zOs/war/rexx2
}¢--- A540769.WK.REXX(DRDALAST) cre=2010-06-21 mod=2010-06-21-14.15.02 A540769 ---
call sqlConnect DBOC
call sqlPreOpen 1, 'select PCK_CONSIST_TOKEN, pck_id, lastUsed' ,
'from RZ2.TACCT_PKGUSED',
'where lastUsed > current date - 1 month'
do while sqlFetchInto(1, ':co, :pkg, :la')
if co <> 0 then
$$- co 'pkg' pkg 'last' la
end
call sqlDisconnect
$#out 20100621 14:14:38
18AB195B16E03DE0 pkg AC1060B last 18.06.2010
18AB195B1B19A8BC pkg AC1060I last 17.06.2010
18B66DF317A71E9C pkg AC1190 last 20.06.2010
18AB1959179D7BFC pkg AC1192 last 18.06.2010
18B3C53907E5CFE9 pkg AC1196 last 18.06.2010
18AB19B60FF64FF3 pkg AC2101 last 18.06.2010
18B3C53F0F2261CC pkg AC2102 last 20.06.2010
18AB19B615BE0272 pkg AC2105 last 20.06.2010
18AB19BC1DF87490 pkg AC7540 last 20.06.2010
1819A0E309014B71 pkg ADBCDCH last 11.06.2010
17F3BCAC09F66210 pkg ADBCDTW last 11.06.2010
1822E35D0E078403 pkg ADBCEST last 11.06.2010
17B022D90D106521 pkg ADBCMRQ last 19.06.2010
18603D8F0D4A2095 pkg ADBCPRE last 12.06.2010
18A121DC0A9C1E0A pkg ADBCRCM last 27.05.2010
18A264BE0E9F499D pkg ADBCRCM last 11.06.2010
18A264C70FDF1ED7 pkg ADBCRCR last 11.06.2010
187ABF44127346A9 pkg ADBCRCR last 27.05.2010
1858F709008D45F5 pkg ADBCUPC last 12.06.2010
187C35C011048701 pkg ADBCVCP last 11.06.2010
185BA8470F622318 pkg ADBCVEX last 12.06.2010
184A07AD05A29DDC pkg ADBCVIC last 11.06.2010
17E51F1106AAAEB9 pkg ADBMAIN last 20.06.2010
17DEA8E01486524B pkg ADBMCCS last 20.06.2010
18AE98A002DC1B24 pkg ADBTEP2 last 12.06.2010
188AF4CB179AB2E0 pkg ADBTEP2 last 03.06.2010
185BA9AF1FF9E54B pkg ADB2CHK last 12.06.2010
17DB3A141EA68018 pkg ADB2CID last 11.06.2010
1678DF0E004395A0 pkg ADB2CON last 20.06.2010
189868660B343BDE pkg ADB2GET last 20.06.2010
183340ED10FAD0AE pkg ADB2PRP last 20.06.2010
18A0F8D11CE06F3C pkg ADB2REM last 07.06.2010
18B1EE870957912F pkg ADB2REM last 20.06.2010
18A07A3E19BE671A pkg ADB2REP last 20.06.2010
18966E4F1B49802E pkg ADB2RES last 18.06.2010
1846BFC107864DB2 pkg ADB2RET last 20.06.2010
189AD5A90FE6E9E5 pkg ADB2REY last 20.06.2010
1879ACAD0350ECDA pkg ADB2RGC last 10.06.2010
188A28691534FB9F pkg ADB2SQL last 11.06.2010
171C42C5012A488A pkg ADB2ZP last 20.06.2010
1895505417B1BEC8 pkg ADB27SP last 11.06.2010
17961DF31BAD529C pkg ADB8SQL last 12.06.2010
188816591A6ADBB1 pkg ALASQL9 last 20.06.2010
188816591F111134 pkg ALASQL9A last 20.06.2010
1888165A0615478B pkg ALASQL9C last 20.06.2010
18B6E4B3064CFAF6 pkg AM0900 last 19.06.2010
189F01D81CD26DA5 pkg AM0920 last 20.06.2010
18A11F1B18CBF0BD pkg ANLCHECK last 03.06.2010
18BBA5AF0B9E2F27 pkg ANLCHECK last 18.06.2010
18730A7C1BEDE203 pkg ANLSETUP last 26.05.2010
18B82B231A54FD95 pkg AP5500 last 18.06.2010
18B98A5A13980F1E pkg AP5510 last 19.06.2010
18B98A5C190E0B88 pkg AP5530 last 18.06.2010
18B82B2D0D25968E pkg AP5540 last 18.06.2010
18B82B2A1A619360 pkg AP5560 last 18.06.2010
18B82B2A02135A90 pkg AP5580 last 18.06.2010
18B93A0E1FD31A99 pkg AP5590 last 18.06.2010
18B82BB4006472EA pkg AP5600 last 20.06.2010
18B82B3505BCA5B2 pkg AP5610 last 20.06.2010
41534E4150504C59 pkg ASNAM802 last 20.06.2010
41534E4150504C59 pkg ASNAP802 last 19.06.2010
41534E434F4D4F4E pkg ASNDB802 last 20.06.2010
41534E434F4D4F4E pkg ASNDD802 last 20.06.2010
41534E434F4D4F4E pkg ASNDF802 last 20.06.2010
41534E434F4D4F4E pkg ASNDM802 last 20.06.2010
177626150670C4BC pkg AT0063 last 03.06.2010
186DA6B4193277D2 pkg AT0099 last 18.06.2010
1899D83B0A7975CB pkg AT7080 last 19.06.2010
189EFE7518F54501 pkg AT7110 last 19.06.2010
189EFE6F19B70604 pkg AT8500 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#DBR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#DBU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#DTR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#DTU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#IXR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#IXU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#ROU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SAU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SCU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SGR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SGU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SRR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SRU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SSU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SYR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#SYU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TBR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TBU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TRR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TRU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TSR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TSU9 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO#TVR8 last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO@DB2V last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO@HIST last 19.06.2010
0C1E4D6F00F2F1F0 pkg AUO@RQI8 last 19.06.2010
18B739031F3B465A pkg AU5070 last 20.06.2010
185C14370B8FA93B pkg AU5100 last 20.06.2010
187081EF0EDA9D73 pkg AU5120 last 20.06.2010
18BA865C08643A7A pkg AU5200 last 08.06.2010
18C119C519640314 pkg AU5200 last 20.06.2010
18BAAEE10B8C3DD0 pkg AU5210 last 20.06.2010
18BC8CC91E67FC82 pkg AU5220 last 08.06.2010
18C146F215DCDD5E pkg AU5220 last 20.06.2010
1883315B09BD8233 pkg AU5760 last 20.06.2010
188383E316CC347E pkg AU5770 last 31.05.2010
18BFD5401464EB4A pkg AV0010 last 20.06.2010
18BCE202048E8AF4 pkg AV0020 last 20.06.2010
186E44DF0DBC95A4 pkg AV0067I last 18.06.2010
186E44E10B8B27CB pkg AV0068I last 19.06.2010
18BFD544097D0E6A pkg AV0075 last 19.06.2010
186E44E701854BB0 pkg AV0079I last 20.06.2010
18BFD54501EBC2C4 pkg AV0080 last 19.06.2010
186E44E900EADFE6 pkg AV0081I last 20.06.2010
186E44EB10B23767 pkg AV0082I last 20.06.2010
186E44ED0BB538DA pkg AV0083I last 18.06.2010
18BE23201514BD54 pkg AV0090 last 11.06.2010
18C32A4F0F309240 pkg AV0090 last 18.06.2010
186C6D9F0FB2F893 pkg AV0101I last 20.06.2010
186E45C213EF509F pkg AV0102I last 20.06.2010
1875882F1CA843A3 pkg AV0105I last 20.06.2010
187588690C80AB06 pkg AV0106I last 18.06.2010
187585F619C89B4B pkg AV0107I last 20.06.2010
18769E4710F1A150 pkg AV0108I last 20.06.2010
186E761E0244DA14 pkg AV0112I last 19.06.2010
186E76A21667DB15 pkg AV0113I last 20.06.2010
186E73250D87BAE2 pkg AV0115I last 20.06.2010
18908A2117C694E8 pkg AV0116I last 20.06.2010
186E45DB13D23CE7 pkg AV0125I last 20.06.2010
187BA97E0061BB83 pkg AV0127I last 20.06.2010
18811ED81C737090 pkg AV0128I last 20.06.2010
186E464F0B9C8D71 pkg AV0129I last 18.06.2010
186E45E415B5DF03 pkg AV0131I last 20.06.2010
18855AF3067C5DE8 pkg AV0132I last 20.06.2010
187CE08C1509F7C2 pkg AV0133I last 20.06.2010
187A8FB0169EEE81 pkg AV0134I last 20.06.2010
188029D81AC0D2C4 pkg AV0135I last 18.06.2010
187943E818C7EC19 pkg AV0136I last 20.06.2010
18B739121B62308C pkg AV0150 last 18.06.2010
18B7391316042884 pkg AV0160 last 18.06.2010
18B73914082E4D60 pkg AV0170 last 19.06.2010
18BFD5450215AFA6 pkg AV0180 last 18.06.2010
18B993BD1C8F0BC0 pkg AV0190 last 18.06.2010
18B739170B76D046 pkg AV0210 last 18.06.2010
18B739171FE52D4A pkg AV0220 last 18.06.2010
18BFD54904595928 pkg AV0230 last 18.06.2010
18B993C0139B6019 pkg AV0240 last 18.06.2010
18BFDF3F06D555CC pkg AV0250 last 18.06.2010
18C02ADB0C686BBC pkg AV0280 last 11.06.2010
18C3045A1090AD0E pkg AV0280 last 14.06.2010
18C40F73155836A0 pkg AV0280 last 18.06.2010
18BFD5491852177E pkg AV0310 last 18.06.2010
187ED0120E900A72 pkg AV0410 last 16.06.2010
187ED0971CC8B8FE pkg AV0440 last 03.06.2010
1895DF0B06FEBA2C pkg AV0450 last 04.06.2010
18B739201EEFC1FC pkg AV0470 last 17.06.2010
18B739211984AF59 pkg AV0480 last 18.06.2010
18B9902417BCFC1A pkg AV0600 last 18.06.2010
18C02AE81A84F5DE pkg AV0630 last 11.06.2010
18C3045B025C6238 pkg AV0630 last 14.06.2010
18C40F7318B3A7B6 pkg AV0630 last 18.06.2010
18BE231D0C2EF26A pkg AV1000 last 20.06.2010
18B707A40D079120 pkg AV5300 last 19.06.2010
18B9368E153706BE pkg AV5530 last 19.06.2010
18B70795045FE31F pkg AV5560 last 19.06.2010
18A89C371043BD0E pkg AV5570 last 19.06.2010
18A89C4016A05070 pkg AV5580 last 19.06.2010
18B738470E6FBDA2 pkg AV5700 last 19.06.2010
18B82159078BEA27 pkg AV5740 last 19.06.2010
18B738481F935624 pkg AV5780 last 19.06.2010
18B707A60F58EE36 pkg AV7210 last 19.06.2010
18B707AA1A896574 pkg AV7220 last 19.06.2010
18B849EE07A2C7D4 pkg AV7240 last 20.06.2010
18A89BDE17E3F5AC pkg AV7460 last 19.06.2010
18BFD54C11ACFC72 pkg AV8100 last 11.06.2010
18C0F5181BAF23D6 pkg AV8100 last 20.06.2010
18B707930036E5F6 pkg AV8141 last 27.05.2010
18BFD54E130D6652 pkg AV8261 last 19.06.2010
18BFD54F0D56DF6C pkg AV8266 last 19.06.2010
18BFD5500F15709C pkg AV8267 last 19.06.2010
18BD06F401E8DA3C pkg AV8460 last 19.06.2010
18B944B7137683C6 pkg AV8465 last 19.06.2010
18B7078404F54156 pkg AV8485 last 19.06.2010
18BAC809172188F2 pkg AV8600 last 19.06.2010
18A8C0261C258758 pkg AV8602 last 19.06.2010
18B93E810EFE5357 pkg AV8604 last 19.06.2010
18A89BE90B20F8C2 pkg AV8608 last 19.06.2010
18B707981F9DD752 pkg AV8910 last 19.06.2010
1852234B0B29F469 pkg A5PO058 last 19.06.2010
18270E741FD7811F pkg BASERSI last 20.06.2010
18270E750004E451 pkg BASERSU last 20.06.2010
18270E7801BA7E0D pkg BASETABI last 20.06.2010
18270E78020B2AE5 pkg BASETABU last 20.06.2010
18270E741354C8CA pkg BASEUGI last 20.06.2010
18270E74175B6B4A pkg BASEUGU last 20.06.2010
18270E7515BF9711 pkg BASEUSI last 20.06.2010
18270E751D37BC4E pkg BASEUSTI last 20.06.2010
18270E751D62448E pkg BASEUSTU last 20.06.2010
18270E7515EAF7C8 pkg BASEUSU last 20.06.2010
18B9939A1C3BA69A pkg BE0090 last 20.06.2010
18534215076612CB pkg BE01DB last 15.06.2010
189AC24415C6036D pkg BE5020 last 20.06.2010
187CC07110260738 pkg BE5050 last 20.06.2010
187CC07413B4B1D3 pkg BE5060 last 20.06.2010
188B85FA0D641A8B pkg BE5090 last 18.06.2010
18A311E00B0FCFC9 pkg BE5160 last 19.06.2010
18B993A813DD5CEA pkg BE5170 last 18.06.2010
189AC24D0442A268 pkg BE5910 last 20.06.2010
187CC0831D6580EC pkg BE5920 last 11.06.2010
18A689F01016CDB0 pkg BE5930 last 20.06.2010
18A689F20AAC658A pkg BE5940 last 20.06.2010
189AC2541BA273B4 pkg BE5950 last 12.06.2010
189AC259080858E8 pkg BE6000 last 20.06.2010
18A7AC390AFADE74 pkg BE7110 last 19.06.2010
189AC269019F2C1B pkg BE7160 last 02.06.2010
189AC26B1019C4C9 pkg BE7170 last 20.06.2010
189AC26D192A6583 pkg BE7180 last 20.06.2010
189AC26F1F2C066A pkg BE7190 last 20.06.2010
189AE8080C1D7E91 pkg BE7200 last 18.06.2010
189AC2720B2549FF pkg BE7210 last 19.06.2010
189AC2731F33C336 pkg BE7220 last 19.06.2010
189AC2751EE85265 pkg BE7230 last 20.06.2010
1838FD201A36983A pkg BE7350 last 18.06.2010
18B9939D15E3BDF2 pkg BE8230 last 16.06.2010
18997FD50B902CBC pkg BF5510 last 19.06.2010
18997FD704E44BF9 pkg BF5520 last 17.06.2010
18B942501F33D79F pkg BG0100 last 18.06.2010
18B94254063AF0AE pkg BG0200 last 18.06.2010
18A7C8C615EFD046 pkg BG0300 last 19.06.2010
18BB6F5917473E50 pkg BG5060 last 18.06.2010
18C27DF11A1FA102 pkg BG5130 last 18.06.2010
18B942391B28E640 pkg BG5140 last 01.06.2010
18BCDE8C0A7886D6 pkg BG5150 last 11.06.2010
18C27DF001C6CB66 pkg BG5150 last 18.06.2010
18B9423908120ECA pkg BG5210 last 10.06.2010
18B9423D18E34E66 pkg BG5220 last 18.06.2010
187CB9EE11C9C3F9 pkg BG5230 last 19.06.2010
18BA7F6E19AA1F3E pkg BG5250 last 19.06.2010
187CC33813656008 pkg BG5260 last 12.06.2010
187CB9E508BB8539 pkg BG5270 last 19.06.2010
187CB9F20C452409 pkg BG5290 last 17.06.2010
18B9423413B2C708 pkg BG5400 last 18.06.2010
18B9425B0D2148C4 pkg BG7800 last 18.06.2010
18B2F6770983CAE3 pkg BG7900 last 18.06.2010
18B942460C9A31D8 pkg BG8150 last 02.06.2010
18B9424713BE7DFD pkg BG8260 last 18.06.2010
18BCDE9204FCB582 pkg BG8520 last 08.06.2010
18C27DF506645388 pkg BG8520 last 18.06.2010
18944B8112091A7A pkg BJMDB2 last 20.06.2010
18AB192C05A981D2 pkg BP0050 last 19.06.2010
18AB192513935744 pkg BP0060 last 20.06.2010
184272580AC7C6B9 pkg BP0170I last 20.06.2010
18356852016F7956 pkg BP0300 last 20.06.2010
18B4386C10A5DA02 pkg BP5010 last 20.06.2010
1872FB950E4CBEC8 pkg BP5030 last 20.06.2010
183DF3EF1BFC66E8 pkg BP5040 last 20.06.2010
18B990231F72E0AE pkg BP5050 last 20.06.2010
189567C0160AFBAE pkg BP5060 last 20.06.2010
18AB192806FAB7C2 pkg BP5070 last 20.06.2010
1825FD861056C375 pkg BP5080 last 20.06.2010
189CF4BE1C2C377B pkg BP7140 last 20.06.2010
189CF52B03BE9CDF pkg BP9060 last 09.06.2010
189CF96712E7590D pkg BQ7010 last 01.06.2010
188E853F0B710425 pkg BQ7810 last 11.06.2010
18B82A41000116E6 pkg BQ7870 last 01.06.2010
18B99377019BE2E6 pkg BS0100 last 18.06.2010
189CF6450BE570C5 pkg BU012@I last 20.06.2010
18A0496B10DBC670 pkg BU013@I last 20.06.2010
18BDF842115E7FDC pkg BU021@I last 12.06.2010
18C13FA508751062 pkg BU021@I last 20.06.2010
18BC66BD07F933A8 pkg BU5100 last 20.06.2010
18B87B651C7155B4 pkg BU8100 last 20.06.2010
18B7FA05159815E8 pkg BW0100 last 18.06.2010
18A9E0651400ECAC pkg BX5030 last 19.06.2010
18BAA47112ADF874 pkg BX5430 last 19.06.2010
189CD0E61DB2B272 pkg BX5700 last 19.06.2010
18BAA48611A4EFC4 pkg BX5800 last 12.06.2010
18BAA471025314E8 pkg BX5810 last 15.06.2010
18B9937815A0B706 pkg BX5900 last 18.06.2010
189B92AB0F43178E pkg BX7720 last 19.06.2010
18BAA47F0F601B78 pkg BX8200 last 19.06.2010
18B993760D2A6706 pkg BX8390 last 18.06.2010
18B670601EFBFB68 pkg CD0010 last 18.06.2010
18B872431E37A69A pkg CD0020 last 18.06.2010
18B871661378949C pkg CD0090 last 20.06.2010
18B84B3007F7CEA9 pkg CD0160 last 18.06.2010
18B847120BA9963B pkg CD0410 last 26.05.2010
18B823AB1B30990C pkg CD0450 last 18.06.2010
188AE271104A0FD3 pkg CD0850M last 20.06.2010
18B6E1E308C27A8E pkg CD0990 last 18.06.2010
1894E87D102F5A6E pkg CD3AR3T last 20.06.2010
1884DF4B0D841DB2 pkg CD3AR4T last 20.06.2010
18426B3D13B28F7E pkg CD3AR5T last 20.06.2010
1894E886015B93C0 pkg CD3AR6T last 20.06.2010
187F398710EDFB38 pkg CD5500 last 20.06.2010
18B19363044BA6A4 pkg CD7430 last 18.06.2010
189B638003279D6A pkg CD7450 last 20.06.2010
1898B05500109A8C pkg CD7570 last 20.06.2010
18962B5E1E6D1243 pkg CD7580 last 02.06.2010
189AE8170C7245C7 pkg CD7650 last 20.06.2010
189AE8721D318EF1 pkg CD7710 last 18.06.2010
189AE88105E9C9D9 pkg CD7720 last 05.06.2010
189AE8840D8B3649 pkg CD7730 last 31.05.2010
189AE8AE01A23A11 pkg CD7740 last 07.06.2010
18A702FB0C6DF382 pkg CD7760 last 19.06.2010
18B7FFB90BFB7CA2 pkg CD8000 last 18.06.2010
18BFACE4050163CC pkg CD8120 last 18.06.2010
18B6207706E94258 pkg CD8120 last 11.06.2010
18B81EA2131677E2 pkg CD8130 last 19.06.2010
18A6AFF0118FEA04 pkg CD8150 last 17.06.2010
18B75BF61E438A25 pkg CD8290 last 31.05.2010
18B75C5809049F7E pkg CD8310 last 17.06.2010
18A667EE01DE927A pkg CD8370 last 18.06.2010
18B75C5A1A37CDAA pkg CD8400 last 19.06.2010
18A8E5A116A317FC pkg CD8430 last 18.06.2010
18B93DA416114DEC pkg CD8440 last 19.06.2010
18B52E15132088E4 pkg CD8510 last 20.06.2010
188B80DD12F85D21 pkg CD8540 last 12.06.2010
18BC92801A4C4284 pkg CE5000 last 11.06.2010
18C053A11B40099C pkg CE5000 last 18.06.2010
18BC9285019DDC36 pkg CE5020 last 11.06.2010
18C053A3050ACBD0 pkg CE5020 last 19.06.2010
18BC9285165EA5E2 pkg CE5030 last 11.06.2010
18C058AE0FC9A388 pkg CE5030 last 19.06.2010
18BC92851E9C4100 pkg CE5100 last 10.06.2010
18C059341455B95A pkg CE5100 last 18.06.2010
18BC92D811186C1A pkg CE5110 last 28.05.2010
18B9967F1F289BA2 pkg CE5200 last 11.06.2010
18C0F49607AF463C pkg CE5200 last 18.06.2010
18B7FF45126202BC pkg CE5210 last 11.06.2010
18C057D70312892E pkg CE5210 last 18.06.2010
18B99681036726F4 pkg CE5230 last 11.06.2010
18C11C4D10EE7FD6 pkg CE5230 last 18.06.2010
18BCDEEA14B51700 pkg CE5300 last 11.06.2010
18C2FE5013BFE4B8 pkg CE5300 last 18.06.2010
18BCDEEA1FCAB4A4 pkg CE5720 last 11.06.2010
18C2FE5412E34D52 pkg CE5720 last 19.06.2010
18B7FF4711CB74CA pkg CE5730 last 11.06.2010
18C057FF056819C2 pkg CE5730 last 18.06.2010
18BCDEEB1FAB328E pkg CE5740 last 11.06.2010
18C2FE560F0AD788 pkg CE5740 last 19.06.2010
18BC926E00F588F8 pkg CE7010 last 11.06.2010
18C058CE18E4D2CC pkg CE7010 last 19.06.2010
18B7FF15044DB254 pkg CE8110 last 10.06.2010
18C1146500C9FBE6 pkg CE8110 last 18.06.2010
18B9968C0B47760E pkg CE8120 last 11.06.2010
18C0F4F118FBEA24 pkg CE8120 last 18.06.2010
18BC919310B884BA pkg CE8200 last 11.06.2010
18C1237B18F9F954 pkg CE8200 last 18.06.2010
18BC927D0FAF965E pkg CE8320 last 11.06.2010
18C0591E1B3583F2 pkg CE8320 last 19.06.2010
18B7FF2008EABACE pkg CE8440 last 01.06.2010
18BC927F059DB5D4 pkg CE8460 last 02.06.2010
18B7FF2607BAC224 pkg CE8500 last 11.06.2010
18C0F59305FCC1BC pkg CE8500 last 19.06.2010
18B7FF271CD55CA8 pkg CE8530 last 01.06.2010
18B822EA0A02D8B2 pkg CE8740 last 20.06.2010
18B80A930CA3397A pkg CE8750 last 15.06.2010
18B93D3707FAED6A pkg CI0050 last 20.06.2010
18BFAC95163C243E pkg CI0060 last 19.06.2010
18B93D381121BE68 pkg CI0060 last 11.06.2010
18B84B250D34859C pkg CI0070 last 18.06.2010
18B84B25188DBCA0 pkg CI0080 last 18.06.2010
18B9638E0811EE66 pkg CI0090 last 18.06.2010
18B9638D1C807120 pkg CI0100 last 17.06.2010
18B873941CBEBD30 pkg CI0210 last 20.06.2010
18BB9BE5061FA5F6 pkg CI0230 last 19.06.2010
18B84BC40B82B818 pkg CI0240 last 20.06.2010
18B8502708107F5E pkg CI0250 last 18.06.2010
18B8503E14E7E598 pkg CI0260 last 18.06.2010
18B84BC50DFD567E pkg CI0280 last 18.06.2010
18B84BC51D10FC10 pkg CI0290 last 18.06.2010
18B93FBC151BB73F pkg CI0300 last 18.06.2010
18B966F807507FD4 pkg CI0310 last 18.06.2010
18BAADA31D5129F8 pkg CI0320 last 19.06.2010
18BDFDF00B29B0D2 pkg CI0600R last 18.06.2010
18B75BFA14C53CA6 pkg CI8040 last 18.06.2010
18B75C23079639E6 pkg CI8250 last 18.06.2010
18B6441C19BA68E4 pkg CJ5000 last 31.05.2010
18B847E71ED4B73A pkg CK5400 last 20.06.2010
18B847D91C65F127 pkg CK5410 last 11.06.2010
18C142061CEC74CE pkg CK5410 last 20.06.2010
18B5C866016FE4F0 pkg CK5420 last 18.06.2010
18B5C8670D9670AE pkg CK5430 last 19.06.2010
189BB6C30543C100 pkg CK7220 last 18.06.2010
189B84C40F92A769 pkg CK7500 last 31.05.2010
189C09D101F3D91E pkg CK7600 last 31.05.2010
189C083C07FB643D pkg CK7700 last 18.06.2010
18B61C8111DADA78 pkg CK8580 last 19.06.2010
18C001DB1DF50540 pkg CK8700 last 10.06.2010
18C14087141C5CDE pkg CK8700 last 18.06.2010
1831EDB80026BE07 pkg CNTRLMXT last 20.06.2010
18B191DA083D9D1D pkg CNTVSMNX last 20.06.2010
18A8EEA60D642B8C pkg CSQ5K600 last 18.06.2010
179F79CC1A787D75 pkg CSQ5L600 last 20.06.2010
179F79C81C536451 pkg CSQ5M600 last 20.06.2010
185CFB4510FA01A4 pkg CSQ5R600 last 20.06.2010
179F79CF19EC7685 pkg CSQ5S600 last 20.06.2010
18547D2109987947 pkg CSQ5T600 last 20.06.2010
186A5A5C1CDE800C pkg CSQ5U600 last 20.06.2010
179F79CC0ABC6CD2 pkg CSQ5W600 last 18.06.2010
18BCFF781125FEA0 pkg CT7400 last 19.06.2010
189C7E6C15E91221 pkg CT7420 last 19.06.2010
189C7E621495F7CE pkg CT7422 last 19.06.2010
189CCE421399A71E pkg CT7425 last 19.06.2010
189CCE4319CE8757 pkg CT7426 last 19.06.2010
18B4ABA70044F441 pkg CT7427 last 19.06.2010
189CCE4605A4B0EA pkg CT7428 last 19.06.2010
189C7E72067F62B7 pkg CT7430 last 19.06.2010
18B4ABA706DB4DC6 pkg CT7435 last 19.06.2010
189C7E6B17E1D72E pkg CT7440 last 19.06.2010
18B4ABA701755E3D pkg CT7445 last 19.06.2010
189C7E601ABECB96 pkg CT7446 last 19.06.2010
189C7E5F052F5B62 pkg CT7447 last 19.06.2010
189C7E601A62811C pkg CT7448 last 19.06.2010
189C7E6018A9D672 pkg CT7449 last 19.06.2010
189C7E6C16F2D0CE pkg CT7450 last 19.06.2010
18B4ABA8095A2FCE pkg CT7451 last 19.06.2010
18B4ABA91F7729DA pkg CT7452 last 19.06.2010
18B4ABAA0897B20B pkg CT7453 last 19.06.2010
189C7E6E06395365 pkg CT7454 last 19.06.2010
189C7E64148FF0AE pkg CT7455 last 19.06.2010
189C7E64166185CE pkg CT7456 last 19.06.2010
189C7E781689BEA0 pkg CT7457 last 19.06.2010
189C7E6A06068A3E pkg CT7460 last 19.06.2010
18BBA0F0011C54B8 pkg CT7465 last 19.06.2010
189C7E6A0605CF3A pkg CT7470 last 19.06.2010
18B4ABA8152A9276 pkg CT7472 last 19.06.2010
18B4ABAA05071738 pkg CT7473 last 19.06.2010
189C7E64148771F8 pkg CT7475 last 19.06.2010
189C7E670C5C1A45 pkg CT7480 last 19.06.2010
189C7E670C66BB58 pkg CT7481 last 19.06.2010
18B4ABA8113B9DA0 pkg CT7483 last 19.06.2010
18B4ABAB01B78CF6 pkg CT7485 last 19.06.2010
18B4ABA7052E33E0 pkg CT7487 last 19.06.2010
189C7E5E19613700 pkg CT7488 last 19.06.2010
189CA5B50C68E2D7 pkg CT7489 last 19.06.2010
189C7E5E18929B17 pkg CT7490 last 19.06.2010
18B207EC0A419B20 pkg CT7510 last 18.06.2010
18B2077319276638 pkg CT7520 last 18.06.2010
18B2077F14A1556E pkg CT7525 last 19.06.2010
18B207A80B230E24 pkg CT7545 last 18.06.2010
18B207B818B5B6F0 pkg CT7550 last 18.06.2010
18B207BE15BBA3C0 pkg CT7555 last 18.06.2010
189C7E601EF3578A pkg CT7600 last 19.06.2010
189C7E661ECECC79 pkg CT7605 last 19.06.2010
18B4ABA9138DF9B7 pkg CT7610 last 19.06.2010
18B4ABA81A14101A pkg CT7611 last 19.06.2010
189C7E670D42B239 pkg CT7612 last 19.06.2010
18B4ABA916E1712E pkg CT7614 last 19.06.2010
189C7E7500BF1D1E pkg CT7615 last 19.06.2010
189C7E781807DD58 pkg CT7616 last 19.06.2010
189C7E721F31C048 pkg CT7617 last 19.06.2010
189C7E770242F58A pkg CT7618 last 19.06.2010
189C7E5E1F10D8D4 pkg CT7619 last 19.06.2010
18B4ABA61D4AB8DE pkg CT7620 last 19.06.2010
189C7E6217B140AB pkg CT7625 last 19.06.2010
189C7E750B68F38C pkg CT7626 last 19.06.2010
189C7E71169B3650 pkg CT7627 last 19.06.2010
189C7E7413FA8545 pkg CT7628 last 19.06.2010
189C7E6A1AEBBCA0 pkg CT7661 last 19.06.2010
18B8A00800642242 pkg CT8000 last 01.06.2010
18B765831D25874E pkg CU9000 last 18.06.2010
189AE6120392C9B9 pkg CV7777 last 18.06.2010
180AA81104B0D57A pkg CWSQLPRO last 01.06.2010
18BCB62F195F5702 pkg CW0020 last 18.06.2010
18B99608009DD8EE pkg CW5800 last 18.06.2010
18B829F90A9BD056 pkg CW8490 last 19.06.2010
188D61D8116C139E pkg CY0100 last 17.06.2010
18B5259B059A2D0C pkg CY5100 last 19.06.2010
187F4358051C15AE pkg CY5110 last 19.06.2010
18B5259C01B7A7FA pkg CY5120 last 19.06.2010
187F436B0879714B pkg CY5130 last 19.06.2010
187F437313EFA328 pkg CY5140 last 19.06.2010
18BACE531F559780 pkg CY5150 last 19.06.2010
187F43A2083B3583 pkg CY5180 last 19.06.2010
188295380BEF3F8E pkg CY5200 last 08.06.2010
18B5259D0AC5CC4C pkg CY5210 last 19.06.2010
189AE2E9039FD799 pkg CY7100 last 19.06.2010
189AE2EB099F33E8 pkg CY7200 last 19.06.2010
18B206A51B335FD2 pkg CZA0011 last 18.06.2010
188E5E0C1D522400 pkg CZA0012 last 10.06.2010
18A083B61487E4A9 pkg CZA0013 last 18.06.2010
188E5E280658B468 pkg CZA0090 last 15.06.2010
18B4B5780A66A774 pkg CZA0091 last 15.06.2010
188E5E2F0EB19530 pkg CZA0092 last 18.06.2010
18B4B64A134A060A pkg CZA0151 last 14.06.2010
18B206F01F6EFBB0 pkg CZA0154 last 18.06.2010
18B4B6DD0F83AD74 pkg CZA0161 last 02.06.2010
18B4B6DF0A75061E pkg CZA0166 last 18.06.2010
18A0B5041B1F4002 pkg CZA0168 last 18.06.2010
18B4B6E2194AF234 pkg CZA0171 last 17.06.2010
188E5E421EDEAF39 pkg CZA0179 last 17.06.2010
18B4B6E91A507E80 pkg CZA0180 last 14.06.2010
18B4B6F015F8B524 pkg CZA0186 last 18.06.2010
18B4B6F61CB677E2 pkg CZA0193 last 18.06.2010
18B4D0421598F013 pkg CZA0200 last 18.06.2010
18B4D05E1F3604BE pkg CZA0204 last 08.06.2010
18B4D06B15729DF7 pkg CZA0209 last 18.06.2010
18B1D6CF17B4360F pkg CZA0215 last 18.06.2010
18A79F4817B49B0C pkg CZA0216 last 18.06.2010
18A79F4E150CA5FC pkg CZA0217 last 15.06.2010
18B27812091CC484 pkg CZA0219 last 17.06.2010
18B4D07D167DAB7A pkg CZA0226 last 09.06.2010
18B4D09203070DAE pkg CZA0233 last 09.06.2010
18B4D0961A84AA40 pkg CZA0238 last 14.06.2010
18B4D09E111A66DD pkg CZA0240 last 08.06.2010
18B4D0AF0ACF8E1C pkg CZA0245 last 17.06.2010
188D841E189A965A pkg CZA0249 last 09.06.2010
188E5E7101A579CE pkg CZA0253 last 18.06.2010
188E5E72135755FB pkg CZA0254 last 18.06.2010
18B4D0B50122ADCC pkg CZA0257 last 18.06.2010
18B4D0BD022528F8 pkg CZA0261 last 10.06.2010
18B4D0C5158518A8 pkg CZA0265 last 10.06.2010
18B4D0CC096FF814 pkg CZA0270 last 18.06.2010
18B4D0F5056CF300 pkg CZA0293 last 15.06.2010
18B4D0F80DCDF2BE pkg CZA0301 last 18.06.2010
18B4D0FB0A7F3192 pkg CZA0302 last 17.06.2010
188E5E791B6628C3 pkg CZA0304 last 18.06.2010
18B4D0FE10589D60 pkg CZA0305 last 18.06.2010
18B7F75E1607F7D0 pkg CZ5079 last 18.06.2010
18AA2A0B1A0E2C40 pkg CZ5120 last 18.06.2010
18B72E691D59B272 pkg CZ5150 last 18.06.2010
18BFAA371ABF2CC4 pkg CZ5175 last 18.06.2010
18B989801626068A pkg CZ5175 last 11.06.2010
18B827EC14CD6806 pkg CZ5179 last 01.06.2010
187EEC0C1D501BF0 pkg CZ5180 last 19.06.2010
18BAAC360DD75594 pkg CZ5190 last 19.06.2010
187F3E541BCC9E04 pkg CZ5200 last 19.06.2010
187BD57C1A00359A pkg CZ5220 last 18.06.2010
187AD7D10C78E848 pkg CZ5230 last 18.06.2010
18B989450C2EE406 pkg CZ5250 last 19.06.2010
18B5EDC71D4A0837 pkg CZ5270 last 19.06.2010
18BACDBD0B2B7AF2 pkg CZ5276 last 12.06.2010
18B5EDCD1A08F479 pkg CZ5280 last 18.06.2010
18B5EF6A0E406462 pkg CZ5285 last 18.06.2010
18B6486E196D2E00 pkg CZ5290 last 18.06.2010
18B63CE117740007 pkg CZ5295 last 19.06.2010
18BFCF9617602290 pkg CZ5300 last 19.06.2010
18B942821356F0F0 pkg CZ5300 last 05.06.2010
18BAAC200E1DD8E8 pkg CZ5480 last 01.06.2010
18B86EBF07F3E1E8 pkg CZ5490 last 01.06.2010
18B63CE509580789 pkg CZ5492 last 01.06.2010
18B5F035099F80D0 pkg CZ5494 last 02.06.2010
18B63B8319AF8D48 pkg CZ5495 last 02.06.2010
18B82B3714AE52F0 pkg CZ5590 last 19.06.2010
18B82B3519B68154 pkg CZ5599 last 22.05.2010
1852F0DE033C6890 pkg CZ5700 last 19.06.2010
188EA0FC1F855B12 pkg CZ5710 last 19.06.2010
1852F0E4036B012D pkg CZ5720 last 01.06.2010
18B82B471777BCD0 pkg CZ5810 last 20.06.2010
18B623DA0D04F24C pkg CZ5860 last 18.06.2010
18BFAA4C0DCD8946 pkg CZ5940 last 20.06.2010
18B8292E0B0C4274 pkg CZ5992 last 19.06.2010
18B70777195ADE30 pkg CZ6000 last 19.06.2010
186E4C221418EF06 pkg CZ6010 last 18.06.2010
187E2B9503B0EA64 pkg CZ6020 last 01.06.2010
18BC86971B07F4A8 pkg CZ6225 last 01.06.2010
18BFAA5015FA1F8A pkg CZ6300 last 18.06.2010
18B9898A1E1810A8 pkg CZ6300 last 10.06.2010
18B828DB0101D760 pkg CZ6400 last 11.06.2010
18C04A6908BEC188 pkg CZ6400 last 18.06.2010
18B828DF03CE4118 pkg CZ6500 last 11.06.2010
18C04A6B1725BF86 pkg CZ6500 last 18.06.2010
18B8040A15AE3254 pkg CZ6600 last 01.06.2010
18B788211E47326A pkg CZ7005 last 31.05.2010
18B2776909A34EDA pkg CZ7060 last 31.05.2010
18B277751B0390F7 pkg CZ7080 last 31.05.2010
18BA562F0DD044B8 pkg CZ7135 last 18.06.2010
18AA2A3019263142 pkg CZ7180 last 01.06.2010
18B72E88011E24EC pkg CZ7192 last 14.06.2010
189B854C0A67AFB8 pkg CZ7195 last 31.05.2010
1850E80C12FC097C pkg CZ7330 last 20.06.2010
18BAAD7919F5D8CA pkg CZ7510 last 20.06.2010
18B2760902D4CEBA pkg CZ7710 last 18.06.2010
18B2761705EB2C9A pkg CZ7715 last 18.06.2010
18B27630194289EA pkg CZ7720 last 18.06.2010
18B27637155B6DD4 pkg CZ7725 last 18.06.2010
18B27640177CD6F0 pkg CZ7730 last 18.06.2010
18B2764600FBBDC2 pkg CZ7735 last 18.06.2010
18B2764C0A884EE8 pkg CZ7745 last 18.06.2010
1850E9D70970C96D pkg CZ7750 last 18.06.2010
18B276561EC5165C pkg CZ7755 last 18.06.2010
18B275631C84BE6C pkg CZ7760 last 18.06.2010
18B2757408197734 pkg CZ7765 last 18.06.2010
18B2757D0B2A09C6 pkg CZ7770 last 18.06.2010
18B2758604FC5DE6 pkg CZ7775 last 18.06.2010
18B2758C029844D2 pkg CZ7780 last 18.06.2010
18A8242B1B3F5A0D pkg CZ7862 last 31.05.2010
187EF508011D69B0 pkg CZ7865 last 31.05.2010
18B82BD81C400076 pkg CZ8010 last 20.06.2010
18B82AF505B17439 pkg CZ8015 last 20.06.2010
18B82AF51E052643 pkg CZ8020 last 20.06.2010
18BACFC61C448468 pkg CZ8030 last 20.06.2010
18B82BEE1757A148 pkg CZ8060 last 19.06.2010
18B2092507542618 pkg CZ8110 last 18.06.2010
18B989911CF40D3C pkg CZ8190 last 19.06.2010
18B988CA0C065A12 pkg CZ8250 last 19.06.2010
18B8481D138E9EFA pkg CZ8260 last 01.06.2010
188EA0E30BF8F3CB pkg CZ8270 last 01.06.2010
18908B680D1263A2 pkg CZ8330 last 18.06.2010
18B6191C003C43BE pkg CZ8400 last 19.06.2010
18B61A6113D111BA pkg CZ8405 last 19.06.2010
18B63D5A0DDD391B pkg CZ8520 last 01.06.2010
18B63B7506DBE6CC pkg CZ8740 last 18.06.2010
18B86E49019335C0 pkg CZ8950 last 18.06.2010
18BACC571DBB6436 pkg CZ8980 last 19.06.2010
1823AACB0F2DB5F5 pkg DCCB81 last 16.06.2010
1835161002FA5064 pkg DCCB81 last 31.05.2010
1823AACC04D4F60D pkg DCKCB81 last 16.06.2010
1823AACC188119EF pkg DCRIO1 last 16.06.2010
1823AAD20DBD6DB6 pkg DDBCB81 last 16.06.2010
1823AA62112BADA7 pkg DESQL81 last 16.06.2010
1835156B11A0D6FE pkg DESQL81 last 31.05.2010
18B7629A05F97C6F pkg DE0020 last 19.06.2010
18B7629B0CDEC618 pkg DE0030 last 19.06.2010
18A8C72D112D4F38 pkg DE0040 last 19.06.2010
18AB42880F3F1B10 pkg DE0050 last 19.06.2010
18B5CB7C0323B82C pkg DE0060 last 19.06.2010
18B2CD5D0A83D0A0 pkg DE0090 last 19.06.2010
18B78E3C13318FC4 pkg DE0100 last 19.06.2010
18B7629D043F363E pkg DE0180 last 19.06.2010
18B7629E1EFB9646 pkg DE0230 last 19.06.2010
18A9AC4D19C7CE82 pkg DE0280 last 19.06.2010
189A9FFB0C821590 pkg DE0290 last 19.06.2010
18B78E3B13B99A55 pkg DE0310 last 18.06.2010
18A9DDDA1E0C11CA pkg DE0320 last 18.06.2010
18A9AC501BC11A80 pkg DE0350 last 19.06.2010
18B78E3A0FC38E40 pkg DE0360 last 19.06.2010
18A9DDDB1CF5BA12 pkg DE0370 last 19.06.2010
189981EF1A52F0CE pkg DE0390 last 19.06.2010
18B5CB7E0286B802 pkg DE0400 last 19.06.2010
18B762A10514EA58 pkg DE0410 last 19.06.2010
18B9946D1A48A75E pkg DE0420 last 18.06.2010
18B762820EAE6CB2 pkg DE0430 last 18.06.2010
18B78E3D14004080 pkg DE0440 last 18.06.2010
18B5CB8B14110D74 pkg DE0490 last 18.06.2010
18BACFB11B36277E pkg DE0810 last 18.06.2010
18BCBC2706FE5A18 pkg DE0820 last 18.06.2010
18B7628B105445AE pkg DE0830 last 18.06.2010
18B762870EB14D38 pkg DE0860 last 18.06.2010
189BD8E61BC220A2 pkg DE0870 last 20.06.2010
18B993340EDB7264 pkg DE0900 last 19.06.2010
18C02EB50656714A pkg DE0910 last 19.06.2010
18B7626B11250589 pkg DE0920 last 19.06.2010
18B7626C049FF5CA pkg DE0930 last 19.06.2010
18BBEA1C00273DEE pkg DE0940 last 19.06.2010
18992E5C12312C27 pkg DE0950 last 19.06.2010
18B7626E16012692 pkg DE0970 last 19.06.2010
188B3BA8088066F4 pkg DE0980 last 18.06.2010
18A6E33B1F1745BF pkg DE0990 last 19.06.2010
18B76270158F397C pkg DE5000 last 18.06.2010
189AE6170BEAE3A8 pkg DE5010 last 18.06.2010
18B762740D554C6B pkg DE5020 last 18.06.2010
187D3A9917469C43 pkg DE5040 last 18.06.2010
18A6E35B0D493CBC pkg DE5090 last 18.06.2010
189BDB100E53714E pkg DE5120 last 18.06.2010
187C9C5F1F398DF6 pkg DE5190 last 31.05.2010
189B8CF502672CE4 pkg DE5300 last 18.06.2010
188BF6FC15AE4EDC pkg DE5310 last 18.06.2010
18B78E361811C81E pkg DE5330 last 18.06.2010
18A6E3640E31B2D9 pkg DE5390 last 18.06.2010
18B7627A095F10A0 pkg DE5600 last 18.06.2010
18B5CB9108982E1E pkg DE5690 last 18.06.2010
189A9FEE07F18C40 pkg DE7120 last 18.06.2010
189B8CF609F9B13A pkg DE7300 last 18.06.2010
188B2FE30D82CC4D pkg DE8010 last 31.05.2010
18A6E2A906EF76BE pkg DE8800 last 10.06.2010
1823AA651BF8ED49 pkg DFKLL81 last 16.06.2010
1894010C083DEC91 pkg DGO@SDOB last 20.06.2010
18BD9C741618C6C6 pkg DG0120 last 20.06.2010
18B821041888C212 pkg DG0120 last 11.06.2010
18B6E092034B7487 pkg DG0250 last 18.06.2010
18BDF74108BC4CAC pkg DG0410 last 11.06.2010
18C211E00CCA9696 pkg DG0410 last 20.06.2010
18B6E07712636888 pkg DG0450 last 18.06.2010
18B8210B13A72002 pkg DG5300 last 11.06.2010
18C1487B0C6F0EDE pkg DG5300 last 19.06.2010
1883854600C83CA1 pkg DG5400 last 19.06.2010
18A314E101ED9634 pkg DG5410 last 19.06.2010
18A0685E109D8D54 pkg DG5430 last 19.06.2010
18B6E0691CD2CC4C pkg DG5470 last 18.06.2010
18B6E8D10681E0BC pkg DG7140 last 01.06.2010
18B6E8720FC8F3FA pkg DG7290 last 01.06.2010
18B6E8720B845C9E pkg DG7320 last 01.06.2010
18B6E8EB1C3EB1A2 pkg DG8070 last 01.06.2010
18B96E4C1C82B24E pkg DG8080 last 19.06.2010
18B8211A0BF01598 pkg DG8090 last 01.06.2010
18B6E8770990D21C pkg DG8130 last 19.06.2010
18B6E87B0636C6DA pkg DG8140 last 19.06.2010
18B6E9331C0FE46C pkg DG8210 last 15.06.2010
18BCE03D1C9BAB06 pkg DG8220 last 26.05.2010
18C1440B0B861A0E pkg DG8220 last 07.06.2010
18C32016061835DC pkg DG8220 last 18.06.2010
18B82BE40E8744A0 pkg DG8360 last 19.06.2010
18B6E87D1414B202 pkg DG8370 last 19.06.2010
18B96E510F0C2868 pkg DG8380 last 19.06.2010
18B6E88603002460 pkg DG8410 last 18.06.2010
18B6E88206B16474 pkg DG8420 last 31.05.2010
18B6E884001705CE pkg DG8440 last 31.05.2010
18B6E87F1F6733C5 pkg DG8450 last 31.05.2010
18B6E887132598E0 pkg DG8460 last 31.05.2010
18B6E8881A5B6D12 pkg DG8480 last 10.06.2010
189BE302087991E6 pkg DG8500 last 31.05.2010
189BE3030A5FEA2C pkg DG8510 last 31.05.2010
189BE30414A1B726 pkg DG8520 last 31.05.2010
1823AA670751E0E0 pkg DILL91 last 16.06.2010
1823AA671A618545 pkg DIPLL81 last 16.06.2010
18B617161AC4ECC8 pkg DI0120 last 11.06.2010
18C11878023224CE pkg DI0120 last 19.06.2010
17AF54D1105DF24A pkg DI049ABI last 17.06.2010
17AF54D10EEF79E9 pkg DI049QBI last 17.06.2010
18B912D619C9CD72 pkg DI0900 last 11.06.2010
18C0FA62144ADE64 pkg DI0900 last 18.06.2010
18B912D808AD9C58 pkg DI0910 last 31.05.2010
187E04D2053306FC pkg DI5120 last 18.06.2010
187E04E60E04EE02 pkg DI5300 last 18.06.2010
18BAB25F1CAEE92A pkg DI5910 last 18.06.2010
189A470E126B7E4A pkg DI7500 last 18.06.2010
189A4712154B7BBC pkg DI7510 last 18.06.2010
189A471A1005179A pkg DI7530 last 18.06.2010
189A6B93135277C4 pkg DI8100 last 28.05.2010
18BA640B0369E690 pkg DI8110 last 18.06.2010
1823AA680DAF747A pkg DKLL81 last 16.06.2010
1823AA6906F97E7E pkg DLOCAT last 16.06.2010
183515F2176A7CB4 pkg DLOCAT last 31.05.2010
18B81D5B147D1E98 pkg DM0090 last 02.06.2010
18B850F20D3637C8 pkg DM0300 last 18.06.2010
18B6261914A7700A pkg DM5000 last 18.06.2010
18B626150E7D826C pkg DM5001 last 18.06.2010
18B2AADE16B662EC pkg DM5200 last 19.06.2010
188C2B4704D87C24 pkg DM8000 last 18.06.2010
187C98A401C389D8 pkg DN5100 last 04.06.2010
18B788F40C765CEE pkg DN8100 last 04.06.2010
18AC83FB1BB7F4EC pkg DO7020 last 20.06.2010
1864D76B1103938C pkg DO70901 last 08.06.2010
18B7569E053CACB2 pkg DP0060 last 11.06.2010
18C023F0181C24BC pkg DP0060 last 18.06.2010
18B669F711A9EA0E pkg DP0070 last 27.05.2010
18B669F81D21E0CA pkg DP0080 last 11.06.2010
18C023F3059BE018 pkg DP0080 last 19.06.2010
18B7573C0DF6B7EF pkg DP0090 last 18.06.2010
18B66A1403CD2E76 pkg DP0190 last 11.06.2010
18C023F6034B835A pkg DP0190 last 19.06.2010
18BA6409156750D8 pkg DP0360 last 01.06.2010
18BB749A13DE8D48 pkg DP0900 last 11.06.2010
18C20D0904EA3974 pkg DP0900 last 20.06.2010
18BAA18D0087B856 pkg DP0910 last 18.06.2010
18B617B30579480E pkg DP0920 last 18.06.2010
18BB764A05C1F91A pkg DP0940 last 11.06.2010
18C0496513BAEE7E pkg DP0940 last 20.06.2010
18B617B4038CEAD6 pkg DP0960 last 20.06.2010
18B5F74F0AA51340 pkg DP0970 last 20.06.2010
18B87D7804E57708 pkg DP0980 last 11.06.2010
18C32EEF1FDC2386 pkg DP0980 last 18.06.2010
18B617DA190EF5C1 pkg DP5010 last 19.06.2010
18B617DB06C90E7E pkg DP5020 last 19.06.2010
18B5F6CD099D0686 pkg DP5080 last 18.06.2010
18B617E10E0A8C04 pkg DP5090 last 31.05.2010
18B617E9021E0674 pkg DP5410 last 19.06.2010
18B5F6D20E045A91 pkg DP5430 last 01.06.2010
18B61A801466D854 pkg DP5440 last 01.06.2010
18B3C31C1CE16204 pkg DP5460 last 18.06.2010
1879A27F0947131E pkg DP5490 last 18.06.2010
1879A28208B33658 pkg DP5500 last 19.06.2010
1879A2841C2B7C16 pkg DP5510 last 19.06.2010
1879A28A09C60313 pkg DP5540 last 19.06.2010
1879A28C1CD5C75C pkg DP5550 last 19.06.2010
1879A28E164DE824 pkg DP5570 last 19.06.2010
18BDA9BB06D54A5A pkg DP5850 last 20.06.2010
18BAA28A18C8D7CE pkg DP5860 last 20.06.2010
18B6DFC414B931E0 pkg DP7020 last 01.06.2010
18B5F70A0F2758EC pkg DP7040 last 02.06.2010
18B5F70B12251B2F pkg DP7050 last 19.06.2010
18B5F70E10A26820 pkg DP7060 last 02.06.2010
18B5F71116E0C09A pkg DP7070 last 18.06.2010
18B99BA40997875E pkg DP7120 last 18.06.2010
18BCD98F0557A16E pkg DP7130 last 19.06.2010
18BCD9930960B0C4 pkg DP7140 last 19.06.2010
18B9984B1AC49AAE pkg DP7150 last 11.06.2010
18C235AD0144A6CA pkg DP7150 last 19.06.2010
18B7F9EC03E86EB6 pkg DP7160 last 01.06.2010
18ABE2B71B0CE095 pkg DP8000 last 19.06.2010
18B61ACE1314C460 pkg DP8010 last 19.06.2010
187DD04F0EB79D98 pkg DP8220 last 19.06.2010
189A4B8B09306BAB pkg DP8230 last 19.06.2010
18A708E607045E2A pkg DP8240 last 14.06.2010
18BCB6D20870056A pkg DP9120 last 07.06.2010
1823AA6A08134A4B pkg DRCB81 last 16.06.2010
1856182D029A8769 pkg DSNATBL8 last 28.05.2010
17F5E3E01FF1858C pkg DSNCLIC1 last 06.06.2010
189FDAF510C243CF pkg DSNCLIC1 last 20.06.2010
17F5E3E31E29347A pkg DSNCLIC2 last 06.06.2010
189FDAF510C3FD57 pkg DSNCLIC2 last 20.06.2010
17F5E3E819278C19 pkg DSNCLIF4 last 06.06.2010
189FDAF60DE23F0F pkg DSNCLIF4 last 20.06.2010
1882C37C08F9F186 pkg DSNCLIMS last 06.06.2010
189FDAF714556201 pkg DSNCLIMS last 20.06.2010
180788C008231B16 pkg DSNCLINF last 06.06.2010
189FDAF90D3D6027 pkg DSNCLINF last 20.06.2010
149EEA901A79FE48 pkg DSNESM68 last 20.06.2010
1847604208116CAA pkg DSNREXX last 20.06.2010
1873C5090A828A66 pkg DSNTEP2 last 20.06.2010
1873C50A111F2972 pkg DSNTEP4 last 19.06.2010
1873C5D604B6B71E pkg DSNTIAD last 20.06.2010
1771EE66027CD724 pkg DSNTIAP last 19.06.2010
18A0E61108660CC7 pkg DSNTIAUL last 06.06.2010
18BB92C81167FA4C pkg DSNTIAUL last 20.06.2010
0E5F9D9F01D4F040 pkg DSNUGSQL last 19.06.2010
0E4D2F4F08F1F1F5 pkg DSQFBOR last 19.06.2010
4040404040404040 pkg DSQFDTVQ last 11.06.2010
4040404040404040 pkg DSQFDYSQ last 19.06.2010
4040404040404040 pkg DSQFESQL last 19.06.2010
0E4D2F5F01F2F7F3 pkg DSQFFSQ7 last 19.06.2010
4040404040404040 pkg DSQFICVS last 19.06.2010
4040404040404040 pkg DSQFIPEL last 18.06.2010
0E4D2F4F08F1F1F5 pkg DSQFLD last 19.06.2010
4040404040404040 pkg DSQFPR last 19.06.2010
4040404040404040 pkg DSQFRCTL last 19.06.2010
4040404040404040 pkg DSQFRDBR last 19.06.2010
4040404040404040 pkg DSQFRDB2 last 19.06.2010
4040404040404040 pkg DSQFRUW last 19.06.2010
0E4D2F5F01F2F7F3 pkg DSQFSDB2 last 19.06.2010
0E4D2F5F01F2F7F3 pkg DSQFSDB7 last 19.06.2010
0E4D2F2F02F8F9F1 pkg DSQFSDB8 last 18.06.2010
0E4D2F3F06F4F2F1 pkg DSQFSDGN last 19.06.2010
4040404040404040 pkg DSQFSDT7 last 11.06.2010
4040404040404040 pkg DSQFSV last 19.06.2010
1823AA6D05E035A5 pkg DTCB91 last 16.06.2010
183515F512C4E990 pkg DTCB91 last 31.05.2010
1823AA6F00B9F9B9 pkg DTSCB91 last 16.06.2010
18697307061D9A11 pkg DT011ABI last 02.06.2010
18B670770CA8F27E pkg DT0800 last 18.06.2010
18B6708008CEB1A5 pkg DT0810 last 18.06.2010
18B6183C03E0D639 pkg DT0820 last 18.06.2010
18B6183C128FC618 pkg DT0830 last 18.06.2010
18B6183E1395128A pkg DT0850 last 18.06.2010
18B6707801C286BC pkg DT0870 last 02.06.2010
18B61841054B3267 pkg DT5000 last 18.06.2010
18A7793C1DDBBA4A pkg DT5010 last 18.06.2010
187A59D6185E3969 pkg DT5410 last 18.06.2010
187A59D801D70B4A pkg DT5420 last 04.06.2010
187A59DB19410FF1 pkg DT5430 last 04.06.2010
1823AA720B142BDA pkg DVILL81 last 16.06.2010
189D1E701C20004A pkg EB5500 last 18.06.2010
18A65D790B98B026 pkg EB8055 last 06.06.2010
18AC637D0F26A6AA pkg EB8374 last 06.06.2010
18AC637F0170549E pkg EB8375 last 06.06.2010
188B08A911FC1525 pkg EB8376 last 06.06.2010
18B93A531E301CBC pkg EC0720 last 20.06.2010
18B8267F1FC351B5 pkg EC0740 last 19.06.2010
18B72E6313244EA6 pkg EC5130 last 18.06.2010
187E4FBE120E8030 pkg EC5306 last 01.06.2010
188B59061584B269 pkg EC5310 last 01.06.2010
187E4FB707382BE1 pkg EC5311 last 01.06.2010
187E4FC40595D557 pkg EC5320 last 01.06.2010
187E4FC204CCC760 pkg EC5330 last 18.06.2010
187E4FC107CB8BE3 pkg EC5335 last 01.06.2010
187E4FC2007D9D5A pkg EC5340 last 01.06.2010
187E4FB90760ECF4 pkg EC5355 last 01.06.2010
187E4FC6120B3917 pkg EC5360 last 01.06.2010
188B590B0ECBCB76 pkg EC5365 last 01.06.2010
188B59090DE9EF4A pkg EC5370 last 01.06.2010
18B7887014AD4CC0 pkg EC5375 last 01.06.2010
188B59100F95DFA8 pkg EC5385 last 01.06.2010
188B591115E992D5 pkg EC5390 last 01.06.2010
189C7E9B028AD389 pkg EC5410 last 20.06.2010
189C7E9B0E5F9437 pkg EC5420 last 20.06.2010
189C7E9C1BAD430F pkg EC5430 last 20.06.2010
189C7E9D15600FB3 pkg EC5440 last 20.06.2010
18B6226B1C833EB6 pkg EC5490 last 02.06.2010
18B63BE91ED2CBC8 pkg EC5491 last 02.06.2010
18B81E581ACA0452 pkg EC5492 last 19.06.2010
188D61A00F949E67 pkg EC5496 last 18.06.2010
18B93B780B7D8868 pkg EC5498 last 18.06.2010
187E4FAD0E226172 pkg EC5502 last 18.06.2010
18B788710A965509 pkg EC5503 last 19.06.2010
188B5C961DDCB9FE pkg EC5504 last 18.06.2010
187E4FA414BA19B2 pkg EC5505 last 18.06.2010
188B5CC41C255ADA pkg EC5506 last 18.06.2010
187E4FB009429AB8 pkg EC5508 last 18.06.2010
18AA080E05695004 pkg EC5509 last 18.06.2010
188B5CC7190E796E pkg EC5510 last 18.06.2010
187E4FA708456C4E pkg EC5511 last 18.06.2010
187E4FB311651CE6 pkg EC5512 last 18.06.2010
188B5D070106686F pkg EC5513 last 19.06.2010
188B5CCC16138F35 pkg EC5514 last 18.06.2010
18B788700FDA76F9 pkg EC5515 last 18.06.2010
188D609F01A71702 pkg EC5516 last 18.06.2010
188B5CD01EACCEDA pkg EC5517 last 18.06.2010
188B5CD510B98367 pkg EC5518 last 18.06.2010
188B5CD71DD26FCE pkg EC5519 last 18.06.2010
188B5CD910617DC2 pkg EC5520 last 18.06.2010
187E4FAC13980009 pkg EC5521 last 18.06.2010
188B5CDC0C5BAC65 pkg EC5522 last 18.06.2010
187E4FB707819F35 pkg EC5523 last 18.06.2010
188B5CDE015088A2 pkg EC5524 last 18.06.2010
188B5CE006310A38 pkg EC5525 last 18.06.2010
187E4FAE14C3DABE pkg EC5526 last 18.06.2010
187E4FBC0801FFEA pkg EC5527 last 18.06.2010
187E4FB90AA05D42 pkg EC5528 last 18.06.2010
187E4FB711523CCC pkg EC5529 last 18.06.2010
187E4FB61DB6AC6A pkg EC5530 last 18.06.2010
187E4FB016623802 pkg EC5531 last 18.06.2010
187E4FBD18EE9152 pkg EC5532 last 18.06.2010
187E4FB90D9E8454 pkg EC5536 last 19.06.2010
187E4FB9091306D2 pkg EC5537 last 18.06.2010
187E4FB212543C26 pkg EC5538 last 19.06.2010
187E4FBF0FC2F803 pkg EC5539 last 18.06.2010
188B5CE31FFE5489 pkg EC5540 last 18.06.2010
188B5CE51CDDDE44 pkg EC5541 last 19.06.2010
188B5D14173271A5 pkg EC5542 last 19.06.2010
187E4FB41CBF6D9C pkg EC5543 last 18.06.2010
188B5CE81BA73DE7 pkg EC5544 last 18.06.2010
18B7887010BB41C8 pkg EC6000 last 19.06.2010
188B5CEB03B49DAE pkg EC6005 last 19.06.2010
187E4FC6176CB69E pkg EC6010 last 18.06.2010
188B5CEE16FAAFD4 pkg EC6015 last 18.06.2010
187E4FCB0A9CCC01 pkg EC6020 last 18.06.2010
187E4FC9103398AA pkg EC6025 last 18.06.2010
188B5D2304B71BA5 pkg EC6030 last 18.06.2010
18B788701BCDAD3D pkg EC6035 last 18.06.2010
187E4FC00B86EBD2 pkg EC6040 last 18.06.2010
187E4FCE03F1792A pkg EC6045 last 18.06.2010
187E4FCB1869DBBE pkg EC6055 last 18.06.2010
189C7DF709557752 pkg EC7005 last 18.06.2010
18AB21851BA4D95E pkg EC7021 last 19.06.2010
18AB218903B8C4D4 pkg EC7022 last 19.06.2010
189C806E10A73284 pkg EC7029 last 18.06.2010
18B7887C05BA16EE pkg EC7030 last 19.06.2010
189C80410A0EE5F4 pkg EC7062 last 19.06.2010
18B7887C0BA97B2A pkg EC7063 last 19.06.2010
189C8041091502F6 pkg EC7064 last 18.06.2010
189C8041032F7B8E pkg EC7065 last 19.06.2010
189C807518DE372A pkg EC7071 last 19.06.2010
189C807805C9FEE9 pkg EC7072 last 19.06.2010
189C807B08E8E32B pkg EC7073 last 19.06.2010
189C807D0B0511FF pkg EC7074 last 19.06.2010
189C808202CCB529 pkg EC7075 last 19.06.2010
189C808515CE0696 pkg EC7076 last 19.06.2010
18B7887C0D3E447E pkg EC7077 last 19.06.2010
18B7887C121451CA pkg EC7078 last 19.06.2010
189C808D09EEC4FE pkg EC7079 last 19.06.2010
189C808F0FF23982 pkg EC7080 last 19.06.2010
189C80CC0FEAA4AD pkg EC7082 last 19.06.2010
189C80D101935A2B pkg EC7083 last 19.06.2010
189C80DD0C9032F8 pkg EC7084 last 19.06.2010
189C80C20A9FAE5C pkg EC7085 last 19.06.2010
189C80CA151497EE pkg EC7086 last 18.06.2010
189C80B810409652 pkg EC7087 last 18.06.2010
189C80A51C97A842 pkg EC7088 last 19.06.2010
189C80A21EC774FC pkg EC7089 last 19.06.2010
189C80931D6721C8 pkg EC7090 last 19.06.2010
18B7887C1725B2E4 pkg EC7091 last 18.06.2010
189C80B218B62461 pkg EC7092 last 18.06.2010
189C8098038D30D8 pkg EC7093 last 18.06.2010
189C80B51EA6B11A pkg EC7094 last 18.06.2010
189C809A0D3FB54C pkg EC7095 last 18.06.2010
189C80DF074A351B pkg EC7096 last 18.06.2010
189C809C1652A277 pkg EC7097 last 18.06.2010
189C809E1A65B4F1 pkg EC7098 last 18.06.2010
189C80A100A30D06 pkg EC7099 last 18.06.2010
189C7EA20BA25721 pkg EC7100 last 20.06.2010
189C80E714CEA053 pkg EC7120 last 19.06.2010
189C80EA0762A659 pkg EC7121 last 18.06.2010
189C80EF128E3328 pkg EC7200 last 18.06.2010
189C80F211B5F248 pkg EC7201 last 18.06.2010
189C80F4172C1982 pkg EC7202 last 18.06.2010
189C80F71A571C33 pkg EC7203 last 18.06.2010
189C80FA0560B68E pkg EC7204 last 18.06.2010
189C810E14376448 pkg EC7205 last 18.06.2010
189C80FD0BD4F333 pkg EC7206 last 18.06.2010
189C81111BE1587A pkg EC7207 last 18.06.2010
189C80FF1DC963D1 pkg EC7208 last 18.06.2010
189C81300CC457BE pkg EC7209 last 18.06.2010
189C810207516FD7 pkg EC7210 last 18.06.2010
189C813808B39D8F pkg EC7211 last 18.06.2010
189C813A10F25FA6 pkg EC7230 last 19.06.2010
18A7FE6D0FE7C364 pkg EC7231 last 19.06.2010
189C813E145C8011 pkg EC7232 last 19.06.2010
189C814017783373 pkg EC7233 last 19.06.2010
189C81421D699E86 pkg EC7234 last 19.06.2010
189C81441FAD2FC4 pkg EC7235 last 19.06.2010
18A7FE6E19707D12 pkg EC7236 last 19.06.2010
18A7FE7002D70D62 pkg EC7237 last 19.06.2010
18A7FE711900FC3A pkg EC7238 last 19.06.2010
18A7FE730F3A6EDC pkg EC7239 last 19.06.2010
189C812203BB4920 pkg EC7240 last 01.06.2010
189C812416FED2E3 pkg EC7241 last 01.06.2010
189C81261B6943BE pkg EC7242 last 01.06.2010
189C812001ABB201 pkg EC7243 last 01.06.2010
189C811E06624836 pkg EC7244 last 18.06.2010
189C811C0861DF77 pkg EC7245 last 19.06.2010
189C8133019290CD pkg EC7246 last 19.06.2010
189C811A05630343 pkg EC7247 last 19.06.2010
189C811715A24C3C pkg EC7248 last 19.06.2010
189C81141C87B9A3 pkg EC7249 last 19.06.2010
189C81CC035F8470 pkg EC7250 last 18.06.2010
189C81CF159EFAB7 pkg EC7251 last 18.06.2010
189C7E0307340F7D pkg EC7405 last 04.06.2010
18B78829085E6A4A pkg EC7999 last 19.06.2010
18B93B791780B248 pkg EC8000 last 01.06.2010
18BAAD3208506F24 pkg EC8030 last 19.06.2010
18B827090C65F34C pkg EC8031 last 19.06.2010
18A8267D1E2F5B3A pkg EC8061 last 18.06.2010
18A826850AE9B15A pkg EC8280 last 18.06.2010
18B788370AA20B6E pkg EC8450 last 05.06.2010
18BD9ED516B488A8 pkg ED012@I last 11.06.2010
18C0EC9605E3CDA8 pkg ED012@I last 18.06.2010
18BD7DC40F3E1768 pkg ED022@I last 18.06.2010
18B71689182C4CD8 pkg ED0600 last 18.06.2010
18B7168A1D1F3F8E pkg ED0610 last 04.06.2010
18B7168B08F248C0 pkg ED0800 last 18.06.2010
18BD08A704200F72 pkg ED0810 last 18.06.2010
18BFDD5A19D7D5CE pkg ED0820 last 18.06.2010
18B7169117F4BF97 pkg ED0830 last 18.06.2010
18B4A923186039F6 pkg ED0840 last 18.06.2010
18B7169204101022 pkg ED0850 last 18.06.2010
18B4A926004A3A3A pkg ED0860 last 18.06.2010
18B4A92718F8618F pkg ED0870 last 18.06.2010
18B8003E01FF866A pkg ED0900 last 18.06.2010
18B82B9C04150158 pkg ED0930 last 18.06.2010
18B992A500D6E292 pkg ED0940 last 18.06.2010
18A430C9046C39E8 pkg ED0950 last 18.06.2010
18BFDD5C011E6894 pkg ED0960 last 11.06.2010
18C112A9144ECE90 pkg ED0960 last 18.06.2010
18BF5B2418628952 pkg ED0970 last 18.06.2010
18A6B5911C278C88 pkg ED0980 last 18.06.2010
18B716980C074D62 pkg ED0990 last 18.06.2010
18B9966E0254870E pkg ED5200 last 18.06.2010
18A7855E1D4D71F2 pkg ED5210 last 18.06.2010
18BD048A1C92E61C pkg ED5220 last 18.06.2010
18A7850D1A185021 pkg ED5240 last 18.06.2010
18B716A20D913AE0 pkg ED5290 last 18.06.2010
187DF9F5053EB80F pkg ED5300 last 18.06.2010
187DFA061457FA5C pkg ED5310 last 18.06.2010
187DF9F800040A08 pkg ED5320 last 18.06.2010
187DF9FA150CB8CC pkg ED5390 last 18.06.2010
18A785261E3A3DF4 pkg ED7340 last 02.06.2010
18B716A409C709CF pkg ED7350 last 02.06.2010
18BD048D09835E08 pkg ED8040 last 02.06.2010
188D6A9708A6AD6A pkg EF5360 last 09.06.2010
189951E301AE876B pkg EF5610 last 02.06.2010
18BDCC1F10F1A850 pkg EF5660 last 01.06.2010
18B5F21E1B907E8A pkg EF7820 last 18.06.2010
187DB2A90CDB2E88 pkg EF8981 last 01.06.2010
187F3A1602372AB9 pkg EF8982 last 01.06.2010
18B70BBF1F4ED3F0 pkg EG5110 last 16.06.2010
18B70BC41E376026 pkg EG7990 last 16.06.2010
18B84B1D06521ED6 pkg EK6410 last 08.06.2010
18B7101A01F69878 pkg EK6420 last 09.06.2010
1899A9E80C9AD3D8 pkg EK6450 last 09.06.2010
1899AA5600BC7969 pkg EK6455 last 09.06.2010
1899AA570ACDF145 pkg EK6460 last 09.06.2010
18981BEA014D0B27 pkg EK6490 last 09.06.2010
18981C010CBCF992 pkg EK6502 last 09.06.2010
189837DF0E4B3DB4 pkg EK6512 last 08.06.2010
189837E40339E586 pkg EK7120 last 09.06.2010
189837E51E73A403 pkg EK7121 last 09.06.2010
189837E71B7EC0C8 pkg EK7122 last 09.06.2010
189837E910C996A1 pkg EK7123 last 09.06.2010
189837EB04F24ACC pkg EK7124 last 09.06.2010
189837EC14F51636 pkg EK7125 last 09.06.2010
189837EE1170073B pkg EK7126 last 09.06.2010
189837F01278CA96 pkg EK7127 last 08.06.2010
189837F30283DB72 pkg EK7600 last 11.06.2010
18981CAA1C699282 pkg EK7605 last 01.06.2010
189837F800D585DE pkg EK7619 last 01.06.2010
189837F91D4C31DC pkg EK7621 last 01.06.2010
189837FC019D1F50 pkg EK7622 last 01.06.2010
189837FD1FD8875B pkg EK7625 last 01.06.2010
189837FF184A3C4E pkg EK7627 last 11.06.2010
18981D3D0EAFB9C2 pkg EK7633 last 09.06.2010
18AD96261B862528 pkg EK7635 last 09.06.2010
18B1DCC2070E94A8 pkg EK7636 last 11.06.2010
18B31A261FDD85AD pkg EK7637 last 11.06.2010
1898380118077244 pkg EK7638 last 11.06.2010
189835A915346224 pkg EK7640 last 11.06.2010
189835A91FF8E43A pkg EK7642 last 11.06.2010
189835AA1D484C44 pkg EK7643 last 11.06.2010
189835AC0275671A pkg EK7645 last 11.06.2010
18B5ECC51CF76636 pkg EK7647 last 11.06.2010
1898380A07E787FA pkg EK7652 last 09.06.2010
189DC22B1F214922 pkg EK7662 last 11.06.2010
1898380E100A8D57 pkg EK7665 last 11.06.2010
189836061325FBE7 pkg EK7670 last 09.06.2010
189838101495D3FC pkg EK7671 last 09.06.2010
18983813066261FE pkg EK7675 last 09.06.2010
1898381702538DB5 pkg EK7676 last 09.06.2010
1898381E0B67FFEA pkg EK7677 last 09.06.2010
189838201574D402 pkg EK7683 last 09.06.2010
18B5C85D111A8FC8 pkg EK7684 last 01.06.2010
1898382500B32970 pkg EK7694 last 01.06.2010
18B5C85F1374D6FC pkg EK7695 last 09.06.2010
18B5ECB617737BC6 pkg EK8000 last 02.06.2010
187AB656033FF4F7 pkg EK8100 last 11.06.2010
187AB65818B63425 pkg EK8110 last 11.06.2010
187AB65B11529B89 pkg EK8120 last 11.06.2010
187AB65C1C6B3E7A pkg EK8130 last 11.06.2010
187AB66615FD2417 pkg EK8419 last 08.06.2010
187AB6670E01C5E2 pkg EK8480 last 09.06.2010
187AB66C06B4E55B pkg EK8481 last 09.06.2010
18B31A2F1AC1A292 pkg EK8482 last 09.06.2010
18B5D01B1E2FB0BC pkg EK8510 last 08.06.2010
18B31A351A23E4D2 pkg EK8520 last 09.06.2010
187AB6701C7AB5CB pkg EK8603 last 02.06.2010
18B5C86319AD1732 pkg EK8618 last 01.06.2010
18B52403165E032C pkg EK8641 last 11.06.2010
189AEE07026EEA80 pkg EK8660 last 11.06.2010
187AB67A0ED0966D pkg EK8661 last 11.06.2010
187AB67C023F11A7 pkg EK8663 last 11.06.2010
189AEE14181499E4 pkg EK8664 last 11.06.2010
189AEE5D0067F6DD pkg EK8666 last 11.06.2010
189F0090158B3091 pkg EK8667 last 11.06.2010
189AEDDE0100D842 pkg EK8668 last 09.06.2010
187AB68C03186EB1 pkg EK8672 last 09.06.2010
18B6E13B13962D09 pkg EK8680 last 09.06.2010
18A77AEF16103612 pkg EK8681 last 09.06.2010
1898382C14140145 pkg EK9999 last 09.06.2010
18B988F117F22071 pkg EQ5000 last 18.06.2010
18B64920129B0272 pkg EQ8925 last 07.06.2010
18B6492403686402 pkg EQ8930 last 07.06.2010
18C0302002C3D1CE pkg ER5020 last 18.06.2010
18B73779109AA734 pkg ER5030 last 18.06.2010
18B737760571464E pkg ER5060 last 01.06.2010
18C2086E119A55A8 pkg ER5060 last 19.06.2010
18BFA9F216D40744 pkg ER5080 last 19.06.2010
188D899B02425C9C pkg ER5140 last 01.06.2010
18B963D00A9B69DE pkg ER5170 last 18.06.2010
18B73779092EE340 pkg ER8020 last 19.06.2010
18B822ED107A3779 pkg EU5000 last 28.05.2010
18B822F1010E38E4 pkg EU5020 last 27.05.2010
18A42D860645CEAC pkg EU7050 last 18.06.2010
187D31A71F05958A pkg EU8030 last 27.05.2010
188BFE3101BF0DEB pkg EV5010 last 18.06.2010
188BFF401F23D3D9 pkg EV5050 last 18.06.2010
18A3B6A70479C7EE pkg EV5090 last 03.06.2010
189AC0B906ABFDE9 pkg EV7000 last 18.06.2010
189A9C0F1ADA5B2F pkg EV7150 last 18.06.2010
188587ED18F9D264 pkg EV8030 last 18.06.2010
188A692D17F8CCED pkg EV8040 last 18.06.2010
18858C6906574E02 pkg EV8100 last 17.06.2010
188BFEE10728F6C1 pkg EV8220 last 18.06.2010
18AB3D0A1A9B863C pkg EV8230 last 17.06.2010
188D1732093734C1 pkg EV8400 last 18.06.2010
188D17341241AF92 pkg EV8410 last 18.06.2010
18BDF37C10461FD0 pkg EV8500 last 17.06.2010
18B985FE071B70C4 pkg EX5010 last 19.06.2010
18BAC7A20A8C8FA0 pkg EX5020 last 17.06.2010
18B985FF02002099 pkg EX5030 last 19.06.2010
18B986050338ACF8 pkg EX5040 last 19.06.2010
18B985FB0B4752A2 pkg EX6000 last 19.06.2010
18B985FA0D2FB0C6 pkg EX6010 last 19.06.2010
18B985F90E7201E2 pkg EX6020 last 19.06.2010
18B98604155219DA pkg EX6030 last 19.06.2010
18B9862F15048AA0 pkg EX7040 last 19.06.2010
18B4DEF510FEA5E8 pkg EX7410 last 19.06.2010
18B985F60B84C438 pkg EX8030 last 31.05.2010
18B985F813BCB947 pkg EX8100 last 01.06.2010
18B985F81310138E pkg EX8110 last 01.06.2010
18B985F903F7FCF4 pkg EX8120 last 01.06.2010
18B985F61D56C650 pkg EX8130 last 03.06.2010
18B985FF1F6EE7B0 pkg EX8150 last 01.06.2010
18B985F71D48C9DA pkg EX8220 last 19.06.2010
18B985FF0EB431D4 pkg EX8300 last 01.06.2010
18B15B9F1DDCE9CC pkg EX8400 last 01.06.2010
18BAC7A818595DDE pkg EX8480 last 19.06.2010
18A31D1D17D975CE pkg FD7110 last 11.06.2010
18B98DB20DE51CE8 pkg FD7120 last 11.06.2010
18B98D9D11EF2471 pkg FD7130 last 20.06.2010
18A31D2501C469CF pkg FD7230 last 10.06.2010
18C26C1C021D1E02 pkg FD7230 last 20.06.2010
18B2CC5618CDE8B8 pkg FD7250 last 10.06.2010
18C2E5D11038AAA4 pkg FD7250 last 20.06.2010
18A31D28036C3360 pkg FD7270 last 10.06.2010
18C0D7710D19914C pkg FD7270 last 20.06.2010
18A31D2906D1972E pkg FD7290 last 20.06.2010
18B70AF6119DA3B6 pkg FF0010 last 18.06.2010
18B98BF11CFAA53A pkg FF0020 last 18.06.2010
18B70AC61DA75870 pkg FF0030 last 20.06.2010
18B70AFC0D13DE3A pkg FF0500 last 20.06.2010
188D4B131EA4D2EA pkg FF0530 last 16.06.2010
189F040A1A9C8996 pkg FF5000 last 19.06.2010
18A9B075186CFDDA pkg FF5020 last 19.06.2010
18B988F610623EE6 pkg FF5030 last 01.06.2010
187E2B1F1F3AF715 pkg FI0200 last 19.06.2010
18AD47D60580B0D0 pkg FI0520 last 10.06.2010
18C027081972D764 pkg FI0520 last 17.06.2010
18BDA6DF19974D6A pkg FI1900 last 11.06.2010
18BFD5D01BDB9FB4 pkg FI2100 last 20.06.2010
18B9901E00B9CA26 pkg FI3400 last 18.06.2010
18C02BB517DCBD78 pkg FI5070 last 31.05.2010
18C1E7ED18DA8698 pkg FI5070 last 04.06.2010
18C2FB680DD53B48 pkg FI5070 last 10.06.2010
18C27E660B655D70 pkg FI5070 last 07.06.2010
18C36F2B18C0257A pkg FI5070 last 18.06.2010
18C4AF90095BBE48 pkg FI5070 last 20.06.2010
18B9903516063559 pkg FI5200 last 18.06.2010
18B9902A071C1EF8 pkg FI5202 last 18.06.2010
18B990311EB95898 pkg FI5210 last 19.06.2010
18AD47D81B7C1D3C pkg FI5240 last 19.06.2010
18BFD72505E6EF22 pkg FI5250 last 10.06.2010
18C36F910E69C080 pkg FI5250 last 19.06.2010
18AD47DB1E89D682 pkg FI5270 last 19.06.2010
18AD47DB02FC0A3A pkg FI5280 last 19.06.2010
18AD47DD0886F67C pkg FI5290 last 18.06.2010
18BFD59A15FCACDC pkg FI5300 last 19.06.2010
18B990490B4C2DE4 pkg FI5400 last 26.05.2010
18C2584E1624228E pkg FI5400 last 07.06.2010
18B9902D04AE35FA pkg FI5500 last 11.06.2010
18C0EFFB0699EC18 pkg FI5500 last 15.06.2010
18C46953158EE094 pkg FI5500 last 18.06.2010
189B8602067B3B3C pkg FI5600 last 18.06.2010
18BFFD44198F6444 pkg FI5700 last 26.05.2010
18C0F440024BED46 pkg FI5700 last 04.06.2010
18C2585115A9E02C pkg FI5700 last 10.06.2010
18C36F8E15C4C3B4 pkg FI5700 last 11.06.2010
18C37A670642C0EC pkg FI5700 last 18.06.2010
18C48A6D05CC9E46 pkg FI5700 last 19.06.2010
18A4A6881606596E pkg FI7030 last 16.06.2010
18C469510C73CFD6 pkg FI7030 last 18.06.2010
18AD47E00A207740 pkg FI7300 last 11.06.2010
18BB77D4085367A4 pkg FI7300 last 19.06.2010
18AD47DE11D63E04 pkg FI7301 last 14.06.2010
18BB78340DA3DC40 pkg FI7320 last 19.06.2010
189B860407351CEF pkg FI7320 last 11.06.2010
189B86120DCF4A65 pkg FI7340 last 19.06.2010
18C257B51C7E19F4 pkg FI7420 last 19.06.2010
18AD47DE1721D266 pkg FI7500 last 19.06.2010
189635961C20540F pkg FI8070 last 15.06.2010
18AD47E30DCD9742 pkg FI8151 last 10.06.2010
18C36F8B14D33D46 pkg FI8151 last 18.06.2010
18A4A68A01F3EFEC pkg FI8160 last 19.06.2010
18B98E1B0AE43B8E pkg FI8200 last 18.06.2010
18C0F3AB18B8AC0C pkg FI9160 last 08.06.2010
18A273F2113F668E pkg FPE@WRPA last 20.06.2010
18954533132C2089 pkg FZ0310 last 19.06.2010
18A9AE9319713F1C pkg FZ0320 last 19.06.2010
18AB3EB8079CB092 pkg FZ0330 last 19.06.2010
18A7D1D5190FE8BA pkg FZ0360 last 19.06.2010
18A10B4A1A0CF323 pkg FZ0390 last 19.06.2010
18B7310007E7EAA5 pkg FZ0800 last 18.06.2010
18A7D37A1F55F2C2 pkg FZ0810 last 18.06.2010
189AE6C510886CEA pkg FZ0820 last 18.06.2010
18B731010730B32E pkg FZ0920 last 18.06.2010
18A9AE8D09F749B9 pkg FZ5000 last 18.06.2010
18B93ADA05622E92 pkg FZ5010 last 18.06.2010
189AE6CA0D94E276 pkg FZ7000 last 18.06.2010
18855AEB060D0F16 pkg GA0110I last 18.06.2010
18B9874F17A8CFF8 pkg GA5030 last 01.06.2010
18C27B4D04DD2686 pkg GA5030 last 04.06.2010
18C281370EBBF8A2 pkg GA5030 last 04.06.2010
18C28633195D80A2 pkg GA5030 last 04.06.2010
18B4D9EA06ECACF2 pkg GA5040 last 18.06.2010
18B644D61EF3E029 pkg GA5200 last 19.06.2010
18AB13C905DF5FA7 pkg GA7050 last 19.06.2010
18AB128E08E63EDB pkg GA7200 last 31.05.2010
18AC0F770958A282 pkg GA7210 last 19.06.2010
18AB13D4005A357E pkg GA7300 last 31.05.2010
18AB13D60A4E7176 pkg GA7400 last 31.05.2010
18B8785206C3267E pkg GA7510 last 04.06.2010
18B5EE691314FBD4 pkg GA7600 last 19.06.2010
18AB13E416D2A4E0 pkg GA8300 last 19.06.2010
1823AA7310120EBE pkg GETID last 16.06.2010
183515F90BACAA10 pkg GETID last 31.05.2010
189F0461015A715F pkg GE0040 last 18.06.2010
189F052112ED33AB pkg GE0050 last 20.06.2010
189F057013BC0103 pkg GE0070 last 18.06.2010
189F059700717272 pkg GE0100 last 18.06.2010
18B988F7046A7E00 pkg GE0130 last 17.06.2010
187C93AC17FA5694 pkg GE0300 last 18.06.2010
189F061F0E4F0C08 pkg GE0430 last 18.06.2010
189F263A0EABD954 pkg GE0440 last 20.06.2010
189BAE201222324A pkg GE7500 last 19.06.2010
18A9B09D1E2EA4A8 pkg GE7510 last 19.06.2010
189A6F21104B1F0A pkg GE7610 last 19.06.2010
189A6F230D020A5D pkg GE7640 last 19.06.2010
18A8EA0410ACF066 pkg GE7660 last 19.06.2010
189BAE21081F2304 pkg GE7770 last 19.06.2010
18A9B0B01423DCD8 pkg GE8000 last 19.06.2010
18B7642115176C28 pkg GM0070 last 11.06.2010
189AC86D19ED0C02 pkg GM0120 last 18.06.2010
188C01E40C234794 pkg GM0130 last 18.06.2010
18B7642415E0CF60 pkg GM0140 last 18.06.2010
18AB3EE014E8CAE6 pkg GM0630 last 11.06.2010
18C027EC166035C0 pkg GM0630 last 18.06.2010
18B76429138B3EB6 pkg GM0850 last 19.06.2010
18B7642811511246 pkg GM0860 last 19.06.2010
189AC88110735B4E pkg GM0870 last 18.06.2010
189AC88305EF1856 pkg GM0880 last 18.06.2010
18A9B49C1F806384 pkg GM0910 last 19.06.2010
18B7642915569C72 pkg GM0930 last 19.06.2010
18B764291B04273A pkg GM0940 last 11.06.2010
18B764291AF98CAA pkg GM0950 last 19.06.2010
18A6E1EF0F881446 pkg GM0960 last 19.06.2010
187BF8151139BC67 pkg GM5450 last 18.06.2010
18BFCF130EB12296 pkg GTF0010 last 18.06.2010
18B4B6DA1AA1B39A pkg GTF0012 last 18.06.2010
18B4B6800C855FAE pkg GTF0032 last 18.06.2010
18B4B6811E19E212 pkg GTF0033 last 18.06.2010
A92617CB3FE54701 pkg G2DRSQL last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#BPRI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#DB2V last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#EPRI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#ERSI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#ERTI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#IOPF last 15.06.2010
0C4D3C3F02F3F040 pkg HAA#IXV8 last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#JPRI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#OBEX last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#OPRI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#UPRI last 19.06.2010
0C4D3C3F02F2F040 pkg HAA#XMLC last 19.06.2010
18BD0D7F09918DE6 pkg HB5000 last 19.06.2010
18BD77971045192A pkg HB7200 last 11.06.2010
18C02A4A057BC02A pkg HB7200 last 19.06.2010
18B82AB81545F84C pkg HB7210 last 18.06.2010
189CF7121146E8E9 pkg HB7220 last 18.06.2010
189CF7161C07B991 pkg HB7225 last 18.06.2010
189CF714133082F9 pkg HB7230 last 31.05.2010
18B82ACC0DF03C93 pkg HB7910 last 01.06.2010
18B82AC60F90FCFA pkg HB7920 last 19.06.2010
18B82AC70355DAFD pkg HB8000 last 18.06.2010
18B82AC40A9272B4 pkg HB8100 last 19.06.2010
18B82ACE1836B507 pkg HB8200 last 19.06.2010
18BA7DC911A58BEC pkg HB8300 last 19.06.2010
18B82ABC05D8A542 pkg HB8400 last 19.06.2010
189CF7120BC957E4 pkg HB8500 last 19.06.2010
18B84FF90D9453EC pkg HB8600 last 19.06.2010
18AAF68F00D952EE pkg HB8710 last 19.06.2010
18BD78D10B623DAC pkg HB8800 last 19.06.2010
18B5F6D10A2C81C5 pkg HY5000 last 18.06.2010
18B70E070D66B5B6 pkg HY5020 last 18.06.2010
18B875410C189DBB pkg HY5050 last 11.06.2010
18C13D1E0275BA92 pkg HY5050 last 18.06.2010
18B70E0D1E75E294 pkg HY5090 last 19.06.2010
18B5F6F70B30FCF8 pkg HY5100 last 18.06.2010
18B5F6FD123A5236 pkg HY5120 last 18.06.2010
18B875441FDB7B54 pkg HY5130 last 11.06.2010
18C13D2107CABF68 pkg HY5130 last 18.06.2010
18B70E111BC2BE54 pkg HY5140 last 18.06.2010
18B5F70A16A1BEB0 pkg HY5160 last 18.06.2010
18B8754916F49657 pkg HY5170 last 11.06.2010
18C13D2616D5B8F6 pkg HY5170 last 18.06.2010
18B8754A12A97AC8 pkg HY5180 last 11.06.2010
18C13D281755C61E pkg HY5180 last 18.06.2010
18B70E2103ABFF0A pkg HY5200 last 01.06.2010
18B70E1F11011EDF pkg HY5210 last 18.06.2010
18B5F72A1C491A3C pkg HY5220 last 31.05.2010
18B70E221DB8A580 pkg HY5230 last 31.05.2010
18B5F730185EE665 pkg HY5240 last 18.06.2010
18B8754C0DC96348 pkg HY5260 last 19.06.2010
18B8754E0A245DD7 pkg HY5270 last 19.06.2010
18B5F73B08FE8210 pkg HY5280 last 18.06.2010
18B5F7511C5BD0B3 pkg HY5620 last 18.06.2010
18B70E2F09D907BE pkg HY5640 last 18.06.2010
18B70E3106BA28F7 pkg HY5660 last 18.06.2010
18B70E3307F8FE88 pkg HY5700 last 18.06.2010
18B5F7781BA90EDC pkg HY5770 last 19.06.2010
18B5F77D0104FA35 pkg HY5780 last 19.06.2010
18B5F7800B1ABE9C pkg HY5900 last 18.06.2010
18B5F7830AAA47D8 pkg HY5910 last 18.06.2010
16FBFB4D11F546CC pkg HZSQLB last 20.06.2010
18B9634416B1B1BD pkg ID6000 last 20.06.2010
18B2F1D008A4207A pkg ID6020 last 19.06.2010
18460D2818929863 pkg ID6030 last 19.06.2010
18B9634510C56921 pkg ID6035 last 19.06.2010
18BBA20B086BB6BA pkg ID6040 last 11.06.2010
18C0F4C616BD319A pkg ID6040 last 20.06.2010
18BB94760A5AC5E6 pkg ID6044 last 11.06.2010
18C007AC1D62EA88 pkg ID6044 last 19.06.2010
18BACF6D1D179C30 pkg ID6045 last 11.06.2010
18C0FBB90F03F516 pkg ID6045 last 19.06.2010
18C232A302EF9A0E pkg ID6055 last 19.06.2010
18BCAED60A03BDF0 pkg ID6060 last 11.06.2010
18C007AF168AA1D2 pkg ID6060 last 19.06.2010
18C2328913D41DF8 pkg ID6065 last 19.06.2010
18BACE7C0FB8C6BA pkg ID6070 last 11.06.2010
18C2652D064A06E6 pkg ID6070 last 19.06.2010
18BCAED41A284104 pkg ID6081 last 11.06.2010
18C21238139054D6 pkg ID6081 last 19.06.2010
183DB3630C6C98B6 pkg ID6090 last 20.06.2010
183DB36316862D9C pkg ID6095 last 20.06.2010
18460E09180645CA pkg ID6100 last 18.06.2010
18B9634803588155 pkg ID6110 last 18.06.2010
18B96D390C5E4F68 pkg ID6170 last 07.06.2010
18C119DD0BEF51BA pkg ID6170 last 20.06.2010
18B96AED0ABDA070 pkg ID6210 last 20.06.2010
18BBA19519858458 pkg ID6310 last 08.06.2010
18B2F1CF15272230 pkg ID6320 last 08.06.2010
1845986B03B849D1 pkg ID6400 last 16.06.2010
1831D1FE15BAB70F pkg ID6500 last 20.06.2010
18B9634817108C48 pkg ID6900 last 11.06.2010
18C257951509FAA2 pkg ID6900 last 16.06.2010
18B995E816BF8B3E pkg ID6910 last 11.06.2010
18C282BE0F17EAD6 pkg ID6910 last 19.06.2010
1861B981041FF4E7 pkg IT0010 last 18.06.2010
18A897BB07A36AB6 pkg IT5310 last 18.06.2010
1844F3ED1EB833B5 pkg IT5503 last 04.06.2010
1844AD83003AD39D pkg IT5504 last 18.06.2010
1844F4AF1C0797D2 pkg IT5600 last 20.06.2010
1895E6310AE6EB61 pkg IT5900 last 19.06.2010
18A895BB1A2CB38A pkg IT5910 last 19.06.2010
183DB37C0DB9957F pkg IT8010 last 18.06.2010
182264280A45D3F1 pkg IT8401 last 04.06.2010
1861B9B508380CCA pkg IT8480 last 20.06.2010
182919DA06C4AC61 pkg IT8481 last 20.06.2010
187E4EBB13DFC07A pkg JM0100 last 18.06.2010
18BAD25D005EC67A pkg JM1900 last 18.06.2010
187E4ECB1F3497C6 pkg JM2000 last 18.06.2010
187E4DD80CBB6756 pkg JM2100 last 17.06.2010
18B615EA196222DC pkg JM2400 last 18.06.2010
187E4ED817CB94F7 pkg JM2500 last 03.06.2010
18B9B63A17065D9C pkg KA4000 last 18.06.2010
18B522E20EF35861 pkg KB5000 last 19.06.2010
18B522E31F7464EE pkg KB5100 last 19.06.2010
18B522E41B61CDDC pkg KB5200 last 19.06.2010
1885D41F1CC14255 pkg KB5300 last 19.06.2010
189C751E1C0B73D2 pkg KB6000 last 01.06.2010
18B962A40BC52610 pkg KC0020 last 18.06.2010
18B98B7A1FBA5292 pkg KC0410 last 18.06.2010
18B8491919539BF8 pkg KC0430 last 07.06.2010
18B98B7211BF5B2E pkg KC0460 last 09.06.2010
18B98B740EB7C35E pkg KC0490 last 08.06.2010
18B987AA11CCC906 pkg KC5400 last 18.06.2010
18B649270D961754 pkg KC7030 last 01.06.2010
18B6492A08744A96 pkg KC8120 last 03.06.2010
189A436D12BEAA24 pkg KC8190 last 03.06.2010
189BE0100AABB75C pkg KC8400 last 31.05.2010
18B96C780F128A98 pkg KE0020I last 20.06.2010
18B96C7A03EB3524 pkg KE0050I last 18.06.2010
18B96C7A0A5F0064 pkg KE0070I last 20.06.2010
18B96C7B17D09C38 pkg KE0100I last 20.06.2010
18B96C7E0924637C pkg KE0130I last 20.06.2010
18B96C7E114424A6 pkg KE0140I last 20.06.2010
18B96C801D4938EE pkg KE0200I last 20.06.2010
18B96C8015EBA8DE pkg KE0210I last 20.06.2010
18B96C81053E3C5C pkg KE0220I last 20.06.2010
18B96C84006C6644 pkg KE0270I last 20.06.2010
18B96C87120850EE pkg KE0280I last 20.06.2010
18B96C88094A4DFA pkg KE0310I last 20.06.2010
18B96C8904E7148E pkg KE0350I last 20.06.2010
18B96C8A037AA588 pkg KE0370I last 20.06.2010
18B96C8A1CDB43FA pkg KE0430I last 20.06.2010
18B96C8B01A64708 pkg KE0470I last 20.06.2010
18B96C8C01551150 pkg KE0490I last 20.06.2010
18B96C8D17C12002 pkg KE0520I last 20.06.2010
18B96C8E06308CA4 pkg KE0580I last 20.06.2010
18B96C8F0327DC1A pkg KE0630I last 20.06.2010
18B96C9016C98284 pkg KE0660I last 19.06.2010
18B96C9112608492 pkg KE0700I last 20.06.2010
18B96C9213A4F902 pkg KE0720I last 20.06.2010
18B96C930151F5CC pkg KE0740I last 20.06.2010
18B96C9801127284 pkg KE0760I last 18.06.2010
18B96C9A07639F10 pkg KE0790I last 20.06.2010
18B670640858D8BA pkg KE5000 last 18.06.2010
18B670640E0E4506 pkg KE5010 last 20.06.2010
18B96B2318363DA2 pkg KE5040 last 01.06.2010
188B39071E645CA9 pkg KE5080 last 18.06.2010
18B670650A8B95AB pkg KE5130 last 18.06.2010
18B67066108598DC pkg KE5170 last 03.06.2010
18B8586C05B4609A pkg KE5180 last 15.06.2010
187E53911ED7E1FA pkg KE5220 last 20.06.2010
18BAAE2609A086FE pkg KE5230 last 24.05.2010
1872142105771D28 pkg KE5280 last 20.06.2010
189A9485082C48D0 pkg KE5320 last 19.06.2010
18BBC0320F8F8AD4 pkg KE5330 last 19.06.2010
1872143606368A9A pkg KE5360 last 18.06.2010
18B6706B13F55FFC pkg KE5400 last 20.06.2010
18B96B2403C804B6 pkg KE5420 last 18.06.2010
18B8026A124D4320 pkg KE5460 last 20.06.2010
18B6706C1FEEBC5D pkg KE5480 last 20.06.2010
189A7B201E167756 pkg KE5490 last 20.06.2010
1871C47F1C58A496 pkg KE5560 last 19.06.2010
18A8E4ED14BF44F8 pkg KE5590 last 04.06.2010
189A7B2B0F22F274 pkg KE7060 last 19.06.2010
18B8020212BA1B6D pkg KS5340 last 20.06.2010
18A8E4EE1F20A1F7 pkg KS5380 last 19.06.2010
18B802221E0FF904 pkg KS5640 last 20.06.2010
18B80206088EF3A6 pkg KS5680 last 18.06.2010
188D625E0973A63C pkg KS5685 last 18.06.2010
1872156206F8DACC pkg KS5700 last 03.06.2010
187215671807DC3E pkg KS5740 last 03.06.2010
188B36FE1936B3C9 pkg KS5870 last 20.06.2010
18B8020613A08E8C pkg KS5880 last 20.06.2010
1894F2681E429F8D pkg KS7330 last 20.06.2010
189A947801E83E29 pkg KS7390 last 03.06.2010
18B4B2FF05B1D4DE pkg LC0500 last 20.06.2010
18B4FA20090E6AFC pkg LC0550 last 20.06.2010
18B4F94A0396EFD2 pkg LC0600 last 18.06.2010
18B5C3410DDF5F58 pkg LC0630 last 18.06.2010
18B6448E15A5C216 pkg LC0640 last 18.06.2010
18B644901285AEEE pkg LC0650 last 20.06.2010
18B712D8110A9F76 pkg LC5010 last 19.06.2010
18B66F271DAB9504 pkg LC5020 last 19.06.2010
18B86F751321FC46 pkg LC5030 last 19.06.2010
18AB130D0BFBE71C pkg LC6200 last 18.06.2010
18AB13131661ED5C pkg LC6220 last 18.06.2010
18B66F2A0340AD62 pkg LC7010 last 18.06.2010
18B66F2A10FE710A pkg LC7020 last 19.06.2010
18B66F2B184DBA85 pkg LC7040 last 19.06.2010
18BB6C730CC56396 pkg LC7050 last 19.06.2010
18B66F2E0596BFDA pkg LC7060 last 19.06.2010
18B3E7DE166E3BD2 pkg LC7320 last 18.06.2010
18AB1315028D01EE pkg LC7330 last 18.06.2010
18B6E60811DB5CA8 pkg LC8000 last 19.06.2010
18AD516702DAE3FD pkg LC8221 last 18.06.2010
18AD51D51181DE31 pkg LC8222 last 18.06.2010
18AD527B1B2681E0 pkg LC8300 last 20.06.2010
18B2095B1ED6E766 pkg LC8800 last 18.06.2010
18B520A7103DC356 pkg LC8820 last 18.06.2010
183DE4BD0E20B572 pkg LG5080 last 20.06.2010
183DB3A50C3D3B9E pkg LG5500 last 20.06.2010
189AC0B0091E6672 pkg LS5010 last 19.06.2010
18A77E2A16E4B691 pkg LS5020 last 19.06.2010
18B93A57142D2A54 pkg LW8450 last 08.06.2010
18C32585106FE730 pkg LW8450 last 09.06.2010
18C348540D82479C pkg LW8450 last 19.06.2010
18962C6B003E0446 pkg LW8570 last 18.06.2010
188EA10612563B52 pkg LW8610 last 15.06.2010
189B91C51F04261A pkg LW8700 last 18.06.2010
18B3C46F0580F024 pkg MB5020 last 20.06.2010
18B3C4701AB1036A pkg MB5120 last 20.06.2010
18B3BEFC13794706 pkg MB5220 last 20.06.2010
187E08D412EED4C6 pkg MC5200 last 18.06.2010
188B3C191D13C0BC pkg MF5000 last 18.06.2010
18A8C5B503B3126A pkg MF5005 last 19.06.2010
189E0AD716F1FD3F pkg MF5010 last 19.06.2010
18B802B10D91578E pkg MF6000 last 02.06.2010
18B802B40AF3A27A pkg MF6010 last 02.06.2010
18B802B409ABB5B6 pkg MF6020 last 02.06.2010
189B646E139BA5DA pkg MF7000 last 18.06.2010
189B64730BFAB8DF pkg MF7025 last 19.06.2010
189B647602CEA0A9 pkg MF7090 last 19.06.2010
189B64770707EB11 pkg MF7091 last 18.06.2010
189B64790D7903CD pkg MF7110 last 19.06.2010
18B802B809B621B4 pkg MF7210 last 18.06.2010
189B687A12159E5B pkg MF7220 last 19.06.2010
18BBF0D419E6FFDA pkg MF7230 last 19.06.2010
18B8090109B20F4E pkg MF7235 last 19.06.2010
189B687E1C1DD8DA pkg MF7240 last 19.06.2010
189B688010DB7A8E pkg MF7250 last 19.06.2010
18B2CDED102C61F2 pkg MF7260 last 19.06.2010
18A7FB001A1199D2 pkg MF7270 last 19.06.2010
189B68860693AB8F pkg MF7275 last 19.06.2010
18B808F91C77053A pkg MF7290 last 19.06.2010
18B57DCC00058B86 pkg MF7300 last 19.06.2010
18B6E7E00BA1DCB4 pkg MF7310 last 19.06.2010
18B57D370E368C2C pkg MF7320 last 19.06.2010
18B8090F0B468390 pkg MF7330 last 19.06.2010
18B57DEE027CF09E pkg MF7340 last 19.06.2010
18B57DFA0ADAFBC6 pkg MF7360 last 19.06.2010
189B68951192127A pkg MF7380 last 19.06.2010
18A397DE11E2BFE0 pkg MF7420 last 20.06.2010
189B689A157AE10F pkg MF7500 last 19.06.2010
189B689D071363FC pkg MF7510 last 19.06.2010
189B689E11761E96 pkg MF7520 last 19.06.2010
189B68A40B8FF619 pkg MF7530 last 19.06.2010
189B68A50FB18EE0 pkg MF7540 last 19.06.2010
18B802B91686C7DC pkg MF7550 last 19.06.2010
189B68A81249E4D3 pkg MF7570 last 19.06.2010
189B68A91BBFB0AF pkg MF7580 last 19.06.2010
189B68AD0D6D3285 pkg MF7590 last 19.06.2010
18B8090710D71DDB pkg MF7600 last 19.06.2010
18A77A8B1965D624 pkg MF7680 last 19.06.2010
18A825761B98AE7A pkg MF7690 last 19.06.2010
189B68B41EDAD520 pkg MF7700 last 20.06.2010
189B68B60B7BA0FC pkg MF7730 last 19.06.2010
189B68B70F4CFF90 pkg MF7740 last 04.06.2010
189B68B900E53767 pkg MF7750 last 03.06.2010
189B68B91AD17BF3 pkg MF7760 last 02.06.2010
18BCFECF076E33BE pkg MF7770 last 19.06.2010
189B68C50CFF0246 pkg MF7780 last 03.06.2010
189B68C61FB17F80 pkg MF7790 last 19.06.2010
189CF51D0604AB49 pkg MF7801 last 18.06.2010
189B68D4076DD7A1 pkg MF7930 last 19.06.2010
18BBED090257FB10 pkg MF8110 last 11.06.2010
18C0076B12419E30 pkg MF8110 last 19.06.2010
18B5C5BB1BC410DF pkg MF8130 last 19.06.2010
18BF51AC0FD46656 pkg MF8200 last 19.06.2010
18B98C7A0EE4EE54 pkg MF8210 last 11.06.2010
18C262D11574ECBA pkg MF8210 last 19.06.2010
18B98C8100E6C434 pkg MF8310 last 19.06.2010
187F167F0F75FAC6 pkg MF8500 last 19.06.2010
18B5FA57129534D8 pkg MF8600 last 19.06.2010
18B5FA57109EBC40 pkg MF8610 last 19.06.2010
18B616280BBF94FE pkg MF8620 last 19.06.2010
18B98C9117AE5CDA pkg MF8630 last 19.06.2010
18B5FA5A06CC43FB pkg MF8640 last 19.06.2010
18B5FA5A17DB7F12 pkg MF8650 last 19.06.2010
18B5FA5E09E99A48 pkg MF8660 last 19.06.2010
18B5FA5B06B75E18 pkg MF8670 last 19.06.2010
18A7852901C08B0C pkg MF8700 last 18.06.2010
189B68F4034FD823 pkg MF8703 last 18.06.2010
189B68F61A3A852A pkg MF8704 last 18.06.2010
189B68F8042F69EE pkg MF8705 last 18.06.2010
189B68F905EDC7B0 pkg MF8706 last 18.06.2010
189B68FA11F0E588 pkg MF8707 last 18.06.2010
189B68FB1D4F7FFE pkg MF8708 last 18.06.2010
189B68FD084BDEB0 pkg MF8710 last 18.06.2010
189B68FE00670320 pkg MF8711 last 18.06.2010
189B68FF1FA27635 pkg MF8714 last 18.06.2010
189B6901135283A4 pkg MF8715 last 18.06.2010
189B6902190590CC pkg MF8716 last 18.06.2010
189B690407313800 pkg MF8717 last 18.06.2010
189B69050AE71492 pkg MF8718 last 18.06.2010
189B6907035F95AD pkg MF8719 last 18.06.2010
189B690801B1D97A pkg MF8723 last 18.06.2010
189B6909047A285E pkg MF8724 last 18.06.2010
189B690A1F38CB74 pkg MF8800 last 19.06.2010
189B690C105CBE3E pkg MF8810 last 03.06.2010
189B690D146EFB92 pkg MF8820 last 03.06.2010
18B8029F178C0A24 pkg MF8920 last 02.06.2010
189B691500940FD6 pkg MF8940 last 02.06.2010
18BB948A0BB844DA pkg MF8950 last 03.06.2010
189B69171D080BE6 pkg MF8955 last 03.06.2010
189B691906B8ED10 pkg MF8956 last 03.06.2010
18B851220873E83A pkg MF8960 last 02.06.2010
18B8090B17D43AE0 pkg MF9100 last 19.06.2010
18B646A40C4C7956 pkg MF9110 last 19.06.2010
18B7648F1FB6BD04 pkg MF9120 last 04.06.2010
18C25BA90EB1A8E6 pkg MF9120 last 18.06.2010
18B98CF50A3BF5B6 pkg MF913@I last 20.06.2010
18BDCB1D0A56BDB0 pkg MF931@I last 18.06.2010
18AB41470443B564 pkg MI5000 last 20.06.2010
189CD2A21BFEE6D0 pkg MI5200 last 20.06.2010
187DF96D1F4652FA pkg MI5300 last 20.06.2010
18A3AFB21A941B55 pkg MI5400 last 20.06.2010
18BF3CF710BCDEB4 pkg MI5500 last 20.06.2010
189AE5DC1D8A2ECF pkg MI5500 last 11.06.2010
1899A2991EF01561 pkg MI5600 last 20.06.2010
18BFB4151270A664 pkg MI5700 last 20.06.2010
1899A29B146A018B pkg MI5700 last 11.06.2010
18BF3CF608C12DF6 pkg MI5800 last 20.06.2010
189AE5DE01FDDB23 pkg MI5800 last 11.06.2010
189AE5DF138602D9 pkg MI6000 last 20.06.2010
189AE5E109A66EDF pkg MI6100 last 20.06.2010
189AE5E301E2DC19 pkg MI6200 last 20.06.2010
189AE5E4154FC5E2 pkg MI6300 last 20.06.2010
189AE5E519756C03 pkg MI6400 last 20.06.2010
185C0AB80D3FDB50 pkg MQ1011 last 18.06.2010
189E0C190813EFBB pkg NF4040 last 18.06.2010
189E0C1A11BC4B0D pkg NF4050 last 19.06.2010
189AC3BD04471C1F pkg NF4060 last 15.06.2010
189AC3BE180F6B8F pkg NF4070 last 12.06.2010
189AC3C00872B2FC pkg NF4080 last 18.06.2010
189E0C1E02229139 pkg NF4110 last 15.06.2010
189E0C1F04F53B3B pkg NF4120 last 15.06.2010
189AC097021DD749 pkg NF4130 last 12.06.2010
189E0C201642AB09 pkg NF4140 last 16.06.2010
18B5C70011015BC2 pkg NF4170 last 16.06.2010
18AD28BB1E6BD04C pkg NF4180 last 15.06.2010
189AC0A5114CF1EF pkg NF4190 last 10.06.2010
187DFCB418C84D3E pkg NF5000 last 20.06.2010
188EA797081F3484 pkg NF5120 last 20.06.2010
1859B277031D1B40 pkg NF5200 last 20.06.2010
18BD03B800301566 pkg NF5310 last 20.06.2010
18A79D98174588E9 pkg NF5400 last 20.06.2010
1871BC58156CD741 pkg NF5410 last 20.06.2010
18B7FBB700D0614C pkg NF5500 last 20.06.2010
18A79D990E2D9698 pkg NF5510 last 20.06.2010
189066F50ECE5A1A pkg NF5520 last 18.06.2010
18B6156D171D7F3E pkg NF5530 last 31.05.2010
18A0E97204AE60D0 pkg NF5540 last 20.06.2010
18589A920B2836F1 pkg NF5550 last 20.06.2010
18B6E8DF0E2A036C pkg NF5600 last 19.06.2010
18A79D221CE792F0 pkg NF5610 last 19.06.2010
18B6E94B0F48C4D2 pkg NF5640 last 19.06.2010
1859B2AB1C9AE60C pkg NF5700 last 20.06.2010
18A79D9A19B71611 pkg NF5720 last 20.06.2010
187331650EF9A258 pkg NF5880 last 20.06.2010
189AC4F11E865B61 pkg NF6000 last 20.06.2010
189AC4F4116F8A08 pkg NF7000 last 20.06.2010
189AC4F709802114 pkg NF7020 last 20.06.2010
189AC5DA1877525A pkg NF7040 last 20.06.2010
189AC5DF0387E054 pkg NF7060 last 20.06.2010
189AC5E51F8CEFB3 pkg NF7070 last 20.06.2010
189AC5F01325072C pkg NF7110 last 20.06.2010
189AC5F50BDB3554 pkg NF7120 last 18.06.2010
189AC60B0196A037 pkg NF7200 last 20.06.2010
189AC61511A92DD2 pkg NF7220 last 20.06.2010
189AC61B1C0D829F pkg NF7240 last 20.06.2010
189AC61E0F01115F pkg NF7300 last 20.06.2010
18B7059211C460FE pkg NF7510 last 19.06.2010
189AC64813F0E7B3 pkg NF7520 last 20.06.2010
189AC3F100083C80 pkg NF7540 last 20.06.2010
189AC64E16AF48EA pkg NF7550 last 19.06.2010
189AC42300D35CC0 pkg NF7620 last 19.06.2010
18B0C1AB082D3C94 pkg NF7700 last 19.06.2010
189AC658147AED95 pkg NF7830 last 20.06.2010
188C79211DD42C13 pkg NG5001 last 18.06.2010
188DBA4F0E313947 pkg NG5002 last 18.06.2010
1899D8D41FA0AF2C pkg NG5003 last 18.06.2010
188C792615C729FC pkg NG5007 last 18.06.2010
18A6E381131184C2 pkg NG5008 last 19.06.2010
1899D8DA1FE623A7 pkg NG5010 last 18.06.2010
187DFB8313FC51A3 pkg NG5020 last 18.06.2010
18A6E38506E0C0F0 pkg NG5050 last 18.06.2010
1899D8A41BB10EC0 pkg NG7530 last 18.06.2010
18B61DDA0F8BBEAC pkg NG7600 last 18.06.2010
1899D89E1E35DF5A pkg NG7610 last 18.06.2010
1899D8A209C55F72 pkg NG7630 last 18.06.2010
18A4587B05087D4B pkg NG7650 last 18.06.2010
18A33CC10D48B64E pkg NG7670 last 18.06.2010
18A6E38B04C51E2E pkg NG7740 last 18.06.2010
18AFB31B0B4FDC82 pkg NG7750 last 18.06.2010
18A89F511C45B506 pkg NG7760 last 18.06.2010
1899D89D07C6C8C7 pkg NG7770 last 18.06.2010
1899D8A606D5B254 pkg NG7780 last 18.06.2010
18BC6345037BB310 pkg NIOD1@I last 11.06.2010
18BFAA530116DC12 pkg NIOD1@I last 19.06.2010
18BE25C105DD58A8 pkg NI0010 last 18.06.2010
18B9435E07F963CF pkg NI0040 last 18.06.2010
18B55AE71F1E0F30 pkg NI132AAI last 19.06.2010
18B55AE71F59783C pkg NI132AAU last 19.06.2010
18B55AE71EA3D294 pkg NI142AAI last 18.06.2010
18B55AE71EE4E8E0 pkg NI142AAU last 18.06.2010
18B55AE71E7C8BCC pkg NI300HAD last 18.06.2010
18B55AE71E156D7C pkg NI300HAU last 19.06.2010
18B27A33007BFE13 pkg NI5230 last 19.06.2010
18BA84B5034CECCA pkg NI5300 last 19.06.2010
18BA879B0E6BBB16 pkg NI5310 last 19.06.2010
18C1477209B53DFE pkg NI5330 last 19.06.2010
18C14772112AA846 pkg NI5340 last 19.06.2010
18B20BFF0EE5A6C8 pkg NI5470 last 19.06.2010
18BFFF3703E65DDE pkg NI5600 last 11.06.2010
18C1477518A86EE2 pkg NI5600 last 18.06.2010
18C4624C03CB125A pkg NI5600 last 19.06.2010
18B20BCD1A068746 pkg NI6270 last 03.06.2010
18B55AE71BBC4168 pkg NI660AAI last 18.06.2010
18B20BBA03782DDC pkg NI6860 last 05.06.2010
18C2306C06F4D23E pkg NI6860 last 19.06.2010
18B20BB61621B3A4 pkg NI6870 last 03.06.2010
18B20BB904D950FC pkg NI7010 last 11.06.2010
18C1477D13E47A52 pkg NI7010 last 19.06.2010
18BF415B0E44DFA4 pkg NI702AAI last 19.06.2010
18BF415B0EF2B796 pkg NI702AAU last 19.06.2010
18BF415B0E74CDC2 pkg NI702ABI last 19.06.2010
18BF415B0F30C9B0 pkg NI702ABU last 19.06.2010
18BF415B0EB68394 pkg NI702ACI last 19.06.2010
18BF415B0F4C6B54 pkg NI702ACU last 19.06.2010
18BF41151547621C pkg NI702ADI last 19.06.2010
18BF411515BCCBE2 pkg NI702ADU last 19.06.2010
18B27C3A0C67FE5A pkg NI7170 last 19.06.2010
18BF41151625B7FA pkg NI740AAI last 02.06.2010
18BF411516F387A4 pkg NI740AAU last 07.06.2010
18BF4115168A0818 pkg NI740ABI last 02.06.2010
18BF411517BDB07A pkg NI740ABU last 07.06.2010
18BF415B05B92DC0 pkg NI740ACI last 02.06.2010
18BF415B0D947D78 pkg NI740ACU last 07.06.2010
18BF415B06186940 pkg NI740ADI last 02.06.2010
18BF415B0DBE14E8 pkg NI740ADU last 07.06.2010
18BF415B0D575072 pkg NI740AEI last 02.06.2010
18BF415B0DE781B6 pkg NI740AEU last 07.06.2010
18B970740EBC4CC8 pkg NI7400 last 19.06.2010
185371461E4619F7 pkg NI742AAU last 17.06.2010
185371461F0E14DC pkg NI744AAI last 10.06.2010
185371461F4D34CA pkg NI744AAU last 16.06.2010
185C34F3170B26A4 pkg NI744ABI last 10.06.2010
185C34F3177192E6 pkg NI744ABU last 16.06.2010
18B9438E0EB04BAD pkg NI7450 last 18.06.2010
18BF4115182A853C pkg NI746AAI last 12.06.2010
18BF411518E7D0B2 pkg NI746ABI last 12.06.2010
18BF41151AB5DD2E pkg NI747AAI last 12.06.2010
18BF41151BC8DB74 pkg NI747AAU last 12.06.2010
18BF41151B464A70 pkg NI747ABI last 12.06.2010
18BF41151C4D0840 pkg NI747ABU last 12.06.2010
18BF41160087F24E pkg NI760AAI last 26.05.2010
18B20BAD16664D58 pkg NI7600 last 19.06.2010
18BF411601B82CB4 pkg NI770AAI last 31.05.2010
18BF411602D936D6 pkg NI770AAU last 14.06.2010
18BF4116024677EC pkg NI770ABI last 31.05.2010
18BF4116035277A6 pkg NI770ABU last 14.06.2010
18B971DF00FEE422 pkg NI7900 last 19.06.2010
18B20BAF075C4566 pkg NI8000 last 18.06.2010
18B70EB103AA7EFE pkg NI8150 last 19.06.2010
18B9470B0A63625A pkg NI8170 last 19.06.2010
18B20BD71E33E61E pkg NI8260 last 18.06.2010
18BA9FCA12DC3AFC pkg NI8500 last 11.06.2010
18C147811F1A5A1A pkg NI8500 last 19.06.2010
18B9439C10F87490 pkg NI8520 last 10.06.2010
18B9439E1D394FC8 pkg NI8610 last 11.06.2010
18C1478216219000 pkg NI8610 last 19.06.2010
18B96CE811A9204E pkg NI8890 last 18.06.2010
18B20BE01CA86CAA pkg NI8895 last 20.06.2010
18B803741B42AFEC pkg NI8940 last 18.06.2010
18B8037C16070EDA pkg NI8950 last 19.06.2010
18B803891DFC3188 pkg NI9060 last 19.06.2010
18BCDD5D177A3DA0 pkg NI9070 last 14.06.2010
18B75A3411F2968D pkg NJ5020 last 20.06.2010
18B75A341C5000A6 pkg NJ5050 last 20.06.2010
187CEDDF1CE1DD34 pkg NL5000 last 19.06.2010
1882404E03DA10D4 pkg NL5070 last 19.06.2010
188B803115ED2E22 pkg NL5080 last 19.06.2010
188241000A3BD1CC pkg NL5100 last 19.06.2010
1882411602F9A7AA pkg NL5110 last 19.06.2010
188241240240860A pkg NL5510 last 19.06.2010
189CF17206854EE3 pkg NL5900 last 18.06.2010
189CF1700941D4CD pkg NL7020 last 19.06.2010
18C02E9C10883B92 pkg NL7300 last 19.06.2010
187E09491F3B5A64 pkg NL7300 last 11.06.2010
18B5543A0D7DFC00 pkg NL7310 last 11.06.2010
18C02BA6076459BA pkg NL7310 last 19.06.2010
18BFDD411C413390 pkg NL7330 last 19.06.2010
189CF166003E0816 pkg NL7330 last 11.06.2010
18BFDDA81ADD36E8 pkg NL7340 last 19.06.2010
189CF16904B24ED4 pkg NL7340 last 11.06.2010
18BFDD4413F9AEBC pkg NL7350 last 19.06.2010
18B5543C066C2B7A pkg NL7350 last 11.06.2010
18C0013F002E5B66 pkg NL7370 last 19.06.2010
189CF15F1E5F7E32 pkg NL7370 last 11.06.2010
18B82797043BDA4D pkg NL7380 last 11.06.2010
18AD79C216877662 pkg NL7390 last 01.06.2010
18BFDDCF00CA9410 pkg NL7470 last 19.06.2010
189CF1630412FF86 pkg NL7470 last 11.06.2010
18BFDD460A1B325E pkg NL7480 last 19.06.2010
18B39C290A7A925D pkg NL7480 last 11.06.2010
189CF16401F61DAE pkg NL7500 last 01.06.2010
18B82AB81ED561A2 pkg NL7510 last 19.06.2010
189CF7120A10EDA0 pkg NL7520 last 18.06.2010
189CF1721ADB0F2C pkg NL7570 last 09.06.2010
189CF16908AEC2C7 pkg NL7590 last 01.06.2010
18A06CD1071996F0 pkg NL7700 last 19.06.2010
18BFDD4D09227582 pkg NL7740 last 19.06.2010
189CF1651BAF62B5 pkg NL7740 last 11.06.2010
189CF16C04F75975 pkg NL7750 last 11.06.2010
18BFDDC603FC3030 pkg NL7800 last 19.06.2010
189CF162061F71F2 pkg NL7800 last 11.06.2010
18BFDD9206F7E65E pkg NL7810 last 19.06.2010
189CF168092E23B1 pkg NL7810 last 11.06.2010
18B827C317D90BF4 pkg NL7830 last 11.06.2010
189CF7191868B028 pkg NL7850 last 18.06.2010
18B39C3F14FC762C pkg NL8000 last 11.06.2010
188B8059131409DE pkg NL8060 last 19.06.2010
188B805F0AA4DB16 pkg NL8070 last 19.06.2010
18B8283211831046 pkg NL8580 last 11.06.2010
18A317160FDCEBB5 pkg NL8821 last 19.06.2010
18B6E4751ABD3E98 pkg NO0200 last 19.06.2010
18B6E45F17C9E0A1 pkg NO0210 last 19.06.2010
18B6E01B0F140F92 pkg NO0930 last 19.06.2010
189A9D8C154A1006 pkg NO0950 last 19.06.2010
18B7629319D4DB0C pkg NO0960 last 18.06.2010
18B730B706EE1AFE pkg NO0970 last 19.06.2010
187DFA390A679594 pkg NO5420 last 18.06.2010
18B6E45116C4C056 pkg NO8100 last 09.06.2010
18B6E4520E0E66CE pkg NO8110 last 09.06.2010
18B988571392D252 pkg NP0010 last 20.06.2010
187C1FE712C3D0B6 pkg NP0110 last 20.06.2010
187C1FEB0C005114 pkg NP0120 last 20.06.2010
188336CD1AAE334C pkg NP0130 last 20.06.2010
188336D90CC22584 pkg NP0140 last 20.06.2010
1899AB980833EFB4 pkg NP0160 last 20.06.2010
184A939A0D8BF6F4 pkg NP0170 last 16.06.2010
188336ED07BD5E9A pkg NP0180 last 20.06.2010
189F4ACE0A715C2A pkg NP5010 last 19.06.2010
18B989501CB223F2 pkg NP5100 last 19.06.2010
18B9892512E5B312 pkg NP5120 last 19.06.2010
189F4AD110D3437C pkg NP5130 last 05.06.2010
189F4AEE1CEDC6EA pkg NP5150 last 19.06.2010
18B98926068D03E6 pkg NP5200 last 19.06.2010
18B2CE4D07F10673 pkg NP5210 last 05.06.2010
18BAA4C0087BAAE6 pkg NP5220 last 05.06.2010
18B989270A495FE1 pkg NP5230 last 05.06.2010
18B9892800392554 pkg NP5240 last 05.06.2010
189BB5DE19D12113 pkg NP5250 last 05.06.2010
18BCDBB2022BD9AA pkg NP5640 last 05.06.2010
189F4B09025BA62B pkg NP7000 last 19.06.2010
189F4B1317D95DD6 pkg NP7240 last 05.06.2010
189F4B18182EAFC1 pkg NP7250 last 05.06.2010
1868269A165F80AD pkg NP8100 last 05.06.2010
18AF2F7C1F70E510 pkg NP8110 last 19.06.2010
189F4C9510AA58E0 pkg NP8210 last 18.06.2010
18A1116117C67086 pkg NP8220 last 15.06.2010
18B989281F357074 pkg NP8260 last 05.06.2010
180EBF680D4750DA pkg NT0129 last 20.06.2010
18B5F9770980F7A1 pkg NZDBM70 last 20.06.2010
18B70FF60463B3EA pkg NZDBM71 last 20.06.2010
18B5F97B0CC92826 pkg NZDBM72 last 20.06.2010
18B5F97E0B86A96A pkg NZDBM73 last 20.06.2010
18B84AEB0177734A pkg NZDBM74 last 20.06.2010
18B614930FD9EE09 pkg NZDBM75 last 18.06.2010
18B6149D1B862826 pkg NZDBM76 last 20.06.2010
18B614A61B13B19E pkg NZDBM77 last 20.06.2010
18B614AF1F07E597 pkg NZDBM79 last 20.06.2010
18B614AB167639DC pkg NZDBM80 last 21.06.2010
18B614D41D16D122 pkg NZDBM81 last 20.06.2010
18B614E100F23003 pkg NZDBM82 last 20.06.2010
18B82A0214E16906 pkg NZDBM83 last 20.06.2010
18BA8A1A0BDE78AA pkg NZDBM84 last 20.06.2010
18B614FD156F232D pkg NZDBM85 last 20.06.2010
18B64B6919AF122C pkg NZDBM86 last 20.06.2010
18B52B850A8CC90D pkg NZDBM87 last 20.06.2010
1871E9A30369A8D9 pkg NZERR00 last 20.06.2010
1863DFDB17A69C0A pkg NZERR01 last 20.06.2010
18B614B71B663A86 pkg NZERR02 last 19.06.2010
18B6150F06BF3EA2 pkg NZERR90 last 19.06.2010
187C2075155AF6F1 pkg NZERR99 last 20.06.2010
18A6B8F91DBE14A4 pkg NZINT01 last 20.06.2010
1861AFDF1D5BF464 pkg NZPMM01 last 20.06.2010
18B61579116180D8 pkg NZSRV01 last 20.06.2010
18B6158A19BD25F6 pkg NZSRV02 last 20.06.2010
18A911B10DF3F90A pkg NZSRV03 last 20.06.2010
18B615801E864EA4 pkg NZSRV04 last 20.06.2010
18A7F66D03D78FFA pkg NZSRV05 last 20.06.2010
18B82A930DA20688 pkg NZSRV06 last 20.06.2010
18B6172016DE9B4C pkg NZSRV08 last 20.06.2010
18B6173817D32D34 pkg NZSRV12 last 20.06.2010
18B6173A1AE9EDF0 pkg NZSRV14 last 20.06.2010
18B617410852F978 pkg NZSRV19 last 18.06.2010
1863E0131B4816E4 pkg NZSUP02 last 18.06.2010
1863E03C1A0880D4 pkg NZTSM11 last 20.06.2010
1863E01E0E9254DC pkg NZTSM12 last 20.06.2010
1863E01F1AB12DA0 pkg NZTSM14 last 16.06.2010
18A90FAC0BEE692A pkg NZTSM15 last 16.06.2010
1865CB460C0FE6D8 pkg NZTSM16 last 19.06.2010
18A90EC11EA225F8 pkg NZTSM17 last 18.06.2010
18B61767029CA8E1 pkg NZTSM20 last 20.06.2010
18B617280656DF7E pkg NZ0510 last 19.06.2010
18B617261A4250CA pkg NZ0520 last 20.06.2010
18B82A9D1F3EE02E pkg NZ0530 last 20.06.2010
18A7F5F018E16008 pkg NZ0540 last 20.06.2010
18B6172003B082EC pkg NZ0630 last 20.06.2010
18B82A8B17FCC23C pkg NZ0900 last 25.05.2010
18C0EFAE04076A84 pkg NZ0900 last 20.06.2010
18B5FC5D0106158A pkg NZ0930 last 18.06.2010
188C1CDF065B1D8A pkg NZ0940 last 20.06.2010
18B61F3F1AF9D0A2 pkg NZ0960 last 18.06.2010
1889E9CE1C7A2A9A pkg NZ0970 last 18.06.2010
18A6B8FA14B847F6 pkg NZ0990 last 18.06.2010
18AC89D91FFA106A pkg NZ5000 last 19.06.2010
18B63C940B64B8D0 pkg NZ5010 last 20.06.2010
188B0DCA0CC5B62E pkg NZ5020 last 20.06.2010
18AAD02206CAAE83 pkg NZ5040 last 18.06.2010
18A6E01906264424 pkg NZ5050 last 18.06.2010
18BACC9C103C5270 pkg NZ5100 last 31.05.2010
18C1E13A1B0C1B70 pkg NZ5100 last 18.06.2010
18B5255C13D5F651 pkg NZ5200 last 18.06.2010
18B5255E19E9CB40 pkg NZ5210 last 20.06.2010
18B63BF812FEA1DF pkg NZ5300 last 18.06.2010
187C8FEF1ECBF4DE pkg NZ5400 last 20.06.2010
18B5FBB01CA1AE62 pkg NZ5500 last 19.06.2010
18B5FBB318FCF30A pkg NZ5550 last 19.06.2010
187D38F10C8E111D pkg NZ5600 last 19.06.2010
18B644EE0F6080A0 pkg NZ5800 last 19.06.2010
187D179F1D0063DE pkg NZ5810 last 29.05.2010
18BBE3D81A2374D6 pkg NZ5820 last 19.06.2010
189AC47E0E3C9B56 pkg NZ6000 last 19.06.2010
189AC46C0B966C25 pkg NZ6050 last 18.06.2010
189AC46A16EFF49F pkg NZ6060 last 18.06.2010
189AC44B16ABE671 pkg NZ6070 last 18.06.2010
189C80B4004BE04B pkg NZ6090 last 19.06.2010
188D3E4A07601745 pkg NZ6130 last 18.06.2010
189AC4181B790573 pkg NZ6200 last 18.06.2010
189BAC390AE8E699 pkg NZ6300 last 18.06.2010
189AC3BC0D4A7D12 pkg NZ6400 last 19.06.2010
18B8263A11DE99D3 pkg NZ6500 last 19.06.2010
189AC38C084C9E5C pkg NZ7040 last 19.06.2010
1899A91A13E309D5 pkg NZ8000 last 18.06.2010
188B0DD10251D069 pkg NZ8020 last 18.06.2010
18BAAB911D55C44E pkg NZ8041 last 01.06.2010
189AC1A10CE51D6D pkg NZ8050 last 18.06.2010
189AC1611BA671D2 pkg NZ8070 last 18.06.2010
18B4B7BA036293C2 pkg NZ8080 last 19.06.2010
189C9DBC0F0608AE pkg NZ8110 last 18.06.2010
188D3E4E1B3AFD67 pkg NZ8130 last 18.06.2010
189BAC3B044E9F75 pkg NZ8140 last 18.06.2010
189ABFDE15E753CF pkg NZ8200 last 18.06.2010
185482BD0C80B41C pkg OE0020 last 20.06.2010
185482CB13E9487D pkg OE0040 last 20.06.2010
185482D100448468 pkg OE0050 last 20.06.2010
18622A5C0B2C2EB2 pkg OE0060 last 18.06.2010
18771D101DE109E3 pkg OE0070 last 20.06.2010
1855981214AB09BC pkg OE0080 last 17.06.2010
1895E909095E848E pkg OE0090 last 18.06.2010
185482EF09307D46 pkg OE0150 last 18.06.2010
18B4AD431721ADC9 pkg OE0170 last 18.06.2010
1856186E1AD7DACC pkg OE0180 last 15.06.2010
185482F60F61E185 pkg OE0200 last 18.06.2010
1879BB280ACEAE72 pkg OE5000 last 20.06.2010
1879BB261BD8770E pkg OE5020 last 19.06.2010
1879BB3704723C94 pkg OE5030 last 18.06.2010
1879BB3F1119EFCA pkg OE5040 last 20.06.2010
1879BB4510E33725 pkg OE5050 last 19.06.2010
1879BB4E04EBAA32 pkg OE5060 last 19.06.2010
1879BB5701DAA370 pkg OE5080 last 18.06.2010
1879BB5D12B49A55 pkg OE5090 last 20.06.2010
1844C84903084FD0 pkg OE5100 last 13.06.2010
1879BB700DE69D74 pkg OE5300 last 20.06.2010
189CF0D91C532CF2 pkg OE7310 last 20.06.2010
189CF0E114A77D72 pkg OE7910 last 18.06.2010
1844C804003F796E pkg OE8000 last 20.06.2010
1844C85B11FD5053 pkg OE8500 last 18.06.2010
18B98AC914609BC8 pkg OO0010 last 20.06.2010
18B7816C19F5E570 pkg OO0020 last 20.06.2010
18B98ACB07801596 pkg OO0040 last 19.06.2010
187E54D50AFF8695 pkg OO0100 last 18.06.2010
18B98AA91EF01BD6 pkg OO0110 last 20.06.2010
18B98AAB19E04001 pkg OO0120 last 20.06.2010
18B98AAA145E73A2 pkg OO0130 last 19.06.2010
18BF517C10E2FE1E pkg OO5070 last 10.06.2010
18C32B8211CA77FE pkg OO5070 last 18.06.2010
189C763A0C0A9E1A pkg OO7520 last 18.06.2010
18AB20CD09875998 pkg OO7540 last 02.06.2010
189C763E090AACBD pkg OO7600 last 18.06.2010
189981DD09ABC2C0 pkg OO7610 last 18.06.2010
18B72F9910ED3184 pkg OO7700 last 16.06.2010
18AB19780C2C7338 pkg OO8500 last 12.06.2010
18AB19500AC3E9EA pkg OO8530 last 12.06.2010
18B98D2B08A8E2F7 pkg OO8540 last 12.06.2010
18AB1977170679AC pkg OO8550 last 04.06.2010
187E55AD0AFD49E8 pkg OO8560 last 18.06.2010
18AB19550614F4B0 pkg OO8650 last 19.06.2010
187E53FA16345D25 pkg OO8660 last 18.06.2010
1818D74415890813 pkg OSSQLCAT last 01.06.2010
17F340C91AFAD757 pkg OSSQLC61 last 01.06.2010
183544BC17E8D1E2 pkg OSSQLIDV last 02.06.2010
182140B41454A687 pkg OS7111 last 20.06.2010
1886C7890BD94F1B pkg PA0360 last 17.06.2010
18B6EA5414567324 pkg PB5000 last 18.06.2010
18BB76FC1E94425C pkg PC5000 last 11.06.2010
18C2053B0AF30CA2 pkg PC5000 last 19.06.2010
18BB76FE03BF597A pkg PC5010 last 19.06.2010
18BB77000C77F3A2 pkg PC5020 last 11.06.2010
18C054480466FF34 pkg PC5020 last 19.06.2010
18BB77001CC025AE pkg PC5040 last 11.06.2010
18C2053B1846F7D2 pkg PC5040 last 19.06.2010
18BB77010D24CA14 pkg PC5050 last 11.06.2010
18C0545119FE37A2 pkg PC5050 last 19.06.2010
18BB77011545E29E pkg PC5060 last 11.06.2010
18C054481421F5AA pkg PC5060 last 19.06.2010
18BB770211C86AC0 pkg PC5070 last 11.06.2010
18C2053D00B05966 pkg PC5070 last 19.06.2010
18BB7703061D28EA pkg PC5080 last 11.06.2010
18C0545208C92852 pkg PC5080 last 19.06.2010
18BB770318607A18 pkg PC5090 last 11.06.2010
18C2053D17766B9E pkg PC5090 last 19.06.2010
18BC603311BE7498 pkg PC5100 last 11.06.2010
18C0545403F5CCD0 pkg PC5100 last 19.06.2010
18BC8FA2028AE7FE pkg PC5110 last 11.06.2010
18C054531A2D7B62 pkg PC5110 last 19.06.2010
18BB752E07046EE4 pkg PC5120 last 11.06.2010
18C054491398867E pkg PC5120 last 19.06.2010
18BC609F13DDA45E pkg PC5130 last 11.06.2010
18C05449143E5F2C pkg PC5130 last 19.06.2010
18BB770418407CB6 pkg PC5140 last 11.06.2010
18C2053E0578C8BA pkg PC5140 last 19.06.2010
18BB77041FE93074 pkg PC5150 last 11.06.2010
18C2053E180B3800 pkg PC5150 last 19.06.2010
18BBED700D51D012 pkg PC5160 last 18.06.2010
18BD2A9212C96D38 pkg PC5170 last 05.06.2010
18C054491F31F8EE pkg PC5170 last 19.06.2010
18C1E18A16D39FD8 pkg PC5190 last 19.06.2010
18C2303E1CE797F0 pkg PC5210 last 18.06.2010
18BD2A9C00718C8A pkg PC5400 last 11.06.2010
18C288330DAC6CAC pkg PC5400 last 19.06.2010
18BE21DD1644DFF2 pkg PC7000 last 04.06.2010
18C0544E04875A76 pkg PC7000 last 18.06.2010
18BB76F118EC3340 pkg PC7010 last 10.06.2010
18C0544E07C04B76 pkg PC7010 last 18.06.2010
18BC8BFE077A6364 pkg PC7020 last 10.06.2010
18C205340D2467B8 pkg PC7020 last 18.06.2010
18BB76F2134521F6 pkg PC7050 last 19.06.2010
18BB76F3071F1C18 pkg PC7060 last 19.06.2010
18BB76F31844DB90 pkg PC7070 last 19.06.2010
18BB76F40C38FA9E pkg PC7100 last 19.06.2010
18BD2AA50EEF6DD4 pkg PC7500 last 10.06.2010
18C2052E140F26C0 pkg PC7500 last 18.06.2010
18A33BFD130563CF pkg PC8000 last 19.06.2010
18BB76ED0472BB4C pkg PC8410 last 19.06.2010
18BB76ED05E2AAEA pkg PC8420 last 19.06.2010
18B94333138491F2 pkg PH8000 last 19.06.2010
189A453E021A9E26 pkg PH8920 last 18.06.2010
614154754E454D58 pkg PMUTV104 last 20.06.2010
189BD7030562A229 pkg POVAORT last 20.06.2010
18B737BA1D7468DA pkg PR0500 last 18.06.2010
1891AAB7151AEE84 pkg PR0720I last 18.06.2010
187ECACF12A55836 pkg PR0740I last 20.06.2010
18B7378B0F55B312 pkg PR0750I last 10.06.2010
18BB956A08C6CE5C pkg PR0770I last 18.06.2010
18B821310A2AF108 pkg PR0780I last 19.06.2010
18BDA9B310EBDE34 pkg PR0800I last 19.06.2010
18BDA9A4011EC6B2 pkg PR0810I last 18.06.2010
18B7379215708F68 pkg PR0820I last 18.06.2010
18BDA9A60CAE7CAE pkg PR0830I last 18.06.2010
18871E5F1BAF792F pkg PR0840I last 18.06.2010
18B7379616C28320 pkg PR0850I last 18.06.2010
18B941D5047EDB1E pkg PR0870I last 18.06.2010
18B941D515E19A8E pkg PR0880I last 15.06.2010
18B7379D19D22D06 pkg PR0890I last 08.06.2010
18BDA9B318019762 pkg PR0900I last 25.05.2010
187DCF2C0B69F48B pkg PR0910I last 18.06.2010
18BAA6100860CD2A pkg PR0920I last 11.06.2010
18C02AB8066F0A04 pkg PR0920I last 18.06.2010
1891AB641200EE06 pkg PR5000 last 18.06.2010
18B848DD00A51E42 pkg PR5010 last 19.06.2010
1891AB641D44A1A0 pkg PR5020 last 19.06.2010
18B848E51222CCFA pkg PR5030 last 19.06.2010
1891AAEF1A4BD406 pkg PR5050 last 18.06.2010
18BFDF7A05C727B0 pkg PR5060 last 20.06.2010
1891AAF117D415D5 pkg PR5070 last 18.06.2010
18BFDF80067EA41A pkg PR5080 last 20.06.2010
187EE8440760CB3C pkg PR5200 last 18.06.2010
18B99391167A5B0A pkg PR5760 last 18.06.2010
18BFDF8B069FF44C pkg PR5785 last 19.06.2010
18B93C1B1EF5F746 pkg PR5790 last 19.06.2010
1895DF0E05984AD2 pkg PR5795 last 19.06.2010
189BAEAA15767BD2 pkg PR7000 last 18.06.2010
189BAEAA1000EB32 pkg PR7100 last 19.06.2010
18B7F906180AE576 pkg PR8000 last 19.06.2010
18B738431AC1D6CC pkg PR8010 last 19.06.2010
17B8C5010E0F54B9 pkg PVSCONV last 18.06.2010
18078A600CEFBD59 pkg PVSDBSTA last 19.06.2010
17B8C4F80C440B00 pkg PVSSQL last 20.06.2010
1839F22211485E3E pkg PVST1 last 17.06.2010
17B8C5020397871A pkg PVST2 last 18.06.2010
188EA9F71F469E34 pkg PV6100 last 19.06.2010
1889F68A0061AE89 pkg PV6200 last 19.06.2010
1889F68B0994A988 pkg PV6300 last 20.06.2010
18A0E7A91492B57A pkg PV6500 last 19.06.2010
17AC2B8A105EB721 pkg PV7130 last 18.06.2010
188EA1161411A33F pkg PW5200 last 20.06.2010
18A8193009485E2E pkg PW5210 last 20.06.2010
188EA4D40186B6B4 pkg PW5220 last 20.06.2010
188EA41C1A15E8B3 pkg PW5230 last 20.06.2010
187E07E10C1AFAA0 pkg PW6200 last 20.06.2010
187E07E302E59D2A pkg PW6201 last 20.06.2010
187E07E40EF9CB1A pkg PW6210 last 20.06.2010
18B9937D14B18F6D pkg PW6230 last 19.06.2010
18BCE09902EC6E16 pkg PW6231 last 11.06.2010
18C0288918CD897A pkg PW6231 last 19.06.2010
18A5C5CE0438F805 pkg PW6239 last 19.06.2010
187E07E8050783A0 pkg PW6240 last 19.06.2010
1858A558172C846A pkg PX0200 last 20.06.2010
187F423B046B76DB pkg PX0300 last 20.06.2010
187F424B0AA8FEB4 pkg PX0310 last 20.06.2010
18B98FA61897CBE4 pkg PX0330 last 20.06.2010
187F425204909A20 pkg PX0340 last 20.06.2010
187F4256013580BF pkg PX0350 last 18.06.2010
1858A5811429CB0D pkg PX0380 last 09.06.2010
1858A5831DB5D39B pkg PX0390 last 20.06.2010
187F425910E4227C pkg PX0410 last 20.06.2010
18B2A53404BB28C4 pkg PX0420 last 19.06.2010
18B5ED351882D4E0 pkg PX5010 last 20.06.2010
1848DF6F0973DB54 pkg PX5020 last 03.06.2010
18B1E40B09222B0A pkg PX5050 last 20.06.2010
189FF0A505FC09AF pkg PX5060 last 03.06.2010
18B5ED651619E987 pkg PX5080 last 03.06.2010
189FF0A613554F65 pkg PX5140 last 20.06.2010
18B5ED3F0560B44F pkg PX5200 last 03.06.2010
18BBC7C803B97232 pkg PX5220 last 03.06.2010
18B783BD00001F50 pkg PX5240 last 03.06.2010
18B1E40C127889F4 pkg PX5500 last 20.06.2010
18B5ED69116A9059 pkg PX5600 last 20.06.2010
185342EF1B2353FF pkg PX5610 last 20.06.2010
189FF0B1084C2539 pkg PX7010 last 20.06.2010
18A8C606175E4750 pkg PX7250 last 03.06.2010
189F49E6024787D1 pkg PX8020 last 20.06.2010
189F49EB1D1803E2 pkg PX8030 last 07.06.2010
18B5ED6E18F6A943 pkg PX8040 last 03.06.2010
189F49F2109BF4CC pkg PX8050 last 07.06.2010
189F4A001B3F10A6 pkg PX8060 last 07.06.2010
189F4A0C144B5486 pkg PX8080 last 07.06.2010
189F4A3D17D00193 pkg PX8090 last 08.06.2010
1868284614F3FE8E pkg PX8100 last 03.06.2010
189F4A410021BD45 pkg PX8110 last 20.06.2010
189F4A76096702AD pkg PX8180 last 20.06.2010
189F4A7914575412 pkg PX8200 last 20.06.2010
189F4A8005861E88 pkg PX8210 last 07.06.2010
18755E3D04F53997 pkg PX8300 last 03.06.2010
189F4A831A767FC6 pkg PX8900 last 03.06.2010
189F4A8B05072D94 pkg PX8910 last 20.06.2010
189CA7F908E55AD0 pkg PYBR4U last 17.06.2010
18A89E561304F876 pkg RA7240 last 19.06.2010
18B78BA516B42130 pkg RA8220 last 19.06.2010
18B78BA517ED08B1 pkg RA8300 last 19.06.2010
18B78BA50A32FF70 pkg RA8400 last 19.06.2010
18A89C7310C957E4 pkg RA8410 last 19.06.2010
18A89C7D17564B36 pkg RA8420 last 19.06.2010
18A89C8701090FFA pkg RA8430 last 19.06.2010
18B6174D0CD1C49A pkg RE0900 last 20.06.2010
18A3658316333173 pkg RE5040 last 18.06.2010
189934D10558F3B0 pkg RE5050 last 18.06.2010
189934D5199182E2 pkg RE7500 last 18.06.2010
189934D902A9DB6D pkg RE7510 last 18.06.2010
189934E008105C87 pkg RE7630 last 18.06.2010
18B6174016AE49FC pkg RE8055 last 19.06.2010
18B93F1802601514 pkg RF0510 last 18.06.2010
18B93F121413935E pkg RF0520 last 19.06.2010
18B93F161E47B564 pkg RF0530 last 20.06.2010
18B93F320DE376D5 pkg RF0540 last 20.06.2010
18B93F0F1BF6DD97 pkg RF0550 last 19.06.2010
18B93F21099B6104 pkg RF5020 last 18.06.2010
18A8E29E0C384876 pkg RF7010 last 18.06.2010
189952CD1B72D13E pkg RF7050 last 18.06.2010
189952CE04D0DC74 pkg RF7070 last 18.06.2010
189952CE0B380F18 pkg RF7100 last 18.06.2010
189954CF003E5EDC pkg RF7110 last 19.06.2010
18A7A8C213E6DE50 pkg RF7120 last 18.06.2010
189952D418C0D9A2 pkg RF7130 last 19.06.2010
189952D8016D94CE pkg RF7140 last 18.06.2010
189952D30A977E38 pkg RF7160 last 19.06.2010
189952DA0BFF8F61 pkg RF7180 last 19.06.2010
18B93F2B05DE8AC4 pkg RF8000 last 18.06.2010
188B04B01B5EF15A pkg RF8010 last 19.06.2010
18B93F1F04F7F042 pkg RF8020 last 18.06.2010
18B93F200B019348 pkg RF8030 last 18.06.2010
18B93F3618C6D8AA pkg RF8040 last 18.06.2010
18A435080D236CA6 pkg RI0810 last 18.06.2010
18B93B48129B1704 pkg RI0820 last 18.06.2010
18B84AD31609E032 pkg RI0830 last 18.06.2010
18B89BC619EF2114 pkg RI0840 last 18.06.2010
18AB3F2C0D4EC3CE pkg RI5000 last 18.06.2010
18A8E4C400B0F126 pkg RI5010 last 18.06.2010
18A9AF97016E8514 pkg RI5090 last 18.06.2010
18BEC912084A28CE pkg RM0100 last 20.06.2010
18B070501D25A3CC pkg RM0100 last 11.06.2010
18B70E2218F1D2A2 pkg RM0200 last 15.06.2010
18BBBB401F28F7E2 pkg RM0980R last 20.06.2010
18B1B0B10DE8E7CE pkg RM5000 last 18.06.2010
18B1E951019E8DE8 pkg RM5030 last 18.06.2010
18B8233710679F46 pkg RM7110 last 18.06.2010
18B6730F14EFC8CA pkg RM7260 last 20.06.2010
18B617270E1B8F8A pkg RM7310 last 18.06.2010
189B66CA0548A8E7 pkg RM7350 last 18.06.2010
18B2F50C13EA5C82 pkg RM7360 last 31.05.2010
18B1B17504BC5FA6 pkg RM7380 last 31.05.2010
18B1E72F189C516C pkg RM7410 last 18.06.2010
18B1AFC702918A7E pkg RM7420 last 18.06.2010
18B207D7157B6D24 pkg RM7430 last 19.06.2010
18B52B320009A516 pkg RM7440 last 18.06.2010
18B8211210874D5E pkg RM7450 last 18.06.2010
18B1AFCA1E33A2FA pkg RM7900 last 18.06.2010
18BCB99619B24B90 pkg RM7920 last 12.06.2010
18B98F3111259B44 pkg RM8010 last 20.06.2010
18B674CC0D840E76 pkg RM8020 last 18.06.2010
18BDD34000F61892 pkg RM8220 last 20.06.2010
18B674CD1096F4C4 pkg RM8220 last 06.06.2010
18B98F32086A62C5 pkg RM8280 last 18.06.2010
18C0248A1AC9DCBA pkg RM8410 last 18.06.2010
1852A7B70F8D7264 pkg RP5010 last 20.06.2010
189D295D1354F8F8 pkg RP5080 last 20.06.2010
18B1E15B113823E2 pkg RP5110 last 20.06.2010
1852A7C005D3CCDD pkg RP5190 last 20.06.2010
1852A7C115EEE716 pkg RP5200 last 20.06.2010
1852A7C31B890CCC pkg RP5210 last 17.06.2010
18B2CC2C03BB1E5C pkg RP5230 last 14.06.2010
18B2CC2C1D1B374E pkg RP5240 last 10.06.2010
18C007031D71EC22 pkg RP5240 last 14.06.2010
1852A8A004B80BFE pkg RP5310 last 19.06.2010
1852A9DA01193100 pkg RP5320 last 20.06.2010
18B2CC2D15F22DC4 pkg RP5420 last 20.06.2010
18785E35008E40A7 pkg RP5862 last 20.06.2010
1852AA1F02883522 pkg RP5930 last 27.05.2010
1852AA2914DC1504 pkg RP5940 last 19.06.2010
18A31D2F1584D102 pkg RP7170 last 20.06.2010
18B2CC43046CAAF0 pkg RP7220 last 14.06.2010
18A31D321D84ABCE pkg RP7230 last 31.05.2010
18A31D3600A282B9 pkg RP7240 last 10.06.2010
18C0D7711899E28C pkg RP7240 last 20.06.2010
18A31D3513840142 pkg RP7241 last 10.06.2010
18C0D7711B810B30 pkg RP7241 last 20.06.2010
18A31D37114ED3F8 pkg RP7250 last 19.06.2010
18A31D380FF9EE2C pkg RP7270 last 19.06.2010
18A31D3B0BBF2B68 pkg RP7300 last 20.06.2010
18B2CC59025E270C pkg RP7350 last 10.06.2010
18C0D77213597C7C pkg RP7350 last 19.06.2010
18A31D3E1185C0D0 pkg RP7360 last 19.06.2010
18A31D401ECEF31A pkg RP7370 last 02.06.2010
18A31D430CF1D49D pkg RP7400 last 07.06.2010
18B2CC430FC54B06 pkg RP7410 last 07.06.2010
18A31D460BD8B5B6 pkg RP7420 last 19.06.2010
18A31D49131FB2B1 pkg RP7450 last 20.06.2010
18A31D4A0E99531E pkg RP7451 last 20.06.2010
18B2CC431B1D198A pkg RP7460 last 20.06.2010
18A31D4D06E1673C pkg RP7461 last 19.06.2010
18A31D4F186AE693 pkg RP7480 last 20.06.2010
18A31D511E773C64 pkg RP7490 last 20.06.2010
18B2CC440E4A73E0 pkg RP7500 last 19.06.2010
18A31D56087D8482 pkg RP7510 last 19.06.2010
18A31D571BAEF5CE pkg RP7520 last 19.06.2010
18A31D5C0048CA78 pkg RP7700 last 20.06.2010
18A31D5D080BA556 pkg RP7701 last 20.06.2010
18BCE4AA131FE0E6 pkg RP7710 last 20.06.2010
18B98DC502F1D72E pkg RP7711 last 10.06.2010
18C245D007DB58F2 pkg RP7711 last 20.06.2010
18B2CC11165F444A pkg RP7800 last 10.06.2010
18C007061211CCB6 pkg RP7800 last 18.06.2010
18A31D661F091ECE pkg RP7810 last 15.06.2010
18A31D671C5E4CF0 pkg RP7820 last 15.06.2010
18A31D690EF18696 pkg RP7830 last 16.06.2010
18A31D6A19091380 pkg RP7840 last 16.06.2010
18B2CC4508B9856F pkg RP7850 last 20.06.2010
18AB4817150E0118 pkg RP7860 last 20.06.2010
18AB481A196E3395 pkg RP7861 last 20.06.2010
18A31D791087B66C pkg RP7950 last 20.06.2010
18A31D7A17591AB8 pkg RP7960 last 20.06.2010
18A31D7B1794F22C pkg RP7990 last 20.06.2010
18A819DA08688F72 pkg RP9002 last 31.05.2010
18A31D8719782602 pkg RP9023 last 07.06.2010
18B850F20EC79521 pkg RP9200 last 10.06.2010
18C27F6E037350BA pkg RP9200 last 11.06.2010
1852A8790A201489 pkg RQ5000 last 10.06.2010
1852A85C16D99464 pkg RQ5010 last 10.06.2010
1852A92C0A110D5D pkg RQ5020 last 19.06.2010
189338B307FB3A1D pkg RQ5050 last 19.06.2010
18C0D7721645B0CC pkg RQ5062 last 20.06.2010
189525AB160DA000 pkg RQ5220 last 19.06.2010
18B2CC4813083B26 pkg RQ5312 last 10.06.2010
18C0D77300ADCAC2 pkg RQ5312 last 19.06.2010
18B2CC5C12C35182 pkg RQ5315 last 10.06.2010
18C0D7730B8C6892 pkg RQ5315 last 19.06.2010
18B3E88E145048B7 pkg RQ5320 last 10.06.2010
18C0D7731F19F41C pkg RQ5320 last 18.06.2010
18933B260DFDD11F pkg RQ5420 last 20.06.2010
18B2CC5E0A94EAC8 pkg RQ5520 last 10.06.2010
18C1E882048D03A0 pkg RQ5520 last 20.06.2010
18B2FE0913CEEFB4 pkg RQ5550 last 10.06.2010
18C26D24144B3FB0 pkg RQ5550 last 20.06.2010
18A31D8D15119F7A pkg RQ7000 last 10.06.2010
18A31D8F0A000F64 pkg RQ7030 last 19.06.2010
18A31D90132CF048 pkg RQ7040 last 19.06.2010
18A31D920EE61280 pkg RQ7060 last 19.06.2010
18C26DA8188B5B38 pkg RQ7061 last 20.06.2010
18A31D94160A313C pkg RQ7316 last 19.06.2010
18B2CC630B22B12A pkg RQ7530 last 10.06.2010
18C1E7AB08A1E078 pkg RQ7530 last 20.06.2010
18A31D97123E50B7 pkg RQ7540 last 10.06.2010
18C1E7DB1D43A688 pkg RQ7540 last 20.06.2010
18A31D990986DD6A pkg RQ7560 last 20.06.2010
18A31D9A0F6C1C0E pkg RQ7810 last 19.06.2010
18A31D9C10E07097 pkg RQ7950 last 20.06.2010
18A9E05F1BCD41CE pkg RVAA1@I last 20.06.2010
18A9E06602BF7A1C pkg RVAB1@I last 20.06.2010
18A9E0681482D213 pkg RVAC1@I last 20.06.2010
18B4B70A1CCCD02A pkg RVAD1@I last 20.06.2010
18B39E260A169AEB pkg RVBA1@I last 20.06.2010
18A9E06B08A9ECD2 pkg RVBB1@I last 20.06.2010
1899A2E70572B71E pkg RVBC1@I last 17.06.2010
18A9FB20033580F2 pkg RVDA1@I last 20.06.2010
1899A2C70574CB86 pkg RVDB1@I last 15.06.2010
18B39E280E584BBC pkg RVDC1@I last 20.06.2010
18A01A060F3E7633 pkg RVDD1@I last 20.06.2010
18A9E06D1F592EBE pkg RVDD2@I last 20.06.2010
18A9E07B0ED7DE84 pkg RVDE1@I last 20.06.2010
18B976FD13E4E24A pkg RVEA1@I last 20.06.2010
18B643A40EA09631 pkg RVEB1@I last 20.06.2010
18A9E080100C46E0 pkg RVFA1@I last 20.06.2010
18B7F9EB0A8833E0 pkg RVFB1@I last 20.06.2010
18A9E083153ED462 pkg RVFC1@I last 17.06.2010
18A9E08713ED08CE pkg RVFD1@I last 18.06.2010
18A9E0891727048A pkg RVFE1@I last 18.06.2010
18B193E71B01B078 pkg RVGA1@I last 18.06.2010
18A9DD1813724F5D pkg RVGB1@I last 18.06.2010
18A9E08F1BB800D0 pkg RVHC1@I last 20.06.2010
189CD4F11120CE6B pkg RVHD1@I last 18.06.2010
18B189F20CE0BAFA pkg RVHE1@I last 20.06.2010
189565F61A55DF82 pkg RVHF1@I last 18.06.2010
18A9E0911838322A pkg RVHG1@I last 18.06.2010
18A9E0930BF9BD08 pkg RVHH1@I last 18.06.2010
18B6BFEE0D56A8CC pkg RVIA1@I last 18.06.2010
18B6E9E41F02FBFA pkg RVIB1@I last 20.06.2010
189566041BE4342F pkg RVJA1@I last 20.06.2010
1895660717956E71 pkg RVJB1@I last 18.06.2010
1895660B0715E889 pkg RVJC1@I last 18.06.2010
18A9E09507F8AD7F pkg RVKA1@I last 04.06.2010
18A9E09709D9324C pkg RVKB1@I last 15.06.2010
18A9E09815F654F6 pkg RVKC1@I last 18.06.2010
18A9E09916AE1ABB pkg RVZA1@I last 19.06.2010
18A9E09C19DA92B1 pkg RVZC1@I last 19.06.2010
18B961711F1F77BB pkg RV5000 last 19.06.2010
18B1B8970FEB15A6 pkg RV5100 last 19.06.2010
18B61AFD0D1A4096 pkg RV5110 last 19.06.2010
18B735A11F5BAF58 pkg RV5120 last 19.06.2010
18B735A20E98F557 pkg RV5130 last 19.06.2010
18A7F96F190A84AE pkg RV5400 last 18.06.2010
18B1B89A0C0A6B88 pkg RV5500 last 31.05.2010
18B874F11F742582 pkg RV5600 last 18.06.2010
189C7EAF06495BE7 pkg RV5610 last 18.06.2010
18BAD3B709C2CDC8 pkg RV5620 last 18.06.2010
189E0F750483C349 pkg RV5630 last 18.06.2010
18A31B550DB6A452 pkg RV5640 last 19.06.2010
18BAD3B71B1A9B62 pkg RV5650 last 19.06.2010
18B646D511D76A06 pkg RV5700 last 19.06.2010
18B646D8058F7ED4 pkg RV5800 last 19.06.2010
18B7FA14068DC0A6 pkg RV5850 last 19.06.2010
189BABDC0E1A471A pkg RV5900 last 19.06.2010
189B5D610207B173 pkg RV6100 last 01.06.2010
182EEEF20BB2B801 pkg SAMCAYGU last 20.06.2010
187DDF040D17E4C4 pkg SAMCAYRU last 20.06.2010
1797C027018D9741 pkg SAMENYTU last 25.05.2010
17EBDCF8139DB90D pkg SAMENYUU last 20.06.2010
17CEC31D1098E6AC pkg SAMEN100 last 20.06.2010
17D32A4800F632BD pkg SAMISP02 last 20.06.2010
17EB67C1191F4058 pkg SAMISP10 last 16.06.2010
18BFAD9300BDEB8C pkg SAMPCA51 last 18.06.2010
18785C301C6AF4D6 pkg SAMPCA98 last 18.06.2010
17B392711B901A19 pkg SAMP0122 last 20.06.2010
1797C13C16C05EE1 pkg SAMP0125 last 20.06.2010
1647C9EC01BAB864 pkg SAMP0190 last 20.06.2010
1797C1E81D447F88 pkg SAMTC111 last 20.06.2010
99858285A69496A3 pkg SAS82 last 02.06.2010
99858285A69496A3 pkg SAS91 last 20.06.2010
18B613E11F9BCD7E pkg SA0010 last 19.06.2010
18B613E31304DC15 pkg SA0020 last 18.06.2010
18B613E602198CE8 pkg SA0030 last 18.06.2010
18B613E713A634DB pkg SA0040 last 18.06.2010
18B6140601CC77AC pkg SA0160 last 20.06.2010
18B6140712D66C9B pkg SA0200 last 20.06.2010
18B61409031F8622 pkg SA0210 last 18.06.2010
18B6648D041ECE92 pkg SA0220 last 17.06.2010
18B6141406A3A6EE pkg SA0230 last 02.06.2010
187E2A7917B85E49 pkg SA0260 last 10.06.2010
18B6141607BED0F9 pkg SA0270 last 11.06.2010
18B6141709C58ACA pkg SA0280 last 14.06.2010
18B614180B48F426 pkg SA0290 last 09.06.2010
18B61419106423E0 pkg SA0300 last 20.06.2010
18B6141A141E4CE4 pkg SA0320 last 18.06.2010
18B614221067AE3E pkg SA0330 last 01.06.2010
18B614B400459622 pkg SA0390 last 28.05.2010
18B614B21A683CFC pkg SA0460 last 10.06.2010
18B614B41BA9CC8C pkg SA0470 last 20.06.2010
1879CA52082075AE pkg SA06A11 last 20.06.2010
1879F80003FF6ACA pkg SA07A11 last 18.06.2010
1879CA6A0D8FF63C pkg SA07B11 last 20.06.2010
187F378D158595F4 pkg SA07C11 last 18.06.2010
1879CA80075E60A0 pkg SA07D11 last 18.06.2010
187A618115FB71B5 pkg SA5110 last 19.06.2010
18B614C61E89D110 pkg SA5140 last 19.06.2010
187A619019B7ED34 pkg SA5280 last 01.06.2010
18B614CE06A4D76A pkg SA5300 last 18.06.2010
18B614D31FF33F94 pkg SA5370 last 02.06.2010
1899C7C31A145780 pkg SA8000 last 20.06.2010
18B614D917728FB4 pkg SA8050 last 19.06.2010
18B664A30FC433E0 pkg SA8380 last 19.06.2010
18B993D90D92F94E pkg SB7030 last 19.06.2010
18B993AC1C369D90 pkg SB7040 last 19.06.2010
18B993B91F2FB7B6 pkg SB8070 last 19.06.2010
17A42E3504676F47 pkg SC7430 last 19.06.2010
1797C2B61171F494 pkg SD3BS1T last 20.06.2010
17F7EDCA0D84D8B4 pkg SD3BS2T last 20.06.2010
1797C2C415698728 pkg SD3BS3T last 20.06.2010
1797C2C60D3973A6 pkg SD3BS4T last 20.06.2010
1797C2C814FE5AE0 pkg SD3BS5T last 20.06.2010
1797C2CB0B5BE695 pkg SD3BS6T last 20.06.2010
17D28E5E0ED04629 pkg SD3BS7T last 20.06.2010
17D2661B0B2E8E25 pkg SD3BS8T last 20.06.2010
17D2663314E0F4DC pkg SD3BS9T last 20.06.2010
1825FE0C1A1732CE pkg SE0870 last 18.06.2010
188E7C1703121B8B pkg SF0100 last 18.06.2010
189A69A614748902 pkg SF0520 last 20.06.2010
18B7106200F9A9DC pkg SF5010 last 18.06.2010
18B710661FDB355E pkg SF5020 last 18.06.2010
18B7107106D9C572 pkg SF5030 last 18.06.2010
18A0412C13C8EF28 pkg SF7070 last 19.06.2010
189ABA85107A449C pkg SF7090 last 18.06.2010
18B990910218FB3B pkg SF8300 last 18.06.2010
18B82B7706ED88B6 pkg SF8330 last 19.06.2010
18B82B7C129AC758 pkg SF8340 last 25.05.2010
18BDFA6C136F92A4 pkg SN0100 last 19.06.2010
18BDD4A61B2AB166 pkg SN0200 last 19.06.2010
18BDD4B8113FE170 pkg SN0300 last 18.06.2010
18B0C868097C83D6 pkg SN261@I last 18.06.2010
18BDD4C015FA9CA2 pkg SN5000 last 18.06.2010
18BDFA6E0F5688F6 pkg SN5001 last 18.06.2010
189F50701E40131D pkg SN5002 last 18.06.2010
189F506D0F401219 pkg SN5003 last 19.06.2010
18B1B92A1F8A9122 pkg SN5004 last 19.06.2010
189F506D1D2608F1 pkg SN5005 last 19.06.2010
18BCD6A417B30C5C pkg SN5009 last 19.06.2010
18BDD49F05537CDE pkg SN5010 last 19.06.2010
18BDD49A1F27A1F8 pkg SN5011 last 04.06.2010
18B4252E02CE7686 pkg SN5012 last 02.06.2010
18BC8B5B15A6921C pkg SN5013 last 18.06.2010
18A186D90E7C779D pkg SN5014 last 19.06.2010
18B6E3D20A3B5CE9 pkg SN5015 last 18.06.2010
18BAD84D0BCCCC3C pkg SN5016 last 19.06.2010
18BAD8F6135B4348 pkg SN5017 last 01.06.2010
18B70FDD0ACB871A pkg SN5018 last 19.06.2010
18B28077112758FE pkg SN5019 last 01.06.2010
18A820601E669FFD pkg SN5021 last 12.06.2010
18B992991DB8B478 pkg SN5025 last 19.06.2010
189F50750CBA99BF pkg SN5028 last 19.06.2010
18BDD4211623BCC8 pkg SN5029 last 18.06.2010
18BDD4CB18F53D60 pkg SN5100 last 19.06.2010
18BDFA700E58026E pkg SN5110 last 18.06.2010
18BDFA7209A737E0 pkg SN5120 last 19.06.2010
18AC131E1A65BD15 pkg SN5130 last 19.06.2010
18B18C2406305848 pkg SN5140 last 19.06.2010
18B3EA8C1B0DFABB pkg SN5810 last 18.06.2010
18B3EA8119FDCE02 pkg SN5820 last 19.06.2010
18BBC0DD13EE08B2 pkg SN5830 last 19.06.2010
18C23CCF1A0ABA58 pkg SN5902 last 12.06.2010
18A5CA220B188658 pkg SN5903 last 01.06.2010
189F507D13DF141C pkg SN5904 last 01.06.2010
189F50831CFA3F08 pkg SN5905 last 12.06.2010
189F507F01DBE1B4 pkg SN5906 last 12.06.2010
18C23CD7160890D8 pkg SN5910 last 12.06.2010
18BDFA79032082AC pkg SN5920 last 12.06.2010
189F50AD080065D3 pkg SN6005 last 19.06.2010
189F50AD0763B1A0 pkg SN6006 last 01.06.2010
18B96482021D460C pkg SN6007 last 01.06.2010
18A8C4680D4208F8 pkg SN6008 last 12.06.2010
189F50AD15965108 pkg SN6009 last 12.06.2010
189F50B30BF0D8AF pkg SN6010 last 12.06.2010
189F50B1098D74BE pkg SN6015 last 18.06.2010
189F50B5124CFD3E pkg SN6016 last 19.06.2010
189F50B01D292579 pkg SN6017 last 18.06.2010
18AC3A5E1C6A4A86 pkg SN6018 last 19.06.2010
18AFD24A15AF4A30 pkg SN6019 last 19.06.2010
18BB77190D98A36A pkg SN6023 last 19.06.2010
18B39BFE1734483E pkg SN8003 last 19.06.2010
18B39C0317996C89 pkg SN8004 last 27.05.2010
18C0FA491B816288 pkg SN8004 last 18.06.2010
18C148BF01DAFEC6 pkg SN8004 last 11.06.2010
18C49482151589C0 pkg SN8004 last 19.06.2010
18B1B14A04DFC292 pkg SN8006 last 19.06.2010
18BC8A27007106E8 pkg SN8007 last 19.06.2010
18B1B14A11F256A2 pkg SN8008 last 19.06.2010
18B2879F104FE5BF pkg SN8009 last 19.06.2010
18B1B14B17BAAFEE pkg SN8010 last 19.06.2010
18B1B14B19887EEF pkg SN8012 last 19.06.2010
18B39C0D0D20C5F1 pkg SN8013 last 19.06.2010
18B647BC107ECD5E pkg SN8014 last 19.06.2010
18BD0A961A8DC4E2 pkg SN8015 last 05.06.2010
18BDCD500333A10A pkg SN8016 last 05.06.2010
189F50B606710730 pkg SN8017 last 19.06.2010
18B6E4480648B5C2 pkg SN8028 last 16.06.2010
18C46E061928A822 pkg SN8028 last 19.06.2010
18B803F70234A9DE pkg SN8029 last 19.06.2010
18B6E4481CCCAE66 pkg SN8030 last 05.06.2010
166F2E2217582C28 pkg SP1BS1T last 20.06.2010
166F2E290E89AC6A pkg SP1BS4T last 20.06.2010
166F2E2B096E72EA pkg SP1BS5T last 20.06.2010
166F2E2C1777DB54 pkg SP1BS6T last 20.06.2010
166F358611521BA8 pkg SP1US2T last 20.06.2010
41414141414C4959 pkg SQLC2G15 last 20.06.2010
1842A4540E70A4F1 pkg SQLPCRTN last 20.06.2010
183544E31EF7761A pkg SQLPFRTN last 20.06.2010
1847CE701090AB46 pkg SQLPLRTN last 20.06.2010
18B87395024B77B0 pkg SUMONIT last 19.06.2010
18BB7B29005CB83A pkg SV0020 last 11.06.2010
18BFBF7B178E7D4C pkg SV0020 last 18.06.2010
18A7CC271E1C8B42 pkg SV0030 last 18.06.2010
18AEBC8B17443DAF pkg SV0040 last 11.06.2010
18BFBF7C1A0F1964 pkg SV0040 last 20.06.2010
18B6EF500DC744FE pkg SV0050 last 18.06.2010
18A7CC2D00B5063C pkg SV0060 last 15.06.2010
18A698461C0F417E pkg SV0070 last 18.06.2010
18B52B891580498A pkg SV0090 last 18.06.2010
18B6528E06FD3F70 pkg SV0100 last 20.06.2010
18B6528E14C07BDA pkg SV0110 last 16.06.2010
18B6529B162A74CA pkg SV0120 last 16.06.2010
18B6528F1A70C276 pkg SV0140 last 09.06.2010
188D1C7509D65B22 pkg SV0160 last 17.06.2010
18B6529F1EAC561A pkg SV0170 last 17.06.2010
18B652A20A2B7D66 pkg SV0180 last 16.06.2010
18C46B9904CC29F2 pkg SV0180 last 18.06.2010
18A7CC411AE396FB pkg SV0190 last 18.06.2010
18A7CC4417E0977C pkg SV0210 last 18.06.2010
18B652910BAFD5E8 pkg SV0220 last 18.06.2010
18A7CC4715932F90 pkg SV0230 last 18.06.2010
18B652A71F3AAA0E pkg SV0250 last 18.06.2010
18A7CC4B0B2C44F6 pkg SV0260 last 17.06.2010
18A7CC4C15A55EBC pkg SV0270 last 18.06.2010
18AE657C0BADAF32 pkg SV0280 last 18.06.2010
18B652A81AB4C16A pkg SV0290 last 18.06.2010
18A7CC5C0CA5B03C pkg SV0300 last 18.06.2010
18B652B70F091BA8 pkg SV0310 last 18.06.2010
18B652B91A461B32 pkg SV0320 last 18.06.2010
18B652BC00E373F0 pkg SV0330 last 18.06.2010
18B652BE0A1FF426 pkg SV0340 last 18.06.2010
18B652C00E8BD36A pkg SV0350 last 18.06.2010
18A7CC6719A504D1 pkg SV0410 last 18.06.2010
18B2AAD41B74E5A4 pkg SV0950 last 19.06.2010
18B713571E937DB2 pkg SV0960 last 19.06.2010
18B2CDA41927B281 pkg SV0970 last 15.06.2010
18B713591C3F8CD8 pkg SV0980 last 18.06.2010
18B61B001A65877B pkg SV5000 last 04.06.2010
18AC822B10EA8BE7 pkg SV5001 last 04.06.2010
18B6E1F70044BB9F pkg SV5002 last 04.06.2010
18B2A2790F5575A8 pkg SV5003 last 04.06.2010
18B672A7137E7408 pkg SV5004 last 04.06.2010
18AC8272156DED83 pkg SV5005 last 04.06.2010
18AC8273073BF40C pkg SV5006 last 19.06.2010
18B7169109A1C1B5 pkg SV5007 last 04.06.2010
18B647B31C304A03 pkg SV5008 last 04.06.2010
18AFA8E003E849EA pkg SV5009 last 19.06.2010
18B1715B109AF203 pkg SV5010 last 04.06.2010
187CC9B51F6D4298 pkg SV5011 last 04.06.2010
18B995BF1D215502 pkg SV5012 last 19.06.2010
18B61B1208056039 pkg SV5030 last 18.06.2010
187E572E02445237 pkg SV5090 last 19.06.2010
189AA1FF1CE584AB pkg SV5110 last 19.06.2010
18B652CD12536254 pkg SV5120 last 11.06.2010
18C13D0214DCB9E0 pkg SV5120 last 19.06.2010
18B995C10CEF623E pkg SV5150 last 18.06.2010
1889C6B21BB1370B pkg SV5210 last 18.06.2010
1889C7220FA8A9CE pkg SV5260 last 19.06.2010
187CF119105DDDED pkg SV5270 last 19.06.2010
18951D091A949BB4 pkg SV5290 last 18.06.2010
18B713AD086C2B24 pkg SV5390 last 18.06.2010
18B822F701F85C29 pkg SV5500 last 19.06.2010
18B822F91CC92770 pkg SV5510 last 19.06.2010
18B439F21AA2F354 pkg SV5580 last 19.06.2010
18AB16B808204D40 pkg SV5590 last 19.06.2010
18B88C2F01A907D6 pkg SV5600 last 18.06.2010
187CEB851F815B3E pkg SV5610 last 19.06.2010
187CEB8716272EEE pkg SV5620 last 19.06.2010
187AC0080BCA735E pkg SV5630 last 19.06.2010
18B66B3F01D2A806 pkg SV5640 last 11.06.2010
18C13D0415E75E7C pkg SV5640 last 19.06.2010
18B5CA0C148DF6EA pkg SV5650 last 19.06.2010
18B52BB50377C78E pkg SV5670 last 12.06.2010
1889C63608A2D0CA pkg SV5700 last 19.06.2010
18B995CA002E8846 pkg SV5710 last 19.06.2010
18B995CB0F6253B8 pkg SV5715 last 18.06.2010
18C4BA6B0BB20302 pkg SV5715 last 19.06.2010
18BCDDB101A83002 pkg SV5720 last 10.06.2010
18C283A90C0D0A80 pkg SV5720 last 18.06.2010
18B995CE0DF4A9FC pkg SV5740 last 19.06.2010
18B995D00498CB1C pkg SV5750 last 19.06.2010
18B995D21D8AFB47 pkg SV5760 last 19.06.2010
18B995DC09BB03BB pkg SV5770 last 15.06.2010
18B995E2077652B4 pkg SV5780 last 11.06.2010
18C302DC123339A8 pkg SV5780 last 19.06.2010
18B995E213B91006 pkg SV5790 last 19.06.2010
18A8A1E000B1AC01 pkg SV5795 last 02.06.2010
18B652FE0260F68C pkg SV5910 last 11.06.2010
18C13D06084E00B0 pkg SV5910 last 19.06.2010
18B6530006FCF44E pkg SV5930 last 19.06.2010
18B5F8C40D574504 pkg SV5940 last 19.06.2010
187EC4CC07BB1437 pkg SV5960 last 19.06.2010
187EC3E4191ABC85 pkg SV5970 last 19.06.2010
187E5A0D1F180E8A pkg SV5980 last 19.06.2010
188F7BCF0F65E0B8 pkg SV5990 last 19.06.2010
18B713A50A8C433E pkg SV7650 last 18.06.2010
18995CF91B40989A pkg SV7700 last 19.06.2010
18995CFB1240B9EA pkg SV7760 last 19.06.2010
18BDA27C01DE3846 pkg SV7790 last 19.06.2010
18A59A96153315EB pkg SV7910 last 01.06.2010
18AB171B144FE833 pkg SV8070 last 19.06.2010
18B52BD517A0D426 pkg SV8090 last 20.06.2010
18B6532213A331CE pkg SV8150 last 18.06.2010
18B5FCC81FFED955 pkg SV8200 last 19.06.2010
18A77B6918930ADA pkg SV8220 last 19.06.2010
18B82970073C9D62 pkg SV8240 last 11.06.2010
18C122070BEF1434 pkg SV8240 last 19.06.2010
188A43E11C7FAD62 pkg SV8280 last 02.06.2010
18995D11160BFDE8 pkg SV8300 last 19.06.2010
18AF38A302B2FD56 pkg SV8330 last 19.06.2010
18A8A1EE1FA7F368 pkg SV8350 last 19.06.2010
187CEA7C0E4AA471 pkg SV8360 last 19.06.2010
18BD783D179A299C pkg SV8370 last 19.06.2010
18AB17490F476BD4 pkg SV8410 last 19.06.2010
18B047F0095121EA pkg SV8500 last 18.06.2010
188A441313D4A163 pkg SV8530 last 19.06.2010
18AEC2410C51ACF8 pkg SW0200 last 19.06.2010
189CFFDA166F4FD6 pkg SW0210 last 19.06.2010
18B84E8817F0B262 pkg SW0400 last 17.06.2010
188D1B8B0A43FC5A pkg SW0620 last 18.06.2010
18BDFC7212D3FC16 pkg SW0800 last 20.06.2010
18B84B7E1540ED51 pkg SW0800 last 12.06.2010
18B84B8011A21362 pkg SW0810 last 20.06.2010
18B84B82040A0026 pkg SW0820 last 20.06.2010
18B84B830D0587F2 pkg SW0830 last 20.06.2010
18A0409A10229939 pkg SW0900 last 12.06.2010
18BDF9FB1BE9CCB2 pkg SW0900 last 20.06.2010
188C207D1CD6FDFE pkg SW0910 last 20.06.2010
18B530AD17588215 pkg SW0920 last 20.06.2010
18992D0A114946DC pkg SW5340 last 19.06.2010
18BDFC85104D3440 pkg SW7350 last 19.06.2010
189937161CE24562 pkg SW7350 last 11.06.2010
18B614F305C3547B pkg SX0030 last 09.06.2010
5359534C564C3031 pkg SYSLH200 last 20.06.2010
5359534C564C3031 pkg SYSSH100 last 19.06.2010
5359534C564C3031 pkg SYSSH200 last 19.06.2010
5359534C564C3031 pkg SYSSN200 last 20.06.2010
5359534C564C3031 pkg SYSSTAT last 28.05.2010
177EC7681D793EC1 pkg S6MDBUPD last 20.06.2010
175FFBCA1DFB16AF pkg S6VBCHGM last 20.06.2010
175FFBCB12DFC3F4 pkg S6VBDATL last 20.06.2010
175FFBCB069B16D0 pkg S6VB1MVC last 20.06.2010
175FFBCB0A4D4ED2 pkg S6VB2ACS last 20.06.2010
1800BFBE103F2149 pkg S6VDBUPD last 20.06.2010
18270E7917437F2D pkg TECHDSPI last 20.06.2010
18270E7917A97625 pkg TECHDSPU last 20.06.2010
18B84B861E649DF3 pkg TL0900 last 18.06.2010
18B84B8801AB9199 pkg TL0960 last 18.06.2010
1899AFD606E4F46A pkg TL7000 last 19.06.2010
18B1D41E133E2514 pkg TM7000 last 19.06.2010
18B820F31B62F8C4 pkg TN0055I last 20.06.2010
18B820D302233D4A pkg TN0065I last 20.06.2010
18B820DB0D5D26B6 pkg TN0075I last 18.06.2010
18BAA49C0B73CE00 pkg TN0083I last 20.06.2010
18B820A5174E417E pkg TN0085I last 20.06.2010
18B820951AF3045C pkg TN0114I last 20.06.2010
18B8209C1876AAD8 pkg TN0124I last 20.06.2010
18B820CA1662A815 pkg TN0134I last 18.06.2010
18B820901E611C66 pkg TN0141I last 20.06.2010
18B820BC02C45832 pkg TN0144I last 18.06.2010
18B820CC1C302246 pkg TN0204I last 18.06.2010
18B98970131B41CF pkg TN0500 last 20.06.2010
18B989641C56262C pkg TN0520 last 20.06.2010
18B98958181E4F68 pkg TN0530 last 18.06.2010
18B9897A124AA1E4 pkg TN5000 last 19.06.2010
18B849201C83AC60 pkg TN5004 last 18.06.2010
18C02B2105B817B6 pkg TN5010 last 11.06.2010
18C258C71E8491F6 pkg TN5010 last 20.06.2010
189F4BC31CECF3D6 pkg TN5011 last 18.06.2010
18B989A615C7EED8 pkg TN5014 last 18.06.2010
18B9898C03C5C162 pkg TN5015 last 19.06.2010
18B9897C0C5092E2 pkg TN5016 last 18.06.2010
18B9898A12165B76 pkg TN5017 last 19.06.2010
189F4BB5050D34C6 pkg TN5018 last 19.06.2010
18B98970145DABA4 pkg TN5020 last 20.06.2010
18B989640B554D24 pkg TN5030 last 18.06.2010
18B989A806338BCC pkg TN5900 last 19.06.2010
18B84924009B4BCA pkg TN7004 last 19.06.2010
18B849171EC014C1 pkg TN7020 last 19.06.2010
18B8492D1C2B3690 pkg TN7030 last 19.06.2010
18BCFCF80AD97712 pkg TN7061 last 20.06.2010
18B849251228E7D0 pkg TN7062 last 20.06.2010
18B8492714E97CBA pkg TN7065 last 20.06.2010
18B849220DA6CF8E pkg TN7066 last 20.06.2010
18B8491A00DF90D1 pkg TN7067 last 20.06.2010
18B8492F159024DA pkg TN7068 last 20.06.2010
18B84927039CE486 pkg TN7071 last 20.06.2010
18B8492C02F20D00 pkg TN7080 last 19.06.2010
18B84922094A38CE pkg TN8090 last 19.06.2010
18B8492110AA2520 pkg TN8100 last 18.06.2010
18AB18D412DEA7A8 pkg TN8400 last 19.06.2010
18BDA4FD1A5080A6 pkg TP0220 last 19.06.2010
18AC3426015554D4 pkg TP0230 last 19.06.2010
18AC3426076080B0 pkg TP0370 last 18.06.2010
18B96C2516A2D550 pkg TP0380 last 18.06.2010
18AC342617965F4E pkg TP0390 last 19.06.2010
18B96C2409BBA212 pkg TP0800 last 18.06.2010
18B96C261F5E4454 pkg TP0830 last 18.06.2010
18B993A10B37361C pkg TP0900 last 19.06.2010
18B8006213D8D6DE pkg TP0910 last 19.06.2010
18BB79730FFF6950 pkg TP0920 last 20.06.2010
18B9882B102FC283 pkg TP5000 last 20.06.2010
18AC341B125F3B3E pkg TP5090 last 18.06.2010
18B6E4BD13ED0E7E pkg TR0800 last 20.06.2010
18B6E4BE1A3010BA pkg TR0810 last 20.06.2010
18B6156E1BA78702 pkg TR0820 last 20.06.2010
18B6E4B81B01C629 pkg TR5100 last 18.06.2010
187C96EF04DD3A12 pkg TR5180 last 18.06.2010
187C97330CD15CA8 pkg TR5190 last 18.06.2010
189CD5C108347696 pkg TR5290 last 18.06.2010
18A7A16E127F55BD pkg TR5310 last 31.05.2010
18B7170D05C8CEF2 pkg TR5320 last 03.06.2010
18B614F815196BA2 pkg TR5330 last 31.05.2010
18B614FA1352BC74 pkg TR5340 last 03.06.2010
18B614FB0D4DC8CE pkg TR5360 last 03.06.2010
187C96F1130E4854 pkg TR5600 last 18.06.2010
18A7A17A100BC56F pkg TR5690 last 31.05.2010
188BF72D0089B344 pkg TR5900 last 16.06.2010
18BFE6E20448D460 pkg TR7100 last 18.06.2010
18BCAC1D03B85524 pkg TR8000 last 19.06.2010
18B0A24D0BCD9ABE pkg TR8030 last 07.06.2010
18BBEE9306976CD0 pkg TR8050 last 18.06.2010
18A2B1D205990320 pkg TT551FFI last 16.06.2010
18A2B1E21B071C0A pkg TT555FFI last 18.06.2010
18A2B1E21C40276E pkg TT555FFU last 18.06.2010
185F8ACD1886EAAE pkg TT582FFI last 18.06.2010
185F8ACD18D1617A pkg TT582FFU last 18.06.2010
18A340C30F44F944 pkg UI5000 last 20.06.2010
18A543231CB9E51C pkg UI5010 last 11.06.2010
18C139CE176DB48E pkg UI5010 last 20.06.2010
18A8C11D19B86DBA pkg UI5020 last 20.06.2010
18A5432406842EDF pkg UI5030 last 11.06.2010
18C139CF1C453E18 pkg UI5030 last 20.06.2010
18A8C11D1E8BA38C pkg UI5040 last 11.06.2010
18C139D1023647F0 pkg UI5040 last 20.06.2010
18A3436B1190CECB pkg UI5200 last 20.06.2010
18A5432419768570 pkg UI5300 last 20.06.2010
18A343CE0C304138 pkg UI5400 last 20.06.2010
189AE5E70D34F891 pkg UI6000 last 20.06.2010
18B5294B151C5CBC pkg US5010 last 19.06.2010
18BFB27000172A4A pkg UU0512I last 20.06.2010
18B18F9217333038 pkg UU0522I last 20.06.2010
187EC5B11E6EC821 pkg UU0531I last 20.06.2010
187EC5B318299580 pkg UU0541I last 18.06.2010
187EC5B5086C21D0 pkg UU0561I last 19.06.2010
18AC821A0E4AD4BA pkg UU0571I last 20.06.2010
187EC5BC1A7411D4 pkg UU0601I last 20.06.2010
187EC5BE0901FF13 pkg UU0611I last 20.06.2010
187EC5BF1D757084 pkg UU0621I last 20.06.2010
18B78814187C5A4E pkg UU0630 last 20.06.2010
187EC5C31E6662BE pkg UU0641I last 20.06.2010
187EC5C5184DC2B2 pkg UU0651I last 20.06.2010
18BAD43D16C97A1A pkg UU5000 last 19.06.2010
187EC8DD0A9839FF pkg UU5100 last 19.06.2010
18B93BA7018BF440 pkg UU5140 last 19.06.2010
18B787F91ABF5E5F pkg UU5150 last 19.06.2010
18B8703C0EAC5362 pkg UU5170 last 19.06.2010
18B93BAF121C5338 pkg UU5180 last 19.06.2010
18B93BB41DA1A588 pkg UU5190 last 19.06.2010
18BAD43E119CCE96 pkg UU5200 last 19.06.2010
187EC8FC1E4833B7 pkg UU5230 last 19.06.2010
187EC8FF0DC9E676 pkg UU5250 last 19.06.2010
18B787EB09F7523D pkg UU5300 last 19.06.2010
189771C815D439DB pkg UU5350 last 19.06.2010
187EC908172CAF62 pkg UU5400 last 19.06.2010
187EC90A1309B6D0 pkg UU5450 last 19.06.2010
18B81DE0019D1AB5 pkg UU5500 last 19.06.2010
18BAD44118B7F9EE pkg UU5510 last 19.06.2010
18B9D8510A07FF56 pkg UU5550 last 19.06.2010
187EC91A03A26C59 pkg UU5600 last 19.06.2010
187EC93208249BD4 pkg UU5700 last 19.06.2010
187EC9350EF03146 pkg UU5750 last 19.06.2010
18BFB2721FDE386C pkg UU5800 last 19.06.2010
18B787580923F4AC pkg UU5850 last 19.06.2010
18B787531C531B2C pkg UU5900 last 19.06.2010
18B5D27E08F2DBFC pkg UU5950 last 19.06.2010
18A9DAB21ED4FB30 pkg UU5960 last 19.06.2010
18B15FF01C84C7CE pkg UU6210 last 19.06.2010
188A3C9B1552CDE7 pkg UU8540 last 19.06.2010
18B93BE5034A10E8 pkg UU8550 last 19.06.2010
187EC9471DAFA9BE pkg UU8560 last 19.06.2010
18B7606C1EA94E9D pkg UU8570 last 19.06.2010
18B4DED41D22412E pkg VDDBM00 last 14.06.2010
18B8233C1DCCAA5A pkg VDDBM01 last 20.06.2010
18B8233D0B8F0860 pkg VDDBM02 last 20.06.2010
18B4DEDD097FBC62 pkg VDDBM03 last 14.06.2010
18B52B5F02E526E2 pkg VDDBM04 last 20.06.2010
18B8233E065A6352 pkg VDDBM05 last 20.06.2010
18B52B600D8FB0A0 pkg VDDBM06 last 18.06.2010
18B52B610D8A7348 pkg VDDBM07 last 20.06.2010
18B8233E1F8E6570 pkg VDDBM08 last 20.06.2010
18B52B6302B6904C pkg VDDBM09 last 20.06.2010
18A7D00019CD96B2 pkg VDDBM10 last 20.06.2010
18B87639014F68F2 pkg VDDBM15 last 20.06.2010
18B52B640F61D5D6 pkg VDDBM17 last 20.06.2010
18B52B65008607D8 pkg VDDBM30 last 20.06.2010
18B52B65198291A3 pkg VDERR01 last 18.06.2010
18B8234208A487BC pkg VDGLH00 last 20.06.2010
18B8236210352502 pkg VDINF01 last 18.06.2010
18B823421AFE5DDA pkg VDINI01 last 20.06.2010
18B52B671CA608AC pkg VDREC00 last 20.06.2010
18B823440B983FB6 pkg VDUTI41 last 20.06.2010
18B52B691F20FF92 pkg VDUTI42 last 20.06.2010
18B9904C0337DDD8 pkg VK0100 last 20.06.2010
18B990610515915C pkg VK0110 last 20.06.2010
18B9905D1372EE8D pkg VK0120 last 18.06.2010
18B990660591BA68 pkg VK0700 last 19.06.2010
18B9906B062802CD pkg VK7500 last 20.06.2010
189A9BE41FA6A9FE pkg VK7505 last 20.06.2010
18B5EA3C1E1994B7 pkg VP0030 last 20.06.2010
185B145E0CF405BC pkg VP0611I last 19.06.2010
189CEEBE16E043C1 pkg VP5300 last 19.06.2010
189CEEC406598593 pkg VP5310 last 19.06.2010
189CEEB41FEA2A32 pkg VP5330 last 18.06.2010
189CEECA0F25B259 pkg VP5340 last 18.06.2010
1850EC0F0A30070C pkg VP5500 last 12.06.2010
1850EBB01594ADEA pkg VP7040 last 18.06.2010
1873C4AE160F8CA2 pkg VP7600 last 04.06.2010
18B521651B92ECCE pkg VP7700 last 17.06.2010
18B29F9F151DEAA6 pkg VP8460 last 19.06.2010
187E2CBB07E39B5F pkg VT5140 last 18.06.2010
18A7A428000172AA pkg VV3NTP last 20.06.2010
18B9902315336BCE pkg VV3200 last 18.06.2010
18B990291CA0C9E3 pkg VV3400 last 20.06.2010
18B6E8100F081C34 pkg VV6050 last 19.06.2010
18AE65441678A64E pkg VV6900 last 20.06.2010
189A9BFE0E22ACE2 pkg VV7760 last 20.06.2010
18B990561FF18602 pkg VV8340 last 19.06.2010
18C20A2B0838241C pkg VV8901 last 20.06.2010
18B9933B1D229CED pkg WA5000 last 19.06.2010
18B9933C020B5056 pkg WA5010 last 19.06.2010
18B9933E08C5B4E8 pkg WA5340 last 11.06.2010
18C006A40EF05C56 pkg WA5340 last 19.06.2010
18BE9BB80E0CE702 pkg WA5700 last 11.06.2010
18C282CF07DA3C1A pkg WA5700 last 18.06.2010
18A8C1800A4CBF3C pkg WA8800 last 18.06.2010
18C02ADA14E0BE08 pkg WB0310 last 11.06.2010
18C258A71C6BB90C pkg WB0310 last 14.06.2010
18C411830388E022 pkg WB0310 last 18.06.2010
18BD06E5039132DC pkg WB0330 last 20.06.2010
18B98C0E06C2AEF0 pkg WB0350 last 07.06.2010
18B98BF91573C79C pkg WB0380 last 19.06.2010
18B98BC70BB963D6 pkg WB0400 last 19.06.2010
18B98C0900BBE948 pkg WB0470 last 18.06.2010
18C02AF11C3EE18E pkg WB0640 last 11.06.2010
18C258A61629CDD2 pkg WB0640 last 14.06.2010
18C40F8A196CA376 pkg WB0640 last 20.06.2010
18BD04FF0B6A3974 pkg WB0650 last 20.06.2010
18C02AC71CDA8BDA pkg WB0670 last 11.06.2010
18C2578D0D86480A pkg WB0670 last 14.06.2010
18C40F8A0A550618 pkg WB0670 last 18.06.2010
18BFDF4204C94686 pkg WB0700 last 20.06.2010
18C02AE803625554 pkg WB0750 last 11.06.2010
18C259131B18AC12 pkg WB0750 last 14.06.2010
18C40F8A1094B9D8 pkg WB0750 last 19.06.2010
18BCFE6409BE87C2 pkg WB0760 last 20.06.2010
18BCFE7411EF28D4 pkg WB0880 last 20.06.2010
18B98BD4013C8312 pkg WB1270 last 19.06.2010
18C02AEF1F911018 pkg WB1320 last 11.06.2010
18C259080C56E5A6 pkg WB1320 last 14.06.2010
18C40F8A1E8E7968 pkg WB1320 last 18.06.2010
18BCFE6500F95C74 pkg WB4700 last 20.06.2010
18B98BCE07773D14 pkg WB5020 last 19.06.2010
18B98C4B03DD017C pkg WB5240 last 18.06.2010
18B98C1D17FE5970 pkg WB5330 last 19.06.2010
18B98C480F06DD5A pkg WB5350 last 18.06.2010
18BD01521DAD8158 pkg WB5400 last 18.06.2010
1882B2C9074123D5 pkg WB5510 last 19.06.2010
18BC8662102B25AA pkg WB5570 last 19.06.2010
18BD015B07F52C82 pkg WB5600 last 19.06.2010
18A017DC00FF2988 pkg WB5650 last 17.06.2010
18BD01670A36D762 pkg WB5700 last 18.06.2010
18BD016D1C0AF4F6 pkg WB5710 last 18.06.2010
18B82CC711AAC2C0 pkg WB7650 last 18.06.2010
18B82CC213124758 pkg WB7750 last 19.06.2010
18B98C0916080AF5 pkg WB8010 last 18.06.2010
18B98BE20B970ACC pkg WB8040 last 31.05.2010
18B98BDE136E9FAA pkg WB8050 last 11.06.2010
18C2590D0C3B1A92 pkg WB8050 last 18.06.2010
18B98C52042381F6 pkg WB8080 last 18.06.2010
18B98BD5085E792E pkg WB8160 last 19.06.2010
18C02B3609B5B08A pkg WB8220 last 11.06.2010
18C16F420CADE84E pkg WB8220 last 14.06.2010
18C411930B336A34 pkg WB8220 last 18.06.2010
18BCD623092B8A34 pkg WB8385 last 19.06.2010
18BD01151A0E2198 pkg WB8630 last 20.06.2010
18B8009616B307A6 pkg WB8719 last 18.06.2010
18B98BDA13F3C014 pkg WB8730 last 19.06.2010
18B98C570F974E8E pkg WB8740 last 19.06.2010
18B98C1418E1641C pkg WB8760 last 19.06.2010
187710C504CB7E7B pkg WB9030 last 14.06.2010
18AE9803049FFEA2 pkg WB9600 last 27.05.2010
18C2574301306B7A pkg WB9600 last 17.06.2010
18BCFE650272FE66 pkg WC0070 last 18.06.2010
18BFB64E181080C0 pkg WC5010 last 19.06.2010
18BC86651CBE8512 pkg WC5080 last 18.06.2010
18BB740401EE9B32 pkg WC7260 last 19.06.2010
189F4C050D41BD69 pkg WC7270 last 19.06.2010
18BB74040ACA6D9E pkg WC7280 last 19.06.2010
18BB74021803798C pkg WC7310 last 19.06.2010
18BB74020BD024BE pkg WC7320 last 19.06.2010
18BB740C17D1FA44 pkg WC7530 last 19.06.2010
18BB74030BE9A13A pkg WC7540 last 18.06.2010
18BC866E01AF6906 pkg WC8120 last 19.06.2010
18BC865117B85164 pkg WC8170 last 19.06.2010
18BC866108849336 pkg WC8410 last 19.06.2010
18B84E910B021E91 pkg WF0210 last 19.06.2010
18B7089E0D02D5DB pkg WF0250 last 19.06.2010
18B64637054F5CD6 pkg WF0280 last 18.06.2010
18AEB61F0DDAFFD2 pkg WF0290 last 18.06.2010
18AEB6240CA2067A pkg WF0300 last 18.06.2010
18B6462C0E5DAE14 pkg WF0310 last 18.06.2010
18B6462916B4D55B pkg WF0320 last 18.06.2010
18A7F60317A73B1E pkg WF0330 last 18.06.2010
18A7F6011337840C pkg WF0340 last 18.06.2010
18AEB60B0CCA613A pkg WF0350 last 18.06.2010
18BBC0D81B6A6F0A pkg WF0360 last 18.06.2010
18B626B80E6C0E0A pkg WF0900 last 20.06.2010
18B9945401AE0217 pkg WF0910 last 12.06.2010
18C28AA21FE27758 pkg WF0910 last 20.06.2010
18B73717149C1996 pkg WF0920 last 20.06.2010
18B626C00B620BE6 pkg WF0950 last 20.06.2010
18B994560AD38F06 pkg WF1010 last 20.06.2010
18B646260D5CDE3A pkg WF1020 last 20.06.2010
18BE1A9E0F992352 pkg WF1070 last 12.06.2010
18C286FA1907D8A6 pkg WF1070 last 15.06.2010
18C446E305B5D872 pkg WF1070 last 17.06.2010
18C4920A0C75D79C pkg WF1070 last 20.06.2010
1885DAA611D67A36 pkg WF5010 last 19.06.2010
18B994581226858A pkg WF5310 last 11.06.2010
18C28AA71BCE1668 pkg WF5310 last 18.06.2010
18B7372608089276 pkg WF5420 last 17.06.2010
187CC51C1E30909A pkg WF5520 last 18.06.2010
18B737291E3834C4 pkg WF5530 last 18.06.2010
18B626D40BB9ABDE pkg WF5570 last 19.06.2010
1885B5951472DECF pkg WF5700 last 20.06.2010
18A8E89F0F0BB8A0 pkg WF5800 last 20.06.2010
188F9A7C1EA4BE01 pkg WF5900 last 20.06.2010
18A8961B0E7130F0 pkg WF5910 last 20.06.2010
1886C93807B5C125 pkg WF6700 last 20.06.2010
187ECF9B030264FA pkg WF6720 last 18.06.2010
189A688D003FCE19 pkg WF8070 last 15.06.2010
18BCDEDD03B67F68 pkg WG5000 last 18.06.2010
18B5C68805011AD8 pkg WG5010 last 18.06.2010
18BE24CC1A7D9B2A pkg WG5020 last 09.06.2010
18C02C4217DCD04E pkg WG5030 last 18.06.2010
18BA586E02DCB28E pkg WG5040 last 18.06.2010
18B624CE166078F2 pkg WG5050 last 15.06.2010
18B624A81B24ECAA pkg WG5060 last 18.06.2010
18BC91511BB11218 pkg WG5100 last 18.06.2010
189BD788174DE51A pkg WG5110 last 18.06.2010
18A45EF2183C2489 pkg WG5120 last 18.06.2010
18B737040E0B5980 pkg WG8040 last 19.06.2010
189CF12D00A8236C pkg WI0280 last 20.06.2010
18C02B131DB2018A pkg WI1030 last 11.06.2010
18C2303617F672A6 pkg WI1030 last 14.06.2010
18C411A60B9E13C2 pkg WI1030 last 18.06.2010
18B98EC50779B528 pkg WI1090 last 14.06.2010
18BFDF6E051DE948 pkg WI1110 last 11.06.2010
18C230440DB61DD6 pkg WI1110 last 18.06.2010
18A38CE614092B48 pkg WI5100 last 18.06.2010
189C793102827529 pkg WI5110 last 19.06.2010
18BBCA2A02C3335C pkg WI5350 last 18.06.2010
18BBCA290F095766 pkg WI5370 last 02.06.2010
18BBCA291A2A22E6 pkg WI5620 last 19.06.2010
18B98EC8166D0F3C pkg WI5680 last 18.06.2010
189C7918122DA3DD pkg WI5860 last 18.06.2010
18AAF07D0433178A pkg WI5930 last 20.06.2010
18B98FA415FD6872 pkg WI5940 last 20.06.2010
18B98F9C07F711D4 pkg WI5950 last 19.06.2010
18B98EC51C2E10B3 pkg WI7210 last 18.06.2010
18BBBEFD038B6B5A pkg WI8710 last 19.06.2010
18BDA9BF08702AD2 pkg WJ5070 last 15.06.2010
18C43E931C370B3C pkg WJ5070 last 18.06.2010
188C7B4111FD6A14 pkg WL0020 last 17.06.2010
18B4B36A0DF1C1A0 pkg WL5220 last 19.06.2010
1898B9C80899CF64 pkg WL7100 last 19.06.2010
189A79670FE89081 pkg WL7200 last 19.06.2010
1898B9CE17AA0943 pkg WL7220 last 19.06.2010
1898B9D30DB70B64 pkg WL7240 last 19.06.2010
1898B9D503C3414E pkg WL7260 last 01.06.2010
189DC1971E299B05 pkg WL7300 last 11.06.2010
18B5CD320FDB7232 pkg WL7310 last 19.06.2010
1898B9DB077D507E pkg WL7320 last 02.06.2010
1898B9DC11F937CD pkg WL7330 last 19.06.2010
1898B9DD1BB8B63F pkg WL7350 last 01.06.2010
18B8205410C68F81 pkg WL7360 last 19.06.2010
1898B9E00513CFFC pkg WL7370 last 01.06.2010
1898B9E1069FEDE6 pkg WL7390 last 02.06.2010
1898B9E20DC77ED2 pkg WL7510 last 19.06.2010
18BCD96711E9A338 pkg WL8200 last 19.06.2010
1898BA7615750B4B pkg WL8260 last 01.06.2010
18B8205E19C843A6 pkg WL8320 last 19.06.2010
18B4B3D019817236 pkg WL8330 last 19.06.2010
18AB4542064FF5B4 pkg WL8520 last 10.06.2010
18BCD96817B43D92 pkg WL8600 last 19.06.2010
187ECF41058ED8E6 pkg WL8760 last 19.06.2010
18BA87C01B5C52AA pkg WM0010 last 11.06.2010
18C2886B00C96C6A pkg WM0010 last 18.06.2010
18B75ECF074711A2 pkg WM0120 last 14.06.2010
18AFB09B15F65226 pkg WM5010 last 11.06.2010
18B6463809FEF78A pkg WM8400 last 14.06.2010
18BFDF7115A11A1A pkg WN0200 last 18.06.2010
18BCFFBF1EFD89AA pkg WN0240 last 18.06.2010
18BCFFC413BB25C4 pkg WN0260 last 09.06.2010
18BCFFC005D9FB76 pkg WN0270 last 20.06.2010
18BCFFB40751B018 pkg WN0280 last 09.06.2010
18BFDF741D8F8088 pkg WN0450 last 11.06.2010
18C258E8117CAB30 pkg WN0450 last 18.06.2010
18BFDF6C001D1E28 pkg WN0510 last 11.06.2010
18C258E91D528586 pkg WN0510 last 19.06.2010
18BFDF7411B263E6 pkg WN0550 last 11.06.2010
18C258EB0E4C54A0 pkg WN0550 last 20.06.2010
18BFDF821D1BB7F6 pkg WN0600 last 10.06.2010
18BCFFD70A39E5AE pkg WN0610 last 18.06.2010
18BFDF8301E2F7FC pkg WN0620 last 11.06.2010
18C258EF1E619536 pkg WN0620 last 18.06.2010
18BCFFF104337E9A pkg WN5040 last 18.06.2010
18BCFFF31027AE48 pkg WN5050 last 18.06.2010
18BFDF7D1F30AEEC pkg WN5150 last 11.06.2010
18C258FA067CF2C0 pkg WN5150 last 19.06.2010
18BCFFEB0223A14C pkg WN5200 last 11.06.2010
18C259000621235C pkg WN5200 last 19.06.2010
18BD00151B06D7C2 pkg WN5500 last 18.06.2010
18BFDF901F44A59E pkg WN5700 last 11.06.2010
18C259061B8EE4F8 pkg WN5700 last 19.06.2010
18BD000207CE80CC pkg WN5710 last 19.06.2010
18BAA4FC1ACB5656 pkg WN8130 last 19.06.2010
18BAA51C0F792116 pkg WN8150 last 19.06.2010
18BFDF980FD2A914 pkg WN8180 last 01.06.2010
18BD005917AC8116 pkg WQ5000 last 11.06.2010
18C27E4508E1F944 pkg WQ5000 last 20.06.2010
18B9B40B049AEFE8 pkg WQ5950 last 11.06.2010
18C0F32F1C05D494 pkg WQ5950 last 20.06.2010
18B9B41811AD57E6 pkg WQ6000 last 01.06.2010
18B9379C1DD8DAF4 pkg WQ6010 last 19.06.2010
18BCB44409B07A44 pkg WQ6020 last 20.06.2010
18BDD1200C69C7C6 pkg WQ6040 last 20.06.2010
18B9B4181C0240B4 pkg WQ6040 last 06.06.2010
187CEE151070775D pkg WU1000 last 18.06.2010
18BD81650C154BE2 pkg WU5000 last 12.06.2010
18C121E909441AE6 pkg WU5000 last 19.06.2010
18B8064705E99C42 pkg WU5050 last 02.06.2010
18B4173A1B47AAE7 pkg WU5070 last 19.06.2010
18B8065906356705 pkg WU5130 last 19.06.2010
18BC87BC0B7D4C4C pkg WU5800 last 02.06.2010
187D181C022183C0 pkg WU5900 last 20.06.2010
18B992391B1CB39C pkg WU5920 last 02.06.2010
18BFD3EE00835624 pkg WV0570 last 11.06.2010
18C1E41A10E53852 pkg WV0570 last 20.06.2010
18B992540EBE8BBA pkg WV5030 last 01.06.2010
18BADBFA19B85180 pkg WV5090 last 11.06.2010
18C056D60D879AF8 pkg WV5090 last 19.06.2010
187DDF1501D50FF0 pkg WY5200 last 19.06.2010
18B809B10C5AA842 pkg WY5400 last 18.06.2010
187DDF170E5F1846 pkg WY5410 last 03.06.2010
189CD57E15626CE0 pkg XBAN05 last 20.06.2010
18BC63D118FE829C pkg XBAN10 last 11.06.2010
18C0F50E029D8FC6 pkg XBAN10 last 19.06.2010
18BC63D31FEB0BEA pkg XBAN15 last 06.06.2010
18C0F5141C936C7C pkg XBAN15 last 20.06.2010
18BC63D415F8A870 pkg XBAN16 last 06.06.2010
18C0F51600CEC410 pkg XBAN16 last 20.06.2010
18BC63D50E92539C pkg XBAN20 last 12.06.2010
18C0F51713199B0E pkg XBAN20 last 20.06.2010
189CDFAB161ACF50 pkg XBAN27 last 15.06.2010
189CD6081636277C pkg XBAN31 last 20.06.2010
189CDFCE1895461C pkg XBAN33 last 20.06.2010
18C145DB17B0FD0A pkg XBAN60 last 20.06.2010
189CD6370BF12532 pkg XBAN60 last 11.06.2010
189CD63C14172910 pkg XBAN92 last 20.06.2010
18783EFB0F51F898 pkg XBAP75 last 20.06.2010
1864677309195755 pkg XBAP76 last 20.06.2010
18AC12161147E8FA pkg XBAP77 last 20.06.2010
18BD0AA21BC301B8 pkg XBARR0 last 20.06.2010
1864652515A1785C pkg XBARR2 last 20.06.2010
18AD000107DD33FE pkg XBARR7 last 20.06.2010
187D3E76024A915B pkg XBARSSD last 20.06.2010
1863EA7216046D13 pkg XBAR01L last 20.06.2010
1863EA880D6C9FD6 pkg XBAR03L last 20.06.2010
1863EA751EE83FD4 pkg XBAR04L last 20.06.2010
1863EA7915A9E09C pkg XBAR05L last 20.06.2010
1863EA89053FF29E pkg XBAR08L last 20.06.2010
1863EA9006B291BE pkg XBAR09L last 20.06.2010
1863EA9600799D70 pkg XBAR10L last 20.06.2010
1863EA9E11524DFF pkg XBAR11L last 20.06.2010
1863EAA90E778D5F pkg XBAR14L last 18.06.2010
1887C69E12183588 pkg XBAR77 last 19.06.2010
189CD64814FF7CDA pkg XBAUR01 last 14.06.2010
18BBBDAE09BCB0C0 pkg XBAU01 last 19.06.2010
18BC63A5187DC188 pkg XBBK04 last 20.06.2010
18BC63A51CD2E1FC pkg XBBK05 last 19.06.2010
187CA14404DA8218 pkg XBCRPV2 last 20.06.2010
186468031E75D29C pkg XBCSBY last 18.06.2010
186468A91A717ADA pkg XBCS00 last 18.06.2010
1863EB4809317EDF pkg XBCS001 last 20.06.2010
186468AA0A3F0A44 pkg XBCS01 last 18.06.2010
1873A48B073C182A pkg XBCS15 last 18.06.2010
186468B6106BD1BD pkg XBCS16 last 18.06.2010
186468BA1117920F pkg XBCS25 last 18.06.2010
18646848191CDB42 pkg XBCS38 last 04.06.2010
186468C9123C68CA pkg XBCS45 last 20.06.2010
18B3163A1A5305D0 pkg XBCV01 last 20.06.2010
1894F4BC08020370 pkg XBDFD4 last 20.06.2010
1863EB4B138C3C4E pkg XBDF50C last 26.05.2010
1863EB4C1AF2DBBA pkg XBDF50L last 26.05.2010
18669D6B188DE248 pkg XBDP90 last 20.06.2010
18C0026D1740CAB4 pkg XBDSDP last 20.06.2010
189CD6B311B5666C pkg XBDSVR2 last 02.06.2010
1886A833141A4D57 pkg XBDS001 last 19.06.2010
1861162D03E2F011 pkg XBDS003 last 19.06.2010
1886A5F31FDED435 pkg XBDS004 last 20.06.2010
187DDE61028FAFBA pkg XBDS01L last 17.06.2010
18B98AA511096C08 pkg XBDS02 last 20.06.2010
189CD6C10D3F2C0A pkg XBDS03 last 20.06.2010
189CD6C708BFE256 pkg XBDS04 last 20.06.2010
189CD6CE049E6556 pkg XBDS07 last 20.06.2010
18B98AA80771AE8E pkg XBDS08 last 20.06.2010
189CDBB71BCAC70A pkg XBEX01 last 18.06.2010
18B880FE12DE941C pkg XBEX02 last 18.06.2010
18A5C28D0C4F6FDE pkg XBIM00E last 16.06.2010
18BC639C1F88F370 pkg XBIM02 last 11.06.2010
18BFD5AF0EA30524 pkg XBIM02 last 20.06.2010
18BC694717A98746 pkg XBIM03 last 11.06.2010
18C0F51E106F2E00 pkg XBIM03 last 20.06.2010
18A7333D0F70041A pkg XBIM031 last 20.06.2010
1889C8A0133EFAC5 pkg XBIM033 last 20.06.2010
18A31F51144939A4 pkg XBIM036 last 20.06.2010
1887BC0406B8BF26 pkg XBIM038 last 20.06.2010
18BC639E16659842 pkg XBIM04 last 11.06.2010
18C009B4130539FC pkg XBIM04 last 20.06.2010
189CCB671C076E5C pkg XBIM041 last 19.06.2010
18B716FE18FF18AA pkg XBIM042 last 20.06.2010
18AD058E173001D6 pkg XBIM043 last 20.06.2010
18A42EF9097794BE pkg XBIM05 last 11.06.2010
18C009550A1D76FC pkg XBIM05 last 20.06.2010
18A31E7719ABB224 pkg XBIM06 last 11.06.2010
18BEEF801A7076CE pkg XBIM06 last 20.06.2010
189CDBE40A98293E pkg XBIM10 last 20.06.2010
189CDC2012628854 pkg XBIM31 last 20.06.2010
189CDC2B0F040D92 pkg XBIM32 last 20.06.2010
18B6E2781611D18A pkg XBIM33 last 20.06.2010
189CDC341DDC1626 pkg XBIM34 last 20.06.2010
189CDC381138E674 pkg XBIM35 last 20.06.2010
18BC694A1D777BC6 pkg XBIM40 last 11.06.2010
18C0F52E1EBF3A12 pkg XBIM40 last 20.06.2010
18C0026E0EAA30EC pkg XBIM41 last 20.06.2010
18BC694C022E2B0C pkg XBIM42 last 11.06.2010
18C0F5300ACDD7D8 pkg XBIM42 last 20.06.2010
18C0026F0668DBCE pkg XBIM43 last 17.06.2010
189CDC810D6FDA96 pkg XBIM53 last 20.06.2010
18B968DD12E83236 pkg XBIM75 last 17.06.2010
189CDC9305D289CC pkg XBIM76 last 17.06.2010
189CDD401D8A2DF2 pkg XBIS31 last 19.06.2010
189CDD580553FA4A pkg XBIS36 last 18.06.2010
189CDD811AB3EDE0 pkg XBIS45 last 18.06.2010
189CDD8D1FCFEEC4 pkg XBIS47 last 20.06.2010
1887BD520CCCB94E pkg XBIS50 last 18.06.2010
18B4379E0DD37965 pkg XBIS80 last 20.06.2010
189CDDC51FD6DD97 pkg XBIS81 last 20.06.2010
189CDDCC17497342 pkg XBIS82 last 02.06.2010
188F96DB0BCC6787 pkg XBLE082 last 20.06.2010
18BBBDB21B15EB02 pkg XBLE80 last 20.06.2010
18BBBDB511447AA0 pkg XBLE82 last 31.05.2010
188D11B901EFFA61 pkg XBLE84 last 20.06.2010
18A3B5FE0854B8BC pkg XBLE85 last 20.06.2010
1866C12C03498755 pkg XBLE86 last 20.06.2010
18B991DA084E5CBC pkg XBLE86C last 20.06.2010
186468751F5C6870 pkg XBLGL0 last 20.06.2010
186460DE0D0C4556 pkg XBLG002 last 20.06.2010
189CDDF218BC8957 pkg XBLG10 last 18.06.2010
189CDDFA0813CBF1 pkg XBLG11 last 18.06.2010
189CDDFF1D1717B0 pkg XBLG77 last 18.06.2010
1887BD5414B2F500 pkg XBMQ400 last 20.06.2010
189CDE0512FE11BC pkg XBOS01 last 19.06.2010
189CDE0B0ADB1328 pkg XBOS02 last 19.06.2010
189CDE110D7D9B5C pkg XBOS03 last 19.06.2010
189CDE2D1CF3B112 pkg XBOS06 last 15.06.2010
189CDE3408782E8F pkg XBOS08 last 19.06.2010
18B437A41D78459E pkg XBOS10 last 19.06.2010
18B437A90FFF00E2 pkg XBOS11 last 19.06.2010
1864686F0C24E7A9 pkg XBOS59 last 19.06.2010
18646878120C163E pkg XBOS62 last 17.06.2010
186468721897144A pkg XBOS64 last 17.06.2010
187C4B661947E150 pkg XBOS65 last 20.06.2010
186468D20CE3C0A2 pkg XBOS66 last 20.06.2010
1863EB7C1B8EDD5C pkg XBPR01L last 20.06.2010
1863EB800D6E98DB pkg XBPR02L last 20.06.2010
1863EB8500AEEF1C pkg XBPR03L last 20.06.2010
1863EB901C0CE6EC pkg XBPR05L last 20.06.2010
1863EB961422FF01 pkg XBPR06L last 18.06.2010
189CDE861DEFA7C4 pkg XBPR54 last 20.06.2010
18B281A80402D1BC pkg XBPR55 last 20.06.2010
1887C69E1DB261E2 pkg XBPR77 last 19.06.2010
187DDDA01D25863D pkg XBRMSEC last 20.06.2010
189AC5F906DB2C08 pkg XBRM01K last 18.06.2010
1863EBA21F7545F4 pkg XBRM01L last 18.06.2010
189CDF2F119E6926 pkg XBRM02 last 19.06.2010
18783F8A0BBCD26C pkg XBRM02L last 08.06.2010
189CDF370243BEF4 pkg XBRM03 last 19.06.2010
1863EBAE1F717C62 pkg XBRM03L last 08.06.2010
189CDF41100E219A pkg XBRM05 last 19.06.2010
1863EBBE04398585 pkg XBRM05L last 02.06.2010
1863EBD515345B73 pkg XBRM09L last 11.06.2010
186460FA1337033C pkg XBSAVE last 20.06.2010
18BEEDFB1F7B7E22 pkg XBW2020 last 20.06.2010
18B769AA11ED61F4 pkg XBW2020 last 11.06.2010
188CC66713C9E194 pkg XB5000 last 20.06.2010
18B990F116C2E586 pkg XB9010 last 12.06.2010
18C128EB1C1C5B1C pkg XB9010 last 20.06.2010
18BE21861B979F84 pkg XB9020 last 04.06.2010
18C128EC165309D6 pkg XB9020 last 20.06.2010
18BE299D0F03C016 pkg XB9040 last 18.06.2010
1863EBD91103C018 pkg XCDRSEC last 20.06.2010
1863EBE01FC82270 pkg XCDR01L last 19.06.2010
1863EBE316FB1C96 pkg XCDR011 last 18.06.2010
1863EBEB0356A9F5 pkg XCDR02L last 18.06.2010
1863EBF20BA6A8AB pkg XCDR032 last 18.06.2010
1863EBFB0C990C2D pkg XCDR05L last 18.06.2010
1863EC120415EAC7 pkg XCDR10L last 03.06.2010
1863EC1703E8404A pkg XCDR101 last 20.06.2010
1863EC1C0E85604B pkg XCDR102 last 20.06.2010
1863EC270D3699B6 pkg XCDR11L last 20.06.2010
1863EC38172A6424 pkg XCDR13L last 20.06.2010
1863EC3B15FCEA18 pkg XCDR130 last 20.06.2010
1863EC460789FA77 pkg XCDR14L last 20.06.2010
1863EC4D041653F2 pkg XCDR15L last 20.06.2010
1894EE710C09FD3E pkg XCDR17L last 20.06.2010
1863EC650A793C1B pkg XCDR18K last 20.06.2010
1863EC6E18FF74A0 pkg XCDR183 last 20.06.2010
1863EC7C11FF51B0 pkg XCDR21L last 20.06.2010
18AE8F021AE28942 pkg XCDR22L last 20.06.2010
1863EC891DBF525D pkg XCDR25L last 20.06.2010
1863EC901438A2C8 pkg XCDR26L last 20.06.2010
1863ECA403603E16 pkg XCDR31L last 18.06.2010
1863ECA918D3CF30 pkg XCDR32L last 18.06.2010
1863ECB5147D83AE pkg XCDR33L last 14.06.2010
1863ECBA19C42614 pkg XCDR34L last 18.06.2010
1863ECC30D87D568 pkg XCDR35L last 18.06.2010
1863ECD7043A12AD pkg XCDR39L last 07.06.2010
1863ECDD0B18B25A pkg XCDR40L last 20.06.2010
1863ECE4157E49D6 pkg XCDR41L last 20.06.2010
1863ECF30CCA5641 pkg XCDR43L last 20.06.2010
1863ECF716DCFBBD pkg XCDR44L last 20.06.2010
1863ED061BF1594C pkg XCDR47L last 19.06.2010
1863ED0E0D575430 pkg XCDR50L last 20.06.2010
18BD0AA904F558B0 pkg XCDR77 last 19.06.2010
1887C37805883308 pkg XCMU008 last 20.06.2010
1887C5CA0098560C pkg XCMU017 last 17.06.2010
18BE935A0B2D9612 pkg XCMU020 last 20.06.2010
18B961610C3C2164 pkg XCMU020 last 11.06.2010
186C922A1DCC5C95 pkg XCTR01 last 20.06.2010
1893D492070B78F6 pkg XCUTUKG last 20.06.2010
17CF38BA0A3924FE pkg XCWWRBW last 18.06.2010
170E45B80614649C pkg XCWWRBW last 18.06.2010
188E751E0DA8EC38 pkg XC5000 last 14.06.2010
18AE4D2410D7440E pkg XC5001 last 14.06.2010
189520670E6A129A pkg XC5002 last 19.06.2010
18910AC50187E178 pkg XC5008 last 20.06.2010
1842488C0774545D pkg XC6001 last 20.06.2010
18951A750A32B1E5 pkg XC6002 last 20.06.2010
18424EC51A32CF9D pkg XC6003 last 20.06.2010
1889F6D81354D8F8 pkg XC6004 last 20.06.2010
187ADB7F0718A692 pkg XC6006 last 19.06.2010
18C1480D1EE44090 pkg XC6007 last 18.06.2010
187233F8041B06EE pkg XR5000 last 20.06.2010
1871E49C1E9B4D68 pkg XR5010 last 20.06.2010
189FEF291303F0AE pkg XR5020 last 20.06.2010
1887B722144262E5 pkg XR5030 last 19.06.2010
18A66D89158522E6 pkg XR5040 last 18.06.2010
18AB1B3D077A1EEC pkg XR5050 last 20.06.2010
187356CE1188C54E pkg XR5080 last 18.06.2010
1873565D0FB7E662 pkg XR5090 last 18.06.2010
18BA7D3C01693D7E pkg XR5100 last 18.06.2010
187442FE0059B018 pkg XR5110 last 20.06.2010
18C004DA1FCF7054 pkg XR5120 last 18.06.2010
189C9E6D17F53948 pkg XR5140 last 18.06.2010
18A9D8FC01B2B23E pkg XR5150 last 18.06.2010
18A8F268125E037C pkg XR5160 last 13.06.2010
189F56E10F2C05F5 pkg XR5170 last 19.06.2010
1872D4DA16EC2E9D pkg XR5180 last 18.06.2010
184D786407328FBD pkg XR5190 last 18.06.2010
1870FBD915E04EB0 pkg XR5320 last 18.06.2010
1870FBE403D19479 pkg XR5330 last 18.06.2010
1867FCCE04608C08 pkg XR5400 last 28.05.2010
189F5B7D0FD91F06 pkg XR5410 last 02.06.2010
17C858561FB3015C pkg XXRICPTS last 20.06.2010
17C8584801D08F08 pkg XXRI07 last 20.06.2010
1856151B155EC743 pkg YAPUDLK last 20.06.2010
18531CC51217B696 pkg YAPULDK last 20.06.2010
188C1E820158F356 pkg YAPUOBJ last 20.06.2010
18672E291E5CDE39 pkg YAPUPND last 20.06.2010
188B8250057F9496 pkg YAPURCV last 20.06.2010
18B82AD11F23B61E pkg YAPUTGK last 19.06.2010
18531CD009DB3791 pkg YAPU163 last 18.06.2010
188C1E8814F7CB88 pkg YAPU164 last 18.06.2010
18B82AD10B65C1C2 pkg YAPU165 last 18.06.2010
18531D0F061F60F8 pkg YAP8005 last 18.06.2010
1885BA420593003A pkg YATGET last 19.06.2010
1885BA19156A1533 pkg YATGKEY last 18.06.2010
187F173B0F125C32 pkg YAU0120 last 18.06.2010
1869168D1389E57F pkg YAU016S last 20.06.2010
18691766010B7280 pkg YAU018D last 20.06.2010
186916941ECB0A82 pkg YAU018I last 20.06.2010
186916660DA1A5A1 pkg YAU018S last 20.06.2010
186916AC02925281 pkg YAU018U last 20.06.2010
1869176D0AA61F5E pkg YAU019D last 20.06.2010
18691705048BC9D4 pkg YAU019I last 19.06.2010
186917190F28DFBC pkg YAU019S last 20.06.2010
1869172B1D9D507A pkg YAU019U last 19.06.2010
1869174F094FBACA pkg YAU030D last 20.06.2010
1869175B0476A695 pkg YAU030F last 20.06.2010
1869178302BAB149 pkg YAU030I last 20.06.2010
18691860178F17E0 pkg YAU030S last 20.06.2010
1869186D0CA8EB01 pkg YAU030U last 19.06.2010
187F638211156138 pkg YAU099I last 10.06.2010
1869189C0434069F pkg YAU180D last 20.06.2010
186918C9146C7105 pkg YAU180I last 20.06.2010
186918DA1D9684CD pkg YAU180S last 20.06.2010
186919110DFDE8C0 pkg YAU181D last 20.06.2010
18691944146C8DD2 pkg YAU181I last 20.06.2010
18691967170275B0 pkg YAU181S last 20.06.2010
1869197C16809CE7 pkg YAU190D last 20.06.2010
1869199F066E5DC2 pkg YAU190I last 19.06.2010
186919AE1FF38C61 pkg YAU190S last 20.06.2010
186919CF0E3F384E pkg YAU191D last 20.06.2010
186919F114356E1B pkg YAU191I last 19.06.2010
18691A0104E4CE28 pkg YAU191S last 20.06.2010
187193000675816A pkg YAVAA last 19.06.2010
1871936914BFB914 pkg YAVAAA last 18.06.2010
18B6ECB00B2D14D6 pkg YAVAAAN last 20.06.2010
18B6ECB103E24160 pkg YAVAAVL last 20.06.2010
18B736C60BF5091C pkg YAVADE last 17.06.2010
18B736C8075E1352 pkg YAVAH last 18.06.2010
18B736C914166536 pkg YAVAHDO last 18.06.2010
18746816047C68B4 pkg YAVALP last 20.06.2010
18B6ECB611660A00 pkg YAVANAN last 20.06.2010
18B736F016DCFF87 pkg YAVANL last 18.06.2010
18B736CA1B17915A pkg YAVASA last 19.06.2010
18A890710692588E pkg YAVA00 last 20.06.2010
18A8907200FBAF16 pkg YAVA01 last 20.06.2010
18A890721EB48D48 pkg YAVA02 last 20.06.2010
18A890731B8043E4 pkg YAVA03 last 20.06.2010
18A8907416979DFD pkg YAVA04 last 20.06.2010
18A891CE1A96E0A2 pkg YAVA05 last 20.06.2010
18A891D007C624B6 pkg YAVA06 last 20.06.2010
18A890771ACEA430 pkg YAVA07 last 20.06.2010
18A891D203F502DC pkg YAVA08 last 20.06.2010
18B736CC0EEDD95A pkg YAVBDA last 18.06.2010
18B6ECB70D70136A pkg YAVBDAN last 20.06.2010
18B6ECB811FCAA00 pkg YAVBDVL last 20.06.2010
18B6ECB90A3F9EF0 pkg YAVBELE last 18.06.2010
187193A5131F4DB6 pkg YAVBER last 03.06.2010
18B736A2177EF81B pkg YAVBOND last 19.06.2010
18719377005E45BE pkg YAVBPL last 03.06.2010
18B648230B0C83CC pkg YAVBWST last 20.06.2010
18A891DD0E72F928 pkg YAVCBET last 20.06.2010
18B6ECBA09169A36 pkg YAVCBST last 20.06.2010
18B6ECBB06BDDAF8 pkg YAVCOAN last 20.06.2010
18B6ECBC0088D492 pkg YAVCOBO last 20.06.2010
18522A000676E1DE pkg YAVCOID last 20.06.2010
18A891E401808974 pkg YAVCPID last 18.06.2010
18B6ECE41531879A pkg YAVCUAN last 20.06.2010
18B64029146D3141 pkg YAVDEFA last 20.06.2010
18B93C860AD0441C pkg YAVDODE last 18.06.2010
182C43AD040D6449 pkg YAVDRPL last 20.06.2010
1871937814AB41FA pkg YAVEAA last 18.06.2010
18B6ECE610D3D95E pkg YAVERAN last 20.06.2010
18B704F518F9A9A6 pkg YAVERBA last 20.06.2010
18B704F80ACF0278 pkg YAVERTR last 20.06.2010
18B6ECE71147A9EA pkg YAVERVL last 20.06.2010
18B736CD180F8BB2 pkg YAVFDA last 18.06.2010
18B6ECE81C597246 pkg YAVFNAN last 20.06.2010
18B6ECEA01520AFE pkg YAVFOND last 19.06.2010
18BFB7541AA22678 pkg YAVFSL last 20.06.2010
18AE1FFF109419F4 pkg YAVFSPL last 17.06.2010
188E388A07025D56 pkg YAVFSUP last 19.06.2010
1840938310B0BD71 pkg YAVFS01 last 19.06.2010
18AE20011DF1E30C pkg YAVFS02 last 19.06.2010
184093910A523B45 pkg YAVFS05 last 19.06.2010
18409398020762EE pkg YAVFS06 last 19.06.2010
18AE2003170B4FFA pkg YAVFS08 last 19.06.2010
18AE200411CC4984 pkg YAVFS10 last 17.06.2010
188E388B028632BE pkg YAVFS11 last 20.06.2010
18B86F8E058C76B4 pkg YAVFS21 last 19.06.2010
18B6ECEB035F68A2 pkg YAVGDW last 20.06.2010
18B6ECED0C582EC2 pkg YAVGMP last 19.06.2010
18B6ECEE11B2BA64 pkg YAVGPD last 20.06.2010
18B6ECF00B090132 pkg YAVGPDD last 20.06.2010
18B4119807238494 pkg YAVGPDE last 20.06.2010
18B527BB1DE01CD4 pkg YAVGPD2 last 20.06.2010
18B6ECEF0DC81D0A pkg YAVGPD3 last 19.06.2010
18B411A107126B1D pkg YAVGPD4 last 20.06.2010
18B6ECF01DCD7B4A pkg YAVGPER last 20.06.2010
18B412280B5F10CE pkg YAVGPFD last 11.06.2010
18C211850A4474CA pkg YAVGPFD last 18.06.2010
18B7F97E101AF886 pkg YAVGVW last 20.06.2010
18B736CF0F78023A pkg YAVKAA last 01.06.2010
1871937C0FB79590 pkg YAVKGB last 03.06.2010
18B736FF14ABE41E pkg YAVKRE last 18.06.2010
18351CE116E8F753 pkg YAVKTSL last 19.06.2010
18B73701016F1AA6 pkg YAVKUND last 18.06.2010
18B736A5113D5D71 pkg YAVLIA last 18.06.2010
1871930C0691D1D9 pkg YAVLOC last 18.06.2010
18B6ECF11F4C5236 pkg YAVMAT last 20.06.2010
18B6ECF21ACC979A pkg YAVMAVL last 20.06.2010
18B871F008090BD7 pkg YAVNV10 last 11.06.2010
18C04D7B01507C58 pkg YAVNV10 last 20.06.2010
18B736F40CEB25A6 pkg YAVOPT last 18.06.2010
18B165A204481584 pkg YAVOVER last 18.06.2010
18B6ECF3199324E6 pkg YAVOVVW last 20.06.2010
187193140918F0E0 pkg YAVPAK last 18.06.2010
187193800D1A84EC pkg YAVPAN last 18.06.2010
18B736F30E60CCDB pkg YAVPFR last 03.06.2010
18B737021B7FDCBA pkg YAVPFU last 03.06.2010
18B6ED04046E0212 pkg YAVPFX last 20.06.2010
18B736A8118CF500 pkg YAVPKT last 14.06.2010
18B736D21B99CC7B pkg YAVPLB last 03.06.2010
1891AA4505E20D9B pkg YAVPOOL last 18.06.2010
18AD286610CA61E6 pkg YAVPRP last 03.06.2010
18B93C751D7156A8 pkg YAVPWS last 18.06.2010
18B736AC081E3AF8 pkg YAVQUDE last 18.06.2010
18B6ED050A7CB71E pkg YAVREC1 last 19.06.2010
18BA5CA71E78B3A8 pkg YAVREC2 last 20.06.2010
187193310C6AA01B pkg YAVSEQ last 14.06.2010
18B93C8A0EBD4DEC pkg YAVSOBU last 14.06.2010
18B6ED0602B80770 pkg YAVSTA last 20.06.2010
1871933319D95AFA pkg YAVSTAP last 18.06.2010
187193341EBB64B4 pkg YAVSVB last 03.06.2010
18B7358B144AF91E pkg YAVSWIF last 19.06.2010
1840B29D01E7A670 pkg YAVSW1 last 19.06.2010
1891AA4B0CA18570 pkg YAVTC last 19.06.2010
187193380DA16EAF pkg YAVTODO last 19.06.2010
188E38C50DAE18B2 pkg YAVVDPS last 20.06.2010
1871933A103556C4 pkg YAVVK1 last 03.06.2010
1871933B1AA30F0C pkg YAVVK2 last 03.06.2010
18B6ED070306BD5A pkg YAVVSRV last 20.06.2010
18A892131E35DA8C pkg YAVVTXT last 18.06.2010
18B6ED080CA7C630 pkg YAVWHGR last 20.06.2010
18B6ED0A064CD11C pkg YAVX001 last 18.06.2010
18B5CCC1063904E4 pkg YAVX002 last 19.06.2010
18B5CCD1066BFEF4 pkg YAVX003 last 19.06.2010
18BC698C08B8D22C pkg YAVX004 last 11.06.2010
18C283EA1F1388E2 pkg YAVX004 last 19.06.2010
18B5CCDF0F591211 pkg YAVX005 last 19.06.2010
18B5CD850E0BE676 pkg YAVX006 last 19.06.2010
18B418971E2C5488 pkg YAVX007 last 19.06.2010
18B6ED0D16148196 pkg YAVX012 last 20.06.2010
18BAAC7C19A0FFFE pkg YAVX014 last 19.06.2010
18B6E96C027C2520 pkg YAVX015 last 19.06.2010
18B6E73B08057E2A pkg YAVX016 last 19.06.2010
18B6E7571828FA5A pkg YAVX023 last 11.06.2010
18C04D860B388802 pkg YAVX023 last 19.06.2010
18B7F99F1CC5709B pkg YAVX024 last 19.06.2010
18B731BF128C536A pkg YAVX025 last 19.06.2010
18B6E7801677DA31 pkg YAVX026 last 19.06.2010
18B5F24606C71768 pkg YAVX027 last 19.06.2010
189A45A818FECD6A pkg YAVX029 last 19.06.2010
189A40C10D9B641A pkg YAVX030 last 19.06.2010
18B5F21F1B2349DC pkg YAVX035 last 19.06.2010
18B5F25E1E49D4DB pkg YAVX036 last 19.06.2010
18B5F29304604744 pkg YAVX037 last 19.06.2010
18855B030D81CDA2 pkg YAVX038 last 20.06.2010
18B6ED0E103DEAF4 pkg YAVX040 last 20.06.2010
18B5F27E07F1D9F0 pkg YAVX041 last 19.06.2010
18B8228E0E341BBA pkg YAVX042 last 11.06.2010
18C142F40C4D96B4 pkg YAVX042 last 19.06.2010
18BBC8BE128EEA24 pkg YAVX050 last 08.06.2010
18C142FB11E18FC6 pkg YAVX050 last 19.06.2010
18BC90A90ECE1956 pkg YAVX052 last 19.06.2010
18BBC9BA0B477F6A pkg YAVX053 last 19.06.2010
18BBC64A0F9BC622 pkg YAVX054 last 19.06.2010
18B4E02D1F735664 pkg YAVX056 last 19.06.2010
18B4DC6A1B60FB7E pkg YAVX057 last 19.06.2010
18B4E03D0954B784 pkg YAVX058 last 19.06.2010
18B64178107AC272 pkg YAV0082 last 11.06.2010
18C04D890536A58A pkg YAV0082 last 20.06.2010
18B7F9B2081F1918 pkg YAV0083 last 18.06.2010
18BDCF7015BD45CE pkg YAV0101 last 20.06.2010
18B641B906BF0A8C pkg YAV0112 last 19.06.2010
18B641C21C1E37E1 pkg YAV0115 last 20.06.2010
18B641C40CE5FD4E pkg YAV0116 last 20.06.2010
189636DD04B145E5 pkg YAV0125 last 20.06.2010
18B9488C11A2C516 pkg YAV0127 last 20.06.2010
18B641CF14977470 pkg YAV0128 last 20.06.2010
18B7F9C707A4236A pkg YAV0129 last 18.06.2010
18B877770E8A1ABC pkg YAV0131 last 20.06.2010
18BDCF721F48ABAA pkg YAV0132 last 20.06.2010
18BC9127153E62DC pkg YAV0133 last 20.06.2010
18BDCBEB1FF90D9A pkg YAV0134 last 11.06.2010
18C1687D027ECA28 pkg YAV0134 last 20.06.2010
18B6ECAF1CD1C790 pkg YAV0135 last 18.06.2010
18B641DB111C07D0 pkg YAV0136 last 20.06.2010
18BDFB0509FB46D6 pkg YAV1001 last 04.06.2010
18A824C41D48FAE5 pkg YAV1002 last 17.06.2010
18A824C51B793C8A pkg YAV1003 last 17.06.2010
18B736D6087E55D9 pkg YAV110 last 18.06.2010
18B736D714DFA074 pkg YAV120 last 17.06.2010
18B736D81EE735C2 pkg YAV219 last 17.06.2010
18880AC411890300 pkg YAZCOV last 20.06.2010
18B5F79519A02CFF pkg YAZHIPU last 16.06.2010
18B8221C1A6235BD pkg YAZHISE last 18.06.2010
18872208076B04A4 pkg YAZ0906 last 20.06.2010
18BCDBC21AC9F7FC pkg YAZ0912 last 20.06.2010
1840B7E51A1602E6 pkg YBEBEM last 20.06.2010
187CB79119091F48 pkg YBEFMTO last 20.06.2010
181AA6390B69325A pkg YBEGRUP last 18.06.2010
186F60FA127D99E7 pkg YBEM01 last 20.06.2010
18B66A8C0BED6564 pkg YBEM02 last 18.06.2010
18B75A6419659A70 pkg YBEPLAU last 18.06.2010
186DA45A025B6D8C pkg YBER01 last 20.06.2010
1871E50606EE37E4 pkg YBER02E last 20.06.2010
1871E5011DF90A87 pkg YBER03E last 20.06.2010
1819166819D08457 pkg YBER05E last 04.06.2010
186EC80712FB8B42 pkg YBESEM last 19.06.2010
1816EB10106E96D3 pkg YBETEM last 20.06.2010
189BFE140E0CB6DA pkg YBEUPD last 20.06.2010
186D81040C9056F9 pkg YBE00MC last 20.06.2010
186D811C0E2B46E9 pkg YBE00RA last 20.06.2010
186D81271169CCC1 pkg YBE00RN last 20.06.2010
186D812D114AB40F pkg YBE00RP last 20.06.2010
186D8132074FCEEA pkg YBE00RR last 11.06.2010
186D813D026FA76D pkg YBE00RU last 20.06.2010
186D814C1D02FEED pkg YBE00VA last 20.06.2010
186D81591288320F pkg YBE00VK last 20.06.2010
186F5DF717434135 pkg YBE21 last 20.06.2010
186F5DFB09174CA4 pkg YBE24 last 20.06.2010
186F5DFD0D2CCF19 pkg YBE25 last 20.06.2010
186F5E0017785448 pkg YBE26 last 20.06.2010
186F5E02077E9595 pkg YBE27 last 20.06.2010
187CB6B61AF78D75 pkg YBE7950 last 19.06.2010
1830F9DA0CB9B41F pkg YBF010C last 18.06.2010
18A3620D163EE50E pkg YBGDB2C last 18.06.2010
18B98DA90ACC19A8 pkg YBH5120 last 16.06.2010
18B784E11A12A214 pkg YBH5130 last 16.06.2010
184271B30ABFF31B pkg YBPACF2 last 18.06.2010
18132E331AB120EB pkg YBPADRG last 20.06.2010
18AB191A1C953A53 pkg YBPALTR last 19.06.2010
1823A37D1B579247 pkg YBPALT1 last 20.06.2010
181F3C63024B7ED6 pkg YBPGE03 last 20.06.2010
189A99DB0B3D6A54 pkg YBPGE04 last 20.06.2010
18AB191D0A77A202 pkg YBPMUT last 20.06.2010
181B49961103918D pkg YBPPUR last 20.06.2010
1815A80A1E1395A1 pkg YBPREAD last 20.06.2010
1869E7CC08B495FF pkg YBPSP01 last 20.06.2010
180AA0CB0D691031 pkg YBPSTAM last 19.06.2010
186A7B94097B9A31 pkg YBPSTAM last 20.06.2010
186A7B9608526CE7 pkg YBPSTOE last 20.06.2010
1818F48A1CD4D103 pkg YBPSUCH last 20.06.2010
18426E3314275BA9 pkg YBPSU04 last 20.06.2010
185AC6CD0D387181 pkg YBP01NP last 19.06.2010
180AA1B81CB23213 pkg YBP41GE last 20.06.2010
180AA1BD05F3F484 pkg YBP41UP last 20.06.2010
18B7FED114C14BE4 pkg YBTMB1E last 20.06.2010
187AE2811FA260B6 pkg YBTMOR4 last 20.06.2010
188D693D14385710 pkg YBW0500 last 18.06.2010
1888090A0C6FA2A0 pkg YBW0501 last 17.06.2010
188E848602545EE7 pkg YBW0502 last 18.06.2010
188EA8790D6E5591 pkg YBW0504 last 17.06.2010
18880E3200D0DF45 pkg YBW0505 last 18.06.2010
18B970E716D4F9FC pkg YBXADBR last 20.06.2010
18B98E7204ED0802 pkg YBXASA last 19.06.2010
18B9B2330158C096 pkg YBXASK last 19.06.2010
18B96EEE18859E0E pkg YBXASST last 18.06.2010
18B75E450F3E9D5E pkg YBXEVEN last 18.06.2010
18B98E7518EC2224 pkg YBXIMI last 20.06.2010
18B98E751D79F6FC pkg YBXKAS last 20.06.2010
189B907A0722E6E2 pkg YBXKST last 20.06.2010
189B929C02B0AA06 pkg YBXMSGE last 19.06.2010
189B6756087F3492 pkg YBXRSS last 18.06.2010
18B4B06C187CB724 pkg YCARM20 last 20.06.2010
18A29D921EE0C3F6 pkg YCA0410 last 20.06.2010
18B526E11B4AC8E9 pkg YCDADDR last 20.06.2010
18B526E71EDF2758 pkg YCDA00E last 20.06.2010
183226D30D2E9D1D pkg YCDBUSB last 20.06.2010
18B52BFD0E4B30AE pkg YCDBUW last 20.06.2010
18264804059CEB3B pkg YCDBU01 last 19.06.2010
18B848A816B681A4 pkg YCDB160 last 19.06.2010
18B84997028B9D21 pkg YCDB161 last 19.06.2010
18B27EEF1EC06C16 pkg YCDCCCE last 18.06.2010
187325A31906B42E pkg YCDCCFC last 19.06.2010
18B6E1830CEA7E1F pkg YCDCCG last 20.06.2010
18B66F1D12E2DACC pkg YCDCCRE last 20.06.2010
18B27A4D1309C32E pkg YCDCCUE last 19.06.2010
18B0EE1B1871C9E4 pkg YCDCIFH last 18.06.2010
18B64CED15BF466E pkg YCDCIFX last 20.06.2010
18167330018C76EC pkg YCDCIUW last 20.06.2010
188AE6A70737071B pkg YCDDAP1 last 18.06.2010
18B81D57078B5876 pkg YCDDEPD last 18.06.2010
183226AC12D00754 pkg YCDFLAG last 20.06.2010
189181C2109F436C pkg YCDFLAM last 20.06.2010
189181F81AAFE0EB pkg YCDFLAT last 18.06.2010
187ECBD810CC7EA9 pkg YCDGAGC last 20.06.2010
187B752610B9B753 pkg YCDGANR last 20.06.2010
1881263907CE4E23 pkg YCDGBZ last 20.06.2010
18531D120DB7F1BF pkg YCDGBZ1 last 18.06.2010
18BCFDD51CE96182 pkg YCDGCLD last 20.06.2010
18B3C2FF0E940E24 pkg YCDGDOA last 20.06.2010
1816E1EA012B9044 pkg YCDGEDI last 20.06.2010
18B66F321C2344E9 pkg YCDGEEB last 20.06.2010
181D5633180E009C pkg YCDGETA last 20.06.2010
181D567E148C47CB pkg YCDGETC last 20.06.2010
181D568C03591AC1 pkg YCDGETE last 20.06.2010
181D569A1FDDE4EF pkg YCDGETF last 20.06.2010
181D56A21A0C2C89 pkg YCDGETM last 20.06.2010
182056D51E925952 pkg YCDGETS last 20.06.2010
181E748310E4B86F pkg YCDGETT last 20.06.2010
18A7B15617E94212 pkg YCDGGC last 18.06.2010
18A7B1550D2E7500 pkg YCDGGD last 18.06.2010
1833582D06867522 pkg YCDGGGE last 20.06.2010
18A7B14F0E460BC8 pkg YCDGGU last 18.06.2010
1815CD9714037D9F pkg YCDGT43 last 20.06.2010
188BF93F01B01274 pkg YCDGWOI last 20.06.2010
18B16B4E0F5474DA pkg YCDGWVO last 20.06.2010
18A7A6300CCE8709 pkg YCDGWVR last 20.06.2010
1851CED319F7BB30 pkg YCDGZVA last 20.06.2010
185221BF1F536217 pkg YCDG610 last 20.06.2010
18B875EE1E163E6B pkg YCDG612 last 18.06.2010
185221B916EF399A pkg YCDG615 last 20.06.2010
18A31B200EA2F45C pkg YCDHIST last 20.06.2010
18BB9B951A7A5CB6 pkg YCDJURC last 18.06.2010
18BB9B2116FB5718 pkg YCDJURR last 19.06.2010
18A7B14C082B0F76 pkg YCDKGD last 18.06.2010
1862A20F1E93C09C pkg YCDKGD last 18.06.2010
188B83C316B2D3CB pkg YCDKGGE last 20.06.2010
18A7B14706077D1C pkg YCDKKD last 18.06.2010
187DFADA152EAC5B pkg YCDKKGE last 20.06.2010
18B3E9E709BF0C8A pkg YCDKSFI last 20.06.2010
1878CC6F02A6EA6E pkg YCDKTOI last 20.06.2010
187C98F804871280 pkg YCDKTXT last 20.06.2010
181D510D05933636 pkg YCDLEVE last 20.06.2010
187831BF0027EE25 pkg YCDLG43 last 20.06.2010
1887C2D0069B2882 pkg YCDLOOK last 20.06.2010
18B98B8B05E7F182 pkg YCDMQEU last 18.06.2010
18B2A2F109C58538 pkg YCDMWST last 20.06.2010
187EEB990B1FD39E pkg YCDM612 last 18.06.2010
188C4F6501F7498B pkg YCDM615 last 20.06.2010
188B838C0A825AF8 pkg YCDNIG last 20.06.2010
1887B6FA13CE5BFE pkg YCDNRHE last 18.06.2010
18B52D6805678B89 pkg YCDOEFU last 20.06.2010
18A3391B047050BA pkg YCDOGEE last 20.06.2010
18A7B140006FC76E pkg YCDPGGE last 18.06.2010
18B66F8714F5395C pkg YCDPKGE last 18.06.2010
18A7B13B091E6D88 pkg YCDPKKE last 18.06.2010
1852F227187A47C3 pkg YCDPUT last 20.06.2010
187F1B1D10FC5206 pkg YCDPUT1 last 20.06.2010
18B5D4561AD7F850 pkg YCDPUT2 last 20.06.2010
18A8217A174B23F6 pkg YCDP100 last 18.06.2010
1831F44E1BB67C37 pkg YCDP101 last 18.06.2010
1815DEAD133A5845 pkg YCDQGET last 20.06.2010
186C60270F04EB74 pkg YCDQUEU last 19.06.2010
1817AA7E1BEA80DD pkg YCDR200 last 20.06.2010
181796931F78B5AF pkg YCDSGET last 20.06.2010
18B52E24131F7A1E pkg YCDTABE last 20.06.2010
188058750D1C6437 pkg YCDT01 last 20.06.2010
188058861648ECF6 pkg YCDT02 last 20.06.2010
1880588E1E8B149E pkg YCDT03 last 20.06.2010
1880589310CCAFFC pkg YCDT04 last 20.06.2010
188058A01B628F1E pkg YCDT06 last 20.06.2010
188058A506C513EB pkg YCDT07 last 18.06.2010
18855A6418A7C928 pkg YCDT09 last 18.06.2010
188A43F219159C07 pkg YCDT100 last 20.06.2010
188127500820F461 pkg YCDT106 last 06.06.2010
188059151786A7C2 pkg YCDT109 last 19.06.2010
18855A661136E470 pkg YCDT11 last 20.06.2010
1880592018D50E56 pkg YCDT116 last 20.06.2010
18805925181CB071 pkg YCDT12 last 20.06.2010
1880592B1EA0CF1A pkg YCDT120 last 20.06.2010
18855A681E1404BA pkg YCDT13 last 20.06.2010
18805936033B41EA pkg YCDT130 last 20.06.2010
1880593B169EED9C pkg YCDT14 last 18.06.2010
18805940061BCBB4 pkg YCDT140 last 20.06.2010
18855AB30B6A3BB8 pkg YCDT16 last 18.06.2010
18805B78165D0949 pkg YCDT160 last 20.06.2010
18805B841447F35D pkg YCDT17 last 18.06.2010
188175CD1510300E pkg YCDT170 last 02.06.2010
18805B9004EDD17B pkg YCDT181 last 20.06.2010
18805B99092EDBE0 pkg YCDT182 last 18.06.2010
188127640D12C4A0 pkg YCDT200 last 20.06.2010
1881276604A3376A pkg YCDT210 last 20.06.2010
18855A7010E6E6FE pkg YCDT22 last 18.06.2010
1881276713624886 pkg YCDT23 last 18.06.2010
1881276903E9970A pkg YCDT24 last 20.06.2010
18855A7305031F8A pkg YCDT25 last 20.06.2010
18805C3F167173E0 pkg YCDT26 last 20.06.2010
18805CEB17F47BCA pkg YCDT28 last 18.06.2010
1881276A0FFF6230 pkg YCDT29 last 20.06.2010
18805CFB1850794A pkg YCDT30 last 20.06.2010
18805D040C89739C pkg YCDT31 last 15.06.2010
18805D1410EC621C pkg YCDT34 last 20.06.2010
18805D190FB1E195 pkg YCDT35 last 20.06.2010
18805D240F2D3DC6 pkg YCDT360 last 18.06.2010
18805D2900212DF5 pkg YCDT363 last 18.06.2010
18805D2D0C9C58FD pkg YCDT370 last 20.06.2010
18A4A1FD0A730964 pkg YCDT380 last 18.06.2010
18805D3210CB75E0 pkg YCDT39 last 20.06.2010
18805D4608FEB669 pkg YCDT40 last 20.06.2010
188560130CD93850 pkg YCDT410 last 18.06.2010
18805D6E05527FD9 pkg YCDT43 last 20.06.2010
18812775101098F2 pkg YCDT44 last 20.06.2010
18855A7B1D070896 pkg YCDT45 last 20.06.2010
1881277706876CE7 pkg YCDT46 last 18.06.2010
18805E2A05D4EB03 pkg YCDT600 last 20.06.2010
18805E31083B5571 pkg YCDT601 last 20.06.2010
18805E35039513FA pkg YCDT610 last 20.06.2010
18805E3D04D96886 pkg YCDT612 last 20.06.2010
18805E46109AF364 pkg YCDT613 last 11.06.2010
18805E49046DFEF1 pkg YCDT614 last 11.06.2010
18805E4C0CC93E3E pkg YCDT615 last 20.06.2010
18805E4E0A0D6F79 pkg YCDT616 last 20.06.2010
18805E500F3B5600 pkg YCDT617 last 20.06.2010
18805E540C4263E9 pkg YCDT77 last 20.06.2010
18A7FD661BDADB90 pkg YCDUPHE last 18.06.2010
18AEB53A0629CC52 pkg YCDUPKB last 20.06.2010
18AFD57C10A12050 pkg YCDUPK3 last 18.06.2010
18A65D910559F9A4 pkg YCDUPOE last 20.06.2010
1889247F043DE789 pkg YCDUP43 last 20.06.2010
1898B56F0398E385 pkg YCDUSWI last 18.06.2010
18145D270C1D0D39 pkg YCDUVGE last 20.06.2010
183564CB0F5DF928 pkg YCDU105 last 18.06.2010
189635A40C5DDA81 pkg YCDVGST last 20.06.2010
186C60031DFBD106 pkg YCDVT03 last 18.06.2010
18BFB35805805300 pkg YCDX011 last 20.06.2010
181B49421FC2068A pkg YCDX021 last 19.06.2010
183F23811E274493 pkg YCDX031 last 20.06.2010
18341AC4024DF7D9 pkg YCDX041 last 20.06.2010
1831CB740957B57C pkg YCDX061 last 20.06.2010
18787AD2006707DD pkg YCD002 last 20.06.2010
189A95420BCC245F pkg YCD080A last 17.06.2010
189A9545123B6E0B pkg YCD080B last 20.06.2010
189A95481185880A pkg YCD080C last 18.06.2010
18A7B13501B9DD3A pkg YCD0803 last 18.06.2010
189A9532025F0BA5 pkg YCD081B last 18.06.2010
18A7B12E0E25BD4C pkg YCD082B last 20.06.2010
189A95241E337E0B pkg YCD083B last 20.06.2010
189843A804A3C660 pkg YCD084A last 19.06.2010
189843AF16514C74 pkg YCD084C last 18.06.2010
187E579D1A4C2316 pkg YCD085M last 20.06.2010
18540FDF052C52C0 pkg YCD085R last 20.06.2010
1886C5A116248A85 pkg YCD3SG0 last 18.06.2010
181A36FA0444F11B pkg YCD39AI last 20.06.2010
183226F41902A4F2 pkg YCD39CU last 20.06.2010
187D3E460FFE8A69 pkg YCEHIKU last 19.06.2010
186EE8EC027B0043 pkg YCEKOSA last 19.06.2010
18B823081DCB665F pkg YCEKOSE last 19.06.2010
1852C27E1E10D1C1 pkg YCEVMUP last 18.06.2010
18B9691000EDAB9C pkg YCEWIAP last 19.06.2010
18B7FEA51C8791DE pkg YCE0692 last 18.06.2010
18B7FEA71522FA7A pkg YCE0693 last 18.06.2010
187D3F4816DE6FE0 pkg YCE070G last 01.06.2010
18B7FEA818668DD6 pkg YCE0721 last 17.06.2010
18B7FEAA19465B5C pkg YCE0821 last 18.06.2010
18B7FEBF15569594 pkg YCE0852 last 16.06.2010
18B82888100F6204 pkg YCE0881 last 18.06.2010
18BA5B2603BE62DE pkg YCE0882 last 18.06.2010
18B8288C18CCE2D2 pkg YCE0883 last 18.06.2010
18B7FEC50534A12A pkg YCE0891 last 18.06.2010
18B7FEC514C41D6C pkg YCE0892 last 18.06.2010
18B8288E03EADB80 pkg YCE0901 last 18.06.2010
18B8288F1F472F32 pkg YCE0902 last 18.06.2010
18BB98590BCEFFAC pkg YCE0903 last 18.06.2010
18B7FECA003A5712 pkg YCE0911 last 18.06.2010
18B7FECC0028DE5E pkg YCE0912 last 18.06.2010
18B82895090CA65B pkg YCE0921 last 18.06.2010
18B82896028D25C8 pkg YCE0922 last 18.06.2010
18B828970F3241C8 pkg YCE0923 last 17.06.2010
18B98E2C03677CD1 pkg YCE0924 last 18.06.2010
18B8289A170D4D68 pkg YCE0925 last 18.06.2010
18B7FED31877BBD7 pkg YCE0931 last 18.06.2010
18B7FED41186FA8C pkg YCE0932 last 18.06.2010
18B7FED601F0B1E1 pkg YCE0933 last 18.06.2010
18B7FED81A791F08 pkg YCE0941 last 18.06.2010
18B7FEDA0893EB1A pkg YCE0943 last 18.06.2010
18BFDAC102B8C15A pkg YCE0951 last 18.06.2010
18B8289E1B1B24B6 pkg YCE0952 last 17.06.2010
18BD08FD0771CC50 pkg YCE0953 last 18.06.2010
18B828A30DD4FCB4 pkg YCE0954 last 17.06.2010
18B7FEDF146D3552 pkg YCE0961 last 18.06.2010
18B7FEE404442752 pkg YCE0962 last 17.06.2010
18B7FEE41C26956C pkg YCE0963 last 02.06.2010
18BBA3480B378330 pkg YCE0971 last 18.06.2010
18B828A910F9D416 pkg YCE0972 last 18.06.2010
18B828A91403839A pkg YCE0973 last 18.06.2010
18B7FEEA138A1174 pkg YCE0981 last 18.06.2010
18AB41FA1205179F pkg YCIAA1 last 20.06.2010
188AE10B00E0E3E6 pkg YCIAGRG last 20.06.2010
18B820E21C2059ED pkg YCIC870 last 19.06.2010
18B820E702DEF77A pkg YCID870 last 19.06.2010
1852F1CD101400FA pkg YCIG600 last 18.06.2010
188B8BC31A70C588 pkg YCIG930 last 20.06.2010
188B8B9202F85256 pkg YCIM930 last 20.06.2010
188C73EF15E4B598 pkg YCIP730 last 18.06.2010
18B939361F7864FE pkg YCIP87E last 19.06.2010
18B820DE0DBB5A36 pkg YCIU870 last 18.06.2010
18B64BE713930588 pkg YCIV810 last 20.06.2010
18B871FB0DA0483E pkg YCI002 last 20.06.2010
188813CB0F9DF9EC pkg YCI003A last 20.06.2010
187238E6041DCBBC pkg YCI003B last 20.06.2010
18785E85180CCB8A pkg YCI003C last 20.06.2010
187238EA14EDEA89 pkg YCI003D last 20.06.2010
188813890BC45829 pkg YCI003E last 18.06.2010
1877639E1C27B09F pkg YCI007 last 20.06.2010
18B5248E164F58B1 pkg YCI011 last 20.06.2010
18B4DDE4034967BE pkg YCI017 last 19.06.2010
187C16040321313B pkg YCI017B last 18.06.2010
1884ED28097D6A2B pkg YCI017C last 20.06.2010
186EC3BC084EBA1F pkg YCI0180 last 15.06.2010
18B4FB611376A35E pkg YCI020 last 20.06.2010
18B3EA371FCC4CD6 pkg YCI022 last 20.06.2010
187763C1017EFC45 pkg YCI024 last 02.06.2010
186E49AC01177AA9 pkg YCI060 last 20.06.2010
18A7B11C15C651B6 pkg YCI0640 last 18.06.2010
18B66F56115A5E7C pkg YCI0662 last 20.06.2010
188ADECB0A2F2616 pkg YCI067A last 11.06.2010
188ADEC80376BFAF pkg YCI067B last 18.06.2010
188ADEC615C89AC9 pkg YCI067C last 14.06.2010
188ADECE01059821 pkg YCI0730 last 18.06.2010
18A7B1131B60F5B4 pkg YCI0840 last 18.06.2010
18B848AC0A43BFFD pkg YCI0870 last 20.06.2010
189A950308580914 pkg YCI090G last 20.06.2010
18B16D9A0FFDC00E pkg YCI0930 last 20.06.2010
188ADEB70A922DC5 pkg YCI0940 last 20.06.2010
188ADEB510FE5615 pkg YCI0950 last 18.06.2010
18A7D3C6070724E0 pkg YCKCCCA last 20.06.2010
18A7D3C901066726 pkg YCKCCDA last 20.06.2010
18A7D3CA120B5C5A pkg YCKCCDC last 18.06.2010
18A7D3CC090457D8 pkg YCKCCGA last 20.06.2010
18974D50155C9B23 pkg YCKCCSI last 18.06.2010
18A7D3D10E7D6DC6 pkg YCKCCUA last 20.06.2010
18AAF563049DD158 pkg YCKCSVE last 20.06.2010
187DDE770C3653E1 pkg YCKDBOP last 20.06.2010
188B59B012ACFFF8 pkg YCKDCBA last 18.06.2010
18B61A3815190FAC pkg YCKDCBB last 20.06.2010
18B61A400E77FE44 pkg YCKDCBU last 20.06.2010
186F6A2B13882EC2 pkg YCKDCCW last 20.06.2010
18B61A421A3CCDBA pkg YCKDCEG last 20.06.2010
18B61A2F1A5BB460 pkg YCKDCEI last 20.06.2010
18BB76140A0008F8 pkg YCKDCES last 20.06.2010
189CA2191AAA48E2 pkg YCKDCES last 12.06.2010
188B3438021482A3 pkg YCKDCEU last 20.06.2010
18484814114F41B9 pkg YCKDCOT last 20.06.2010
18B63E9E1639EB48 pkg YCKDCPE last 20.06.2010
18B61A3603D6B94A pkg YCKDCPP last 20.06.2010
187DFFB010D27F13 pkg YCKDCRE last 20.06.2010
187DFFB703DC9BD9 pkg YCKDCSG last 20.06.2010
18B61A5203851CA8 pkg YCKDCSL last 20.06.2010
18B61A5A0A698CC8 pkg YCKDCSM last 20.06.2010
18B643F419C0C5EA pkg YCKDCS0 last 20.06.2010
18B61A6008452BAA pkg YCKDHLI last 18.06.2010
18B61A6515D3B086 pkg YCKDHST last 18.06.2010
187E01761CFBF858 pkg YCKGCCH last 17.06.2010
188B85E404D3EC92 pkg YCKKKGE last 20.06.2010
189BB184029D3893 pkg YCKKKU last 18.06.2010
186F6A0B1428F0FE pkg YCKMCSZ last 20.06.2010
18B61A6E16BC621A pkg YCKSCCA last 20.06.2010
187E017308D61130 pkg YCKSCCC last 01.06.2010
1881221C1F9CE6CC pkg YCKT020 last 20.06.2010
1881222103CEE10D pkg YCKT021 last 20.06.2010
1881222512D2E749 pkg YCKT022 last 20.06.2010
1881222B05915D87 pkg YCKT023 last 20.06.2010
1881222E0CC9A04E pkg YCKT025 last 20.06.2010
18812237026E916F pkg YCKT030 last 20.06.2010
1881223A09631254 pkg YCKT031 last 20.06.2010
1881224314453A28 pkg YCKT032 last 20.06.2010
188122471A85F102 pkg YCKT040 last 18.06.2010
187DDE7C16A3F275 pkg YCKXMLW last 19.06.2010
18B4B78702EAE328 pkg YCK091G last 20.06.2010
1879CB230D7A794C pkg YCO01C1 last 20.06.2010
18BF823F08FD383A pkg YCTCANA last 09.06.2010
18B89E8811BB2E44 pkg YCTK200 last 20.06.2010
189542941BF43F14 pkg YCTMRLS last 20.06.2010
189542850373EF65 pkg YCTM150 last 20.06.2010
1895428815A303E3 pkg YCTM152 last 20.06.2010
189542981FAB2EFF pkg YCTM200 last 20.06.2010
189542930E42E215 pkg YCTM201 last 20.06.2010
18954290061F67D6 pkg YCTM202 last 20.06.2010
1895429B1A879548 pkg YCTM203 last 20.06.2010
18954295071F555F pkg YCTM204 last 20.06.2010
189542A01A943C3A pkg YCTM206 last 20.06.2010
189542830C3CF534 pkg YCTM207 last 20.06.2010
189542821EE6BD74 pkg YCTM208 last 20.06.2010
18B4D4350A62182A pkg YCTM209 last 20.06.2010
18B4D4351492902C pkg YCTM210 last 20.06.2010
189542830C5A370E pkg YCTM213 last 20.06.2010
1895428D16C160D5 pkg YCTM214 last 20.06.2010
189542970545A5E8 pkg YCTM215 last 20.06.2010
18B4D438141083A8 pkg YCTM217 last 20.06.2010
18B4D4350E2198AC pkg YCTM218 last 20.06.2010
18B4D457111C023E pkg YCTM233 last 20.06.2010
189542A110B79BAB pkg YCTM250 last 20.06.2010
18977CA01A5CA73A pkg YCTM251 last 20.06.2010
18977CA71EA05934 pkg YCTM254 last 20.06.2010
18977CAB06209F52 pkg YCTM255 last 18.06.2010
18977CAD180BB9C0 pkg YCTM256 last 20.06.2010
18977CB0186055D5 pkg YCTM257 last 20.06.2010
18977CB20FB0473A pkg YCTM258 last 20.06.2010
18B89E900B31E07A pkg YCTM259 last 20.06.2010
18977CB70EFC6978 pkg YCTM260 last 18.06.2010
18977CBA0A120C18 pkg YCTM261 last 20.06.2010
18977CBC14CBF7AA pkg YCTM262 last 20.06.2010
18977CBF1A9BBF84 pkg YCTM264 last 17.06.2010
18977CC11B53FC43 pkg YCTM265 last 17.06.2010
18977CC40AF88A65 pkg YCTM266 last 20.06.2010
189A4F171D9971A6 pkg YCTM300 last 20.06.2010
18977A571FC209BC pkg YCTM301 last 20.06.2010
18977A4611A90122 pkg YCTM302 last 18.06.2010
18B4D4491575C514 pkg YCTM303 last 20.06.2010
18977A5A11FB6DD1 pkg YCTM304 last 19.06.2010
18977A5D09A269D9 pkg YCTM305 last 19.06.2010
18B4D44D061AF1B4 pkg YCTM306 last 20.06.2010
18977A5F1A7AB8C1 pkg YCTM308 last 18.06.2010
18977A620D26D8EA pkg YCTM309 last 18.06.2010
189542D60A25FC7E pkg YCTM350 last 20.06.2010
189A46C20DAE8402 pkg YCTM351 last 20.06.2010
189A46C40A52C0A4 pkg YCTM353 last 20.06.2010
189A46C80173EC1B pkg YCTM354 last 20.06.2010
189A46CC176B265B pkg YCTM355 last 18.06.2010
189A46CF06521E28 pkg YCTM356 last 20.06.2010
189A46D306505A61 pkg YCTM357 last 18.06.2010
189A46D6142BC090 pkg YCTM358 last 20.06.2010
189A46DC0D9F9912 pkg YCTM359 last 20.06.2010
1895428F05752026 pkg YCTM400 last 20.06.2010
189C084F0EAACE67 pkg YCTSORD last 20.06.2010
1895429E10E54125 pkg YCTSRLS last 20.06.2010
18954288097F6F7C pkg YCTSVPT last 20.06.2010
18B89E8C1F644D7C pkg YCTS100 last 20.06.2010
1895428C05EA4FBE pkg YCTS150 last 20.06.2010
18B4D4500ACF7B02 pkg YCTS200 last 17.06.2010
18C025F2062CBE7A pkg YCTS200 last 20.06.2010
18B4D4340594207C pkg YCTS209 last 20.06.2010
1895427E19DF5411 pkg YCTS213 last 20.06.2010
18B89E890EFEF94A pkg YCTS250 last 20.06.2010
18B89E8A187F5B1F pkg YCTS300 last 20.06.2010
18B4D44D0C0CE1EE pkg YCTS303 last 20.06.2010
18B89E8E0F46429E pkg YCTS350 last 11.06.2010
18C00DB617A48D24 pkg YCTS350 last 20.06.2010
18C14483172FEA70 pkg YCTS400 last 20.06.2010
1895428E15CF0E38 pkg YCTS400 last 17.06.2010
189542860D78FDBE pkg YCTTRA last 20.06.2010
18BC90A307B285B6 pkg YCTURAT last 12.06.2010
18C1458F0396B816 pkg YCTURAT last 19.06.2010
18BAD2B310D81D6E pkg YCWAUZA last 11.06.2010
18C173BC0F65C61A pkg YCWAUZA last 19.06.2010
18BACF4304E3A43A pkg YCWBERD last 20.06.2010
18BAD2EB0D525CDC pkg YCWDB2C last 18.06.2010
18965F711814A170 pkg YCWDOSM last 19.06.2010
18BAD3A71ED57BCC pkg YCWD100 last 18.06.2010
18BAD3AD06994B4E pkg YCWD101 last 18.06.2010
18BAD3B216179AC8 pkg YCWD200 last 19.06.2010
18BAD3C011B3125C pkg YCWD400 last 18.06.2010
18BB44F60218848A pkg YCWG010 last 12.06.2010
18BAD3DA10CCB4EC pkg YCWG700 last 20.06.2010
18BAD3E2031D9D46 pkg YCWG710 last 20.06.2010
18BAD3E90720160E pkg YCWG720 last 20.06.2010
1887B7D9170623E7 pkg YCWG800 last 18.06.2010
18A8E39406BDF3E9 pkg YCWG801 last 20.06.2010
18856AB708B0AF8E pkg YCWG802 last 18.06.2010
18BAD3EF07DBD6F0 pkg YCWI010 last 16.06.2010
188718DF04481CFB pkg YCWI800 last 18.06.2010
188ADCA80A8C8D80 pkg YCWI801 last 18.06.2010
18856ABB172BC5CA pkg YCWI802 last 18.06.2010
18BB45F30A9DC2A4 pkg YCWKS4 last 01.06.2010
187CE80802623F20 pkg YCWONG last 19.06.2010
187CE8090D7CEE5D pkg YCWONGT last 19.06.2010
187CE80B15581174 pkg YCWONU last 19.06.2010
18A487AE17B2CDEB pkg YCWRCW2 last 20.06.2010
18BB494F14F101E0 pkg YCWSLBK last 20.06.2010
18A7A75B1E8FCB40 pkg YCWTCW2 last 20.06.2010
18856AC31CBEC0C5 pkg YCWTVAD last 18.06.2010
18A45F180EDD5068 pkg YCWU800 last 18.06.2010
18A8E3930A1D90AA pkg YCWU801 last 18.06.2010
188C02FA08A58364 pkg YCW20J1 last 18.06.2010
188EA43E1252DC06 pkg YCW20J2 last 18.06.2010
18719A1E01A32AB2 pkg YCYUAVD last 19.06.2010
188C1E8F1E005B31 pkg YCZAPES last 20.06.2010
180B43B81B045008 pkg YCZAURA last 20.06.2010
18264C17108D299A pkg YCZDUDT last 20.06.2010
186098311FFB6B66 pkg YCZD584 last 20.06.2010
18B3BB1C1278D205 pkg YCZE025 last 20.06.2010
18B6ED390207CB74 pkg YCZE100 last 20.06.2010
18531D341D448C04 pkg YCZF960 last 20.06.2010
18B2768912AF2144 pkg YCZGETP last 18.06.2010
18B20D17174E3366 pkg YCZJABW last 19.06.2010
1834511810A71846 pkg YCZJCTF last 20.06.2010
18264C160CC33802 pkg YCZJ251 last 19.06.2010
18B3E2CF0C1B861E pkg YCZJ311 last 20.06.2010
1899879419F94BB9 pkg YCZJ319 last 20.06.2010
18A5994D12B4BC13 pkg YCZJ321 last 20.06.2010
1899A86313A554FA pkg YCZJ323 last 20.06.2010
1851333205E5F450 pkg YCZJ360 last 20.06.2010
180B4A6B12BEFF18 pkg YCZJ365 last 20.06.2010
18B2C9001F1F67B0 pkg YCZJ425 last 20.06.2010
18BE2697072789C6 pkg YCZJ431 last 20.06.2010
189987701D540526 pkg YCZJ431 last 11.06.2010
185133550A23F9C6 pkg YCZJ501 last 20.06.2010
1851339707A1977D pkg YCZJ511 last 20.06.2010
189987860C8709BA pkg YCZJ519 last 20.06.2010
18998580191B4591 pkg YCZJ720 last 19.06.2010
18744954184CCACE pkg YCZJ721 last 15.06.2010
187449870AA02C58 pkg YCZJ723 last 17.06.2010
187449971697270A pkg YCZJ726 last 31.05.2010
187449A113A1EF80 pkg YCZJ727 last 15.06.2010
187624E01956203C pkg YCZJ729 last 15.06.2010
187449C107D31B70 pkg YCZJ730 last 15.06.2010
187449CD00CA75F6 pkg YCZJ731 last 15.06.2010
18531DDB06D7C3E3 pkg YCZJ966 last 18.06.2010
18531DDC0032C543 pkg YCZJ980 last 18.06.2010
18531DDD0F5E2C0C pkg YCZJ981 last 20.06.2010
18B4D58008975584 pkg YCZLOCK last 20.06.2010
188060711536D7F4 pkg YCZMLIM last 18.06.2010
1851AD9D17C1EFF9 pkg YCZM005 last 20.06.2010
18B3BA75030A8BD0 pkg YCZM025 last 20.06.2010
18B619C50172ABAF pkg YCZM062 last 19.06.2010
1851ADA316BC17C5 pkg YCZM095 last 20.06.2010
1851ADA7146F3E45 pkg YCZM098 last 20.06.2010
1851ADAB1DD398EB pkg YCZM100 last 20.06.2010
186D870418338ACE pkg YCZM101 last 20.06.2010
1851ADB41007742B pkg YCZM103 last 20.06.2010
1851ADB808CA88DB pkg YCZM106 last 20.06.2010
1851ADBD036EE055 pkg YCZM107 last 20.06.2010
1863E8D90202DA1B pkg YCZM140 last 08.06.2010
185133B410DFDE1F pkg YCZM190 last 18.06.2010
185133B105106E47 pkg YCZM191 last 18.06.2010
1839ED3D0E838297 pkg YCZM235 last 20.06.2010
1839ED3E1AB837E1 pkg YCZM236 last 19.06.2010
1851333215483E82 pkg YCZM237 last 20.06.2010
1839ED4009B426EA pkg YCZM238 last 20.06.2010
180AD8721E7B9BF3 pkg YCZM239 last 20.06.2010
180AD87D0FF0D21A pkg YCZM240 last 18.06.2010
180AD8A910FBDF6A pkg YCZM241 last 20.06.2010
186D82DE13DBE4D4 pkg YCZM244 last 08.06.2010
18269AC212AF51C1 pkg YCZM250 last 19.06.2010
18269AC504F7E571 pkg YCZM251 last 19.06.2010
18269AC70A20365A pkg YCZM253 last 19.06.2010
18A6DFB509402C04 pkg YCZM300 last 20.06.2010
1899875B1C6A2F4C pkg YCZM311 last 20.06.2010
180AD8BF00DB9396 pkg YCZM312 last 20.06.2010
1851333B14A9B370 pkg YCZM313 last 20.06.2010
1851335B14BDDE22 pkg YCZM315 last 20.06.2010
185133471ED8F53E pkg YCZM316 last 20.06.2010
182EA0C11A0092FA pkg YCZM317 last 20.06.2010
1839ED46141390FE pkg YCZM318 last 20.06.2010
182FBB6C1576B58C pkg YCZM319 last 20.06.2010
180AD8FE02446CD8 pkg YCZM320 last 20.06.2010
185133B917A5ABFD pkg YCZM321 last 20.06.2010
182FDF4111CE64AE pkg YCZM322 last 20.06.2010
1839ED491A954D71 pkg YCZM323 last 20.06.2010
189987D90EE24FB1 pkg YCZM324 last 20.06.2010
180AD9530AF1F993 pkg YCZM325 last 20.06.2010
189987C71152CA76 pkg YCZM327 last 20.06.2010
185133AA1783B35D pkg YCZM329 last 20.06.2010
185133B9144E3AE6 pkg YCZM331 last 20.06.2010
183007751E7E8521 pkg YCZM360 last 20.06.2010
182EA0CB1AC0A9FC pkg YCZM362 last 20.06.2010
18513338070CDF4D pkg YCZM364 last 20.06.2010
185133B51D1C692D pkg YCZM365 last 18.06.2010
185133400069F26F pkg YCZM366 last 20.06.2010
185133430037FF62 pkg YCZM367 last 20.06.2010
182BCD1F18413C36 pkg YCZM368 last 20.06.2010
182FDFF11C042100 pkg YCZM384 last 20.06.2010
1839ED5A1A7412DD pkg YCZM386 last 20.06.2010
1839ED5C0245C064 pkg YCZM387 last 20.06.2010
185133B1023C9711 pkg YCZM388 last 18.06.2010
1839ED5D0C3A2EB6 pkg YCZM389 last 20.06.2010
1839ED5E187B5573 pkg YCZM392 last 20.06.2010
185133611CC9739D pkg YCZM393 last 20.06.2010
185133AE1E1E9AA7 pkg YCZM420 last 20.06.2010
185133BE05B20284 pkg YCZM421 last 20.06.2010
185133BA1A6F01F6 pkg YCZM422 last 20.06.2010
1839ED670DF95116 pkg YCZM423 last 20.06.2010
185133C21C04A92E pkg YCZM424 last 20.06.2010
185133B6074F24D8 pkg YCZM425 last 20.06.2010
18B31A2908DA456C pkg YCZM427 last 20.06.2010
185133C304253049 pkg YCZM428 last 20.06.2010
185133BF0B6FFD91 pkg YCZM429 last 20.06.2010
185133930E88152A pkg YCZM431 last 20.06.2010
1851338F0851D3C8 pkg YCZM432 last 20.06.2010
1851324006A0EFAD pkg YCZM434 last 18.06.2010
18BB6F3B0F09C4FC pkg YCZM435 last 20.06.2010
1851323C08289E62 pkg YCZM436 last 18.06.2010
1851323B0E8B6C86 pkg YCZM437 last 18.06.2010
184814A910EC0379 pkg YCZM440 last 20.06.2010
1899858718CAAF09 pkg YCZM441 last 20.06.2010
186D86E30222E44A pkg YCZM442 last 20.06.2010
186D86ED1EE286A5 pkg YCZM443 last 20.06.2010
1839ED7508D3FABD pkg YCZM501 last 20.06.2010
188AE377173A7BF2 pkg YCZM540 last 01.06.2010
188AE3781B1F90DC pkg YCZM541 last 01.06.2010
188AE37A14483C22 pkg YCZM542 last 01.06.2010
188AE37D0FA1BFEA pkg YCZM543 last 01.06.2010
1851323715288271 pkg YCZM700 last 20.06.2010
18513237118166D3 pkg YCZM701 last 20.06.2010
1851323D1DBBB836 pkg YCZM702 last 18.06.2010
1851323D02708D84 pkg YCZM703 last 18.06.2010
1851323D1864223F pkg YCZM704 last 18.06.2010
1851323C0EA3E434 pkg YCZM705 last 18.06.2010
1851323C09817A35 pkg YCZM706 last 20.06.2010
183A17810CB44B40 pkg YCZM707 last 18.06.2010
183A177F1400AAE1 pkg YCZM708 last 18.06.2010
18531DE40A0E711D pkg YCZM976 last 20.06.2010
18531DE6005E86E9 pkg YCZM980 last 20.06.2010
18531DE614F290F6 pkg YCZM981 last 20.06.2010
18531DE80630B6AC pkg YCZM982 last 18.06.2010
18264C501740AD3D pkg YCZNSEQ last 19.06.2010
18B315A80EF8CA1E pkg YCZONSR last 20.06.2010
18BDF1CC06290DAE pkg YCZPABW last 19.06.2010
189CEDA1091252BA pkg YCZPARM last 18.06.2010
18B5D10E03176F43 pkg YCZPARP last 18.06.2010
18A6AE3B0D8D015E pkg YCZPARS last 20.06.2010
18B09A8007531660 pkg YCZPARS last 20.06.2010
18B20D791EA871CA pkg YCZPCIF last 19.06.2010
18B871A607CD3DF6 pkg YCZPPRD last 19.06.2010
189987B31CEE6E68 pkg YCZPUCA last 18.06.2010
18B2CCB41ED32686 pkg YCZRKRE last 01.06.2010
1851ADC01AC328B5 pkg YCZS025 last 20.06.2010
18B619C819D8BA1E pkg YCZS098 last 18.06.2010
185133260665007F pkg YCZS311 last 20.06.2010
180B4B300BDE8DDE pkg YCZS319 last 19.06.2010
1899858311C2C26D pkg YCZTCDD last 20.06.2010
182A19C20211403E pkg YCZTCOC last 18.06.2010
18BB6D020D366C2E pkg YCZTPRT last 20.06.2010
1899858500ED5093 pkg YCZTRRT last 20.06.2010
1851334B004FEA2D pkg YCZTZTQ last 20.06.2010
1851ADC404898AE1 pkg YCZT005 last 20.06.2010
1850E7C116744560 pkg YCZT017 last 26.05.2010
18B3BA7312F21401 pkg YCZT025 last 20.06.2010
18B619C20DE36C80 pkg YCZT062 last 20.06.2010
1851ADCB06008143 pkg YCZT095 last 20.06.2010
1851ADCE1E3FE07E pkg YCZT098 last 20.06.2010
18B619CC1952A8A0 pkg YCZT099 last 19.06.2010
18B2D0260C53EBBE pkg YCZT100 last 20.06.2010
1851ADD217BDF933 pkg YCZT101 last 20.06.2010
18B61A0D0EBF2D46 pkg YCZT102 last 20.06.2010
1851ADD51DF59A47 pkg YCZT103 last 20.06.2010
18B619D016259320 pkg YCZT105 last 20.06.2010
1851ADD9193BC798 pkg YCZT106 last 20.06.2010
1851ADDD13A10133 pkg YCZT107 last 20.06.2010
1850E7C21CF74A7C pkg YCZT109 last 11.06.2010
1850E6E51EBCC859 pkg YCZT122 last 11.06.2010
1850E7C60EE4A541 pkg YCZT125 last 01.06.2010
1850E7C80FCEFB3C pkg YCZT129 last 08.06.2010
1850E7C9094E7FBC pkg YCZT131 last 01.06.2010
18B275D6046C5DAE pkg YCZT132 last 11.06.2010
185133250C008426 pkg YCZT136 last 11.06.2010
1850E7CD1FE8F23E pkg YCZT137 last 01.06.2010
18B619DD0592D0CD pkg YCZT138 last 20.06.2010
1850E7D002D07A48 pkg YCZT187 last 26.05.2010
1851332701BFA93E pkg YCZT190 last 20.06.2010
1851333716CFF0FF pkg YCZT191 last 18.06.2010
180AC94919990204 pkg YCZT201 last 20.06.2010
185A745B1A43AF55 pkg YCZT235 last 20.06.2010
180AC95A0D2B0FA9 pkg YCZT236 last 20.06.2010
180AC95C035B343D pkg YCZT237 last 20.06.2010
1851332118F74248 pkg YCZT238 last 20.06.2010
180AC96107BE5EF0 pkg YCZT239 last 20.06.2010
180AC96301D43D27 pkg YCZT240 last 18.06.2010
180AC96612DAF17D pkg YCZT241 last 20.06.2010
1824E7EF068C648B pkg YCZT242 last 19.06.2010
18237E0B1CAEF607 pkg YCZT243 last 19.06.2010
1863E94F1E895241 pkg YCZT244 last 08.06.2010
186ECB131C15A010 pkg YCZT245 last 17.06.2010
186ECB3F08105D3E pkg YCZT246 last 17.06.2010
18269AE71EB40EF8 pkg YCZT250 last 20.06.2010
18264C1A0B6D7E0B pkg YCZT251 last 19.06.2010
18264C1B103FAF26 pkg YCZT253 last 20.06.2010
1851332904CC5624 pkg YCZT300 last 20.06.2010
1863E5C60B9CD2F1 pkg YCZT311 last 20.06.2010
180AC96815984415 pkg YCZT312 last 20.06.2010
1812B01D0842284D pkg YCZT313 last 20.06.2010
1812B0211B23508C pkg YCZT315 last 20.06.2010
189985C61AD61B80 pkg YCZT316 last 20.06.2010
1812B02A0D1B36A7 pkg YCZT317 last 20.06.2010
1812B02E0F0180B1 pkg YCZT318 last 20.06.2010
18513231198D3D6E pkg YCZT319 last 20.06.2010
180AC96A15A37962 pkg YCZT320 last 20.06.2010
185133B910CB87AF pkg YCZT321 last 20.06.2010
182F979B1CE4767B pkg YCZT322 last 20.06.2010
189987941839E16E pkg YCZT323 last 20.06.2010
185133A21B0F4261 pkg YCZT324 last 19.06.2010
18513398096CB462 pkg YCZT325 last 20.06.2010
1851339404BB792F pkg YCZT327 last 20.06.2010
185A746F1D02947D pkg YCZT328 last 20.06.2010
185133A10731A914 pkg YCZT331 last 20.06.2010
185CD6811507CFD4 pkg YCZT340 last 20.06.2010
180B63AA1906AE26 pkg YCZT350 last 20.06.2010
185133C7101FF0EC pkg YCZT360 last 20.06.2010
185133991894A01D pkg YCZT362 last 20.06.2010
180AC9871C13596A pkg YCZT364 last 20.06.2010
185133C3181BFF4A pkg YCZT365 last 20.06.2010
180AC99102D4CC64 pkg YCZT366 last 19.06.2010
180AC9921DD24BB5 pkg YCZT367 last 20.06.2010
1830B401101748FC pkg YCZT368 last 20.06.2010
18513363089AF438 pkg YCZT370 last 19.06.2010
180AC9981900C34E pkg YCZT373 last 20.06.2010
180AC99A0E65549C pkg YCZT376 last 20.06.2010
1851332804F0E0D4 pkg YCZT377 last 20.06.2010
180AC99E152426A2 pkg YCZT384 last 20.06.2010
1839F6531CB5D00D pkg YCZT386 last 20.06.2010
180AC9A31CC28824 pkg YCZT387 last 20.06.2010
180AC9A5153C2C95 pkg YCZT388 last 19.06.2010
189D94770ED4F2E2 pkg YCZT389 last 20.06.2010
185133A712BBCAFA pkg YCZT392 last 20.06.2010
1851332D12131EF6 pkg YCZT393 last 20.06.2010
1851339C15F91105 pkg YCZT396 last 20.06.2010
180AC9B40992855C pkg YCZT398 last 20.06.2010
1899876918A3C1C0 pkg YCZT399 last 20.06.2010
180AC9B606CE6379 pkg YCZT420 last 20.06.2010
185133BF1F9B27C5 pkg YCZT421 last 20.06.2010
180AC9BC0F408C33 pkg YCZT422 last 20.06.2010
180AC9BE12441A24 pkg YCZT423 last 20.06.2010
185133C012179721 pkg YCZT424 last 20.06.2010
185133CC069B4E60 pkg YCZT425 last 20.06.2010
180AC9C204A76D57 pkg YCZT427 last 20.06.2010
180AC9C307B130B8 pkg YCZT428 last 20.06.2010
180AC9C50D15C181 pkg YCZT429 last 20.06.2010
18B0998C122D2B3A pkg YCZT431 last 20.06.2010
1851339813751463 pkg YCZT432 last 20.06.2010
1812F3300B6504C2 pkg YCZT434 last 18.06.2010
18BB6F3C1D3B56D0 pkg YCZT435 last 20.06.2010
180C6654115655D4 pkg YCZT436 last 18.06.2010
180C66551E0E0BD5 pkg YCZT437 last 18.06.2010
18A3651E1B908446 pkg YCZT440 last 20.06.2010
185D03850EFADCD1 pkg YCZT441 last 20.06.2010
180A5855120ABDD1 pkg YCZT442 last 20.06.2010
180A588015A7BC93 pkg YCZT443 last 20.06.2010
185133C80C34F96F pkg YCZT501 last 20.06.2010
1823A8BA1DA2E775 pkg YCZT519 last 18.06.2010
185132410BD695FD pkg YCZT700 last 20.06.2010
186A548419DCB34D pkg YCZT702 last 20.06.2010
185132400948622E pkg YCZT703 last 20.06.2010
185132400FAC8B7D pkg YCZT704 last 20.06.2010
18513244182DC62F pkg YCZT705 last 20.06.2010
185132440AC9D561 pkg YCZT706 last 20.06.2010
1810C1EF0CA7DE01 pkg YCZT707 last 20.06.2010
1810C1F4047CB36C pkg YCZT708 last 20.06.2010
1850E7D6024AF1BC pkg YCZT720 last 01.06.2010
1899857E0D51A078 pkg YCZT721 last 20.06.2010
181B46CE10A1E7DC pkg YCZT724 last 01.06.2010
181B46E50C400A42 pkg YCZT726 last 01.06.2010
189985870DDF8F2A pkg YCZT727 last 20.06.2010
180A789E161AEF3B pkg YCZT729 last 20.06.2010
180A592F1A8CB25D pkg YCZT730 last 20.06.2010
1851323A03D87249 pkg YCZT731 last 20.06.2010
187353D602F4127A pkg YCZT732 last 17.06.2010
180AC9D3044500E5 pkg YCZT905 last 20.06.2010
1851336912400C91 pkg YCZT915 last 19.06.2010
180AC9D81DD44F3F pkg YCZT957 last 18.06.2010
180AC9DA162AF7AF pkg YCZT958 last 18.06.2010
18531DF4064783D8 pkg YCZT960 last 20.06.2010
18531DF7090D8396 pkg YCZT963 last 20.06.2010
18531E0412D8B085 pkg YCZT964 last 18.06.2010
18531DFE0709672C pkg YCZT965 last 20.06.2010
18531E04109D1816 pkg YCZT966 last 20.06.2010
18531E040E1F287B pkg YCZT967 last 19.06.2010
18531DFF1BD04A48 pkg YCZT969 last 20.06.2010
18531E0013961341 pkg YCZT970 last 20.06.2010
18531E031F83EFF0 pkg YCZT971 last 20.06.2010
18531E04185AF59E pkg YCZT976 last 20.06.2010
189C5BB01345E9E1 pkg YCZUCOP last 18.06.2010
1866E01F09D3769C pkg YCZUCRC last 19.06.2010
182A412A16A2C82C pkg YCZUC79 last 18.06.2010
186D82341A3E907A pkg YCZUKDK last 02.06.2010
1850E7D80CA8E8E4 pkg YCZUPKM last 08.06.2010
18B855841DBE1158 pkg YCZUSDE last 19.06.2010
18B89E9009B8D8D9 pkg YCZUWIN last 11.06.2010
18B6E17A0B3DEEF7 pkg YCZU384 last 18.06.2010
18B82AD308F04976 pkg YCZU694 last 19.06.2010
188B092C0CFDB74C pkg YCZVERP last 19.06.2010
18B61CD514D30161 pkg YCZVVM last 18.06.2010
18B3189D1A423F57 pkg YCZWCL3 last 20.06.2010
18615FED1F533EC3 pkg YDBC101 last 19.06.2010
18615FF1040B7965 pkg YDBC102 last 20.06.2010
18615FF9095AC741 pkg YDBC104 last 20.06.2010
18636B4605198DA2 pkg YDBC201 last 20.06.2010
18636B4911FC6287 pkg YDBC203 last 20.06.2010
18636B4C1D16B512 pkg YDBC204 last 20.06.2010
18A6E2630C539450 pkg YDECIF last 18.06.2010
1897988808C79BA7 pkg YDECLS2 last 19.06.2010
18B7625A020AC7FA pkg YDEF102 last 19.06.2010
189A9F8B03311650 pkg YDELIQ2 last 19.06.2010
189A9F8E04A62A94 pkg YDELSTO last 18.06.2010
189A9F9002681D51 pkg YDEOUG last 19.06.2010
18280A5E0EAB0E7C pkg YDESTEU last 20.06.2010
188AE7B106F4D14B pkg YDESWB2 last 18.06.2010
1844CAED0E9BCC75 pkg YDETEXT last 18.06.2010
18A9AC530ECDC7FF pkg YDE0020 last 19.06.2010
18A9AC3C0769CC5C pkg YDE0021 last 19.06.2010
187DAF66065BC6EC pkg YDE5003 last 18.06.2010
189A9F930C302622 pkg YDE5004 last 18.06.2010
1874E21E18A922BC pkg YDGAP last 18.06.2010
18B82033142F76F8 pkg YDGBEL last 11.06.2010
18C1488B0AE9F8AE pkg YDGBEL last 18.06.2010
18B96E3A15DF4DE6 pkg YDGBEST last 19.06.2010
18BACD4C17188E34 pkg YDGCMA last 19.06.2010
187004B90B8D233E pkg YDGDB61 last 20.06.2010
1871E6960BCD0466 pkg YDGDB93 last 19.06.2010
18B6E04307BD5486 pkg YDGDEPN last 19.06.2010
18B6E89215D07220 pkg YDGFON last 20.06.2010
18B6E8930786AD9B pkg YDGGC last 18.06.2010
18B6E04508AD2698 pkg YDGKSLD last 19.06.2010
18BA57FD0797C228 pkg YDGMAN last 19.06.2010
188B57E40915D0B8 pkg YDGPE last 19.06.2010
1893AD3E19F0C8A7 pkg YDGPER last 19.06.2010
18B82A1804DCBFDC pkg YDGPRI last 18.06.2010
18B82A33055F1AC2 pkg YDGSS last 20.06.2010
18B82A3A05B21E6E pkg YDGST last 20.06.2010
18B82A431F43B10B pkg YDGSTI last 19.06.2010
18B82A5415525354 pkg YDGTAR last 20.06.2010
18B82A5C1F8D5A4F pkg YDGTAX last 19.06.2010
18B6E0430FD07104 pkg YDGTA13 last 15.06.2010
187CC4900DC5A45F pkg YDGTEX last 19.06.2010
18B82A6900E2167A pkg YDGVST last 18.06.2010
18B7603E019204D6 pkg YDGVVM last 20.06.2010
18B82A7006527186 pkg YDGVWG last 20.06.2010
1885883C105A4D05 pkg YDG001 last 19.06.2010
1885883E18F1204E pkg YDG002 last 19.06.2010
186F860A0C3756E5 pkg YDG061 last 19.06.2010
1871E6E50DDFF006 pkg YDG114 last 19.06.2010
18B1B6A016574F68 pkg YDG121 last 19.06.2010
1885884D15F757F5 pkg YDG122 last 19.06.2010
1885691916DE3ABE pkg YDG123 last 19.06.2010
1885691F1233D038 pkg YDG124 last 19.06.2010
1885692612720FE4 pkg YDG125 last 19.06.2010
1885692D1F1EF83C pkg YDG126 last 19.06.2010
18B82A760192B709 pkg YDG127 last 19.06.2010
18B829D009D7801A pkg YDG127K last 31.05.2010
18BA876411E4D8C8 pkg YDG128 last 19.06.2010
18B829C807DCA446 pkg YDG128K last 01.06.2010
18AE86891E283235 pkg YDG129 last 19.06.2010
189AA28815615D04 pkg YDG129K last 01.06.2010
18AE869006642C73 pkg YDG130 last 19.06.2010
189AA28F1DA23940 pkg YDG130K last 01.06.2010
1885697C0A26F30E pkg YDG200 last 19.06.2010
188588591A1E44EE pkg YDG201 last 19.06.2010
1885698416654A23 pkg YDG202 last 19.06.2010
1885885D19D49D15 pkg YDG203 last 19.06.2010
1885698F0437F73F pkg YDG204 last 19.06.2010
18C211DC1E14BD7A pkg YDG215 last 19.06.2010
189DE4A8127045D7 pkg YDG215 last 11.06.2010
186F86B4142FD4D8 pkg YDG250 last 19.06.2010
1885887512811B1D pkg YDG251 last 19.06.2010
1885699506BC1140 pkg YDG301 last 18.06.2010
1885699B048F9D22 pkg YDG302 last 18.06.2010
18AB45AB0C294BF9 pkg YDG303 last 19.06.2010
18B1BC730646ABF3 pkg YDG314 last 19.06.2010
186F872614E78ACB pkg YDG320 last 20.06.2010
1871E6E11350D20D pkg YDG370 last 19.06.2010
1871E6DC00B14DD6 pkg YDG420 last 20.06.2010
18B829BE18F87980 pkg YDG45 last 18.06.2010
1871E6D41E6EA467 pkg YDG470 last 19.06.2010
186F8772111E4091 pkg YDG500 last 18.06.2010
186F87841C53E83B pkg YDG510 last 19.06.2010
1871E6D71AC5AB2C pkg YDG570 last 18.06.2010
1871E6DF09E6E9AC pkg YDG620 last 18.06.2010
186F87BB07CCDFDE pkg YDG670 last 20.06.2010
188588720354BAF8 pkg YDG700 last 19.06.2010
186F8CCD1E475532 pkg YDG9WN last 20.06.2010
186F8CDE19ADBE7F pkg YDG920 last 20.06.2010
186F8CF1065CDF7F pkg YDG930 last 19.06.2010
18B70D951E887D06 pkg YDG940 last 18.06.2010
188B3634181D6970 pkg YDG955 last 20.06.2010
186F8D320FEFEC68 pkg YDG970 last 20.06.2010
186F8D431C0D1B24 pkg YDG980 last 20.06.2010
1879F167188F1FC9 pkg YDG990 last 19.06.2010
187DFDCB0A829F6C pkg YDIBEG1 last 17.06.2010
189B64360676337E pkg YDICAL1 last 18.06.2010
186F5F5015498568 pkg YDIEURE last 20.06.2010
18B662E00A683E30 pkg YDIFXFM last 19.06.2010
18B64771012D2AFE pkg YDIFXFO last 19.06.2010
187DFE461E77E100 pkg YDIMAC1 last 17.06.2010
187DFEAE1943F77D pkg YDIMAG1 last 17.06.2010
1899546C09435884 pkg YDIODLE last 20.06.2010
18BA63D708A40084 pkg YDITGAK last 20.06.2010
18A70867181B784A pkg YDITKON last 20.06.2010
181A04DB1A546484 pkg YDITMAN last 20.06.2010
18198C571877B908 pkg YDIT001 last 20.06.2010
18198C5E01009DFC pkg YDIT002 last 20.06.2010
18198C621573D3AA pkg YDIT003 last 20.06.2010
18198C6817C8FE50 pkg YDIT004 last 20.06.2010
18198C6E006095C5 pkg YDIT006 last 19.06.2010
186EF3AB0BDCC13C pkg YDIT009 last 17.06.2010
181A02AC1797316C pkg YDIT027 last 18.06.2010
187E05670E191D6A pkg YDIT028 last 31.05.2010
181A02B118F46B0F pkg YDIT029 last 20.06.2010
18B77FAE07AED705 pkg YDIT20P last 20.06.2010
18B77FB00E432129 pkg YDIT20V last 20.06.2010
1819B565082D4022 pkg YDIT24P last 20.06.2010
18ACF94E1D586156 pkg YDIT24V last 20.06.2010
186E7D7E16038D26 pkg YDIU017 last 18.06.2010
186E7D890AFCA6AE pkg YDIU018 last 18.06.2010
187E056809E37438 pkg YDIU024 last 31.05.2010
18BA8376002D0548 pkg YDIXIOE last 20.06.2010
187BFB2907EB5671 pkg YDI4021 last 20.06.2010
186EF45811B4C35A pkg YDI4214 last 20.06.2010
18BAAF270D5C79F8 pkg YDI5918 last 20.06.2010
184590A508DAB963 pkg YDMC020 last 18.06.2010
1832283C08DD7973 pkg YDMD020 last 18.06.2010
18B6260404CBA2E2 pkg YDMGETB last 19.06.2010
18B4BAEC12FFEA8E pkg YDMGETD last 18.06.2010
18B4BAF101D8F06A pkg YDMGETP last 20.06.2010
1832284A063B04E3 pkg YDMG020 last 18.06.2010
18B4BAF30D83F792 pkg YDMOEFU last 20.06.2010
18B649300A185D54 pkg YDMP100 last 18.06.2010
18B4BAF6072E1032 pkg YDMP300 last 18.06.2010
18B4BAFA14D6D920 pkg YDMU300 last 18.06.2010
186DAD3918C49322 pkg YDMU900 last 18.06.2010
187D172215AC7FED pkg YDM001E last 20.06.2010
18BFDA851AA9E9DC pkg YDM0014 last 18.06.2010
187531EA043A4E84 pkg YDM01GE last 20.06.2010
189BB46012E2C680 pkg YDM0930 last 18.06.2010
187D0EAB00D4B51F pkg YDNUMSA last 19.06.2010
18B5F6651A362CD7 pkg YDPANF last 11.06.2010
18C023E70A67C49E pkg YDPANF last 19.06.2010
18B61AF505193226 pkg YDPERF last 11.06.2010
18C023E6100E6AE4 pkg YDPERF last 18.06.2010
18B5F6680EF49497 pkg YDPEXP last 11.06.2010
18C023E503829FF4 pkg YDPEXP last 19.06.2010
18B75690139BBB54 pkg YDPNET last 11.06.2010
18C023E406985F1A pkg YDPNET last 19.06.2010
18A9FEC015AE47A9 pkg YDPPMSG last 20.06.2010
18B5F64D0DAD55C8 pkg YDPPOSE last 11.06.2010
18C023D5190A90C2 pkg YDPPOSE last 19.06.2010
18B5F64F0F23312D pkg YDPPOSS last 11.06.2010
18C023E21FBC6E38 pkg YDPPOSS last 19.06.2010
18B5F65F136B4251 pkg YDPPOS2 last 11.06.2010
18C023E10FC542DA pkg YDPPOS2 last 19.06.2010
18B5F6600D682EE9 pkg YDPPOS6 last 08.06.2010
18C023E0102B2FE2 pkg YDPPOS6 last 15.06.2010
18B5F66109878FE9 pkg YDPSTEU last 20.06.2010
18AC0EED1B4B763E pkg YDPT080 last 20.06.2010
18B1E6DA0CED9FDE pkg YDPT085 last 20.06.2010
18AC0FB205B21983 pkg YDPT090 last 19.06.2010
18AB42A3159BEA06 pkg YDP6022 last 11.06.2010
18C32EE70ABEDE8A pkg YDP6022 last 20.06.2010
18B3218B01624A06 pkg YDP6042 last 12.06.2010
18C32EE71FD5A3A4 pkg YDP6042 last 20.06.2010
18AB43101E72F2AE pkg YDP6062 last 18.06.2010
18C32EE80DB2E4C2 pkg YDP6102 last 20.06.2010
18B6182A18993F74 pkg YDT100C last 02.06.2010
18B6182D17FC10B0 pkg YDT100G last 07.06.2010
18B6182E1D56BD6C pkg YDT100S last 18.06.2010
18B6182F120BC209 pkg YDT101A last 08.06.2010
18B6183201D4C843 pkg YDT101G last 17.06.2010
18B6183313C24532 pkg YDT101J last 17.06.2010
18B6183518104850 pkg YDT101M last 16.06.2010
18B618371B3041AD pkg YDT102P last 18.06.2010
187A59990359B3D1 pkg YDT102T last 18.06.2010
18B618380B354B98 pkg YDT102X last 04.06.2010
187A599E04B531BD pkg YDT103A last 07.06.2010
189865631678680D pkg YDWDAUF last 18.06.2010
188C4F330A863CAB pkg YDWDPOS last 18.06.2010
188C437D18319198 pkg YDWGBE last 19.06.2010
18A7808E01CAA3E6 pkg YDWGBES last 18.06.2010
1898657117E70E40 pkg YDWGBG last 20.06.2010
18C0030001FA99D0 pkg YDWGBS last 19.06.2010
188B174F0537AFE8 pkg YDWGBS last 11.06.2010
1898657C1BD39052 pkg YDWGBVR last 19.06.2010
18AB195F150F732C pkg YDWGER last 19.06.2010
18C140DA0D0469F8 pkg YDWGLA last 18.06.2010
188C4F3F0C4D0500 pkg YDWGLA last 11.06.2010
189865840EB81881 pkg YDWGLB last 19.06.2010
188C4F450BDF0C77 pkg YDWGNPS last 18.06.2010
18625E3606EC653D pkg YDWG100 last 19.06.2010
18625E7B11684F3D pkg YDWG101 last 19.06.2010
18625E7E1AAECD36 pkg YDWG102 last 19.06.2010
18A9DC0F099CAA6E pkg YDWG103 last 19.06.2010
189BB2081F61D901 pkg YDWG109 last 19.06.2010
18625E4E04B972F2 pkg YDWG111 last 19.06.2010
18625E510AAB7871 pkg YDWG112 last 19.06.2010
1865A03C1940ED53 pkg YDWG120 last 18.06.2010
18625E900818977F pkg YDWG121 last 19.06.2010
18625E9316DD529C pkg YDWG122 last 19.06.2010
18625E97095B2420 pkg YDWG123 last 19.06.2010
18B939CA0BB99C66 pkg YDWG130 last 19.06.2010
186284D61D481550 pkg YDWG200 last 19.06.2010
18625EA010A96ECC pkg YDWG300 last 20.06.2010
1898658F1BCEFBE9 pkg YDWIAUF last 19.06.2010
186EF3060977545E pkg YDWIBE last 18.06.2010
188C2C1A09CD8E9E pkg YDWIPOS last 19.06.2010
18625EA715C9E50A pkg YDWI100 last 18.06.2010
18625EAA18D97017 pkg YDWI101 last 19.06.2010
18625EAE04CE1758 pkg YDWI102 last 19.06.2010
188C289B1ACEB2A0 pkg YDWI103 last 18.06.2010
189BB2091ED6D8FE pkg YDWI109 last 19.06.2010
18625EB71293509D pkg YDWI110 last 18.06.2010
18625EBA04DD4E34 pkg YDWI111 last 18.06.2010
18625EC00D8AF597 pkg YDWI112 last 18.06.2010
18625EC80F2FE4B8 pkg YDWI120 last 18.06.2010
18625ECC0B8D1E9E pkg YDWI121 last 18.06.2010
18625ECF05AC3EE3 pkg YDWI122 last 19.06.2010
18625ED218ED8EEF pkg YDWI123 last 19.06.2010
188DBCD8168330BE pkg YDWI130 last 18.06.2010
18625EDD01BE556C pkg YDWI300 last 18.06.2010
1899CE5D0964F4E6 pkg YDWONDO last 17.06.2010
189865940B176F6C pkg YDWUAS last 19.06.2010
1898659D1A3CFE80 pkg YDWUAUF last 19.06.2010
188C2C0F0F885CB4 pkg YDWUBAN last 19.06.2010
186EF30D0C99333E pkg YDWUBE last 09.06.2010
189865A50541D755 pkg YDWUBR last 19.06.2010
188C4F4B04D0A14F pkg YDWULI last 19.06.2010
188C4F4C0ED1DD5A pkg YDWUPOS last 19.06.2010
188C43F10C4EBEDB pkg YDWUSEL last 19.06.2010
189865B1127DE153 pkg YDWUSWR last 19.06.2010
188C2CDC000DEE14 pkg YDWUVTS last 19.06.2010
18625EDF1DEF91A6 pkg YDWU100 last 18.06.2010
18625EE3108CD4E9 pkg YDWU101 last 19.06.2010
18625EE61A420CEF pkg YDWU102 last 19.06.2010
188C4F5019E9636E pkg YDWU103 last 18.06.2010
189BB20F04A713EC pkg YDWU109 last 19.06.2010
18625EF208549DFE pkg YDWU111 last 18.06.2010
18625EF61A58D9DE pkg YDWU112 last 18.06.2010
18625EFC1D9994B8 pkg YDWU121 last 18.06.2010
18B0C464122C3A65 pkg YDWU123 last 19.06.2010
188478691F6C813C pkg YDWU130 last 18.06.2010
186E6E891A2F6F93 pkg YEBBEN last 19.06.2010
18297687006A501F pkg YECBKY last 20.06.2010
18333413071C343A pkg YECBSL last 20.06.2010
189C7E70091D8F1D pkg YECCHRG last 20.06.2010
189C7E720FA601A8 pkg YECCRAC last 20.06.2010
1852F4BE0C27B2C4 pkg YECCRAT last 20.06.2010
189C7E7514C5D55E pkg YECCRFL last 20.06.2010
1833362A0F456CD5 pkg YECDCKY last 18.06.2010
1833364A158CC489 pkg YECDTKY last 15.06.2010
18B826770025487A pkg YECGT last 20.06.2010
18B826771168B292 pkg YECGTW last 18.06.2010
18B43BDE015DD21E pkg YECPARS last 18.06.2010
183400B608568988 pkg YECSADB last 20.06.2010
1833533C0F99BE20 pkg YECSAPM last 20.06.2010
1870820514A0B127 pkg YECSAXA last 20.06.2010
1852F4FA038303C5 pkg YECSAXC last 18.06.2010
1852F4F40691D562 pkg YECSAXL last 18.06.2010
1852F4EE011EF9D7 pkg YECSAXR last 20.06.2010
1852F4E9177F1401 pkg YECSAXS last 18.06.2010
18B2A6751F7F41F8 pkg YEDF10 last 18.06.2010
18B71678099CFA7C pkg YEDGET last 18.06.2010
18B4D77117EC229C pkg YEDGOR last 18.06.2010
187D3A7712DC74CE pkg YEDOUG last 18.06.2010
18BD01310732F700 pkg YEDPRNT last 18.06.2010
18BDF8F6106CFB1A pkg YEDRE2P last 18.06.2010
18B4D9610C13F264 pkg YEDROR last 18.06.2010
187D3A8113F4E9CE pkg YEDST2P last 18.06.2010
18604C250AACC8D6 pkg YEDTXTB last 18.06.2010
18BFDD491F2D3686 pkg YEDUP2P last 11.06.2010
18C1125E0B215C7A pkg YEDUP2P last 18.06.2010
18B4A9A80C150E44 pkg YED5203 last 18.06.2010
1861144F11C561C4 pkg YED5204 last 18.06.2010
186E769B0E7586A8 pkg YEFGAAP last 18.06.2010
186EA367095AA6D4 pkg YEFLOGM last 01.06.2010
186283F615AD083F pkg YEF300 last 20.06.2010
1871E3441536ECA4 pkg YEF301 last 18.06.2010
186283F714F3301B pkg YEF301A last 17.06.2010
186283F71E4C85D4 pkg YEF302 last 18.06.2010
186283F91225CF3F pkg YEF302A last 18.06.2010
186283FC1AA01F25 pkg YEF303 last 18.06.2010
186283FC17097CB1 pkg YEF303A last 12.06.2010
186283FB1EA43083 pkg YEF304 last 12.06.2010
186283FE059C7EA1 pkg YEF304A last 01.06.2010
186283FE11289475 pkg YEF305 last 18.06.2010
186284020E520862 pkg YEF306 last 18.06.2010
186284020FF05B8D pkg YEF307 last 09.06.2010
186284011A5CD254 pkg YEF307A last 08.06.2010
18628403051BB324 pkg YEF309 last 01.06.2010
186283F51E6E0406 pkg YEF310 last 01.06.2010
188BFD6F1F33CBEA pkg YEGEKGT last 20.06.2010
182C93040B064724 pkg YEGEKUP last 19.06.2010
18B647501FF0DAF6 pkg YEGMI2D last 16.06.2010
182B3283174566FB pkg YEQBKY last 18.06.2010
186D54DB0BC96840 pkg YEQBRGP last 18.06.2010
185E114A1D7B6660 pkg YEQISRK last 18.06.2010
185319370EFD0DFD pkg YEQJ100 last 18.06.2010
185132D307C30B00 pkg YEQJ901 last 17.06.2010
185A747E0D906937 pkg YEQKDGP last 18.06.2010
188AE775155027E5 pkg YEQKKAT last 20.06.2010
188AE7770809EDA1 pkg YEQLIMB last 20.06.2010
185319471115C126 pkg YEQM107 last 14.06.2010
185319471A540C0A pkg YEQM190 last 14.06.2010
1853194A118BAF92 pkg YEQM300 last 18.06.2010
1853194B0EC50A3A pkg YEQM301 last 18.06.2010
1853194C10D6D7D4 pkg YEQM302 last 18.06.2010
1853194E00589B21 pkg YEQM303 last 18.06.2010
1853194F1435AF72 pkg YEQM304 last 18.06.2010
1853195206CA0DDB pkg YEQM305 last 18.06.2010
1853195504029129 pkg YEQM306 last 18.06.2010
185132D41D197948 pkg YEQM900 last 18.06.2010
185132D60B6B3E04 pkg YEQM901 last 18.06.2010
185132D701E7A54F pkg YEQM902 last 18.06.2010
185132D606200A1B pkg YEQM903 last 18.06.2010
185132D71C914F10 pkg YEQM910 last 18.06.2010
184391740EE7A01B pkg YEQNK02 last 07.06.2010
1843916D1D1C44C0 pkg YEQNK03 last 07.06.2010
185319670579F7BC pkg YEQT030 last 18.06.2010
185319651CE2DD36 pkg YEQT100 last 18.06.2010
1853196C005EB032 pkg YEQT101 last 18.06.2010
1853196E1E573036 pkg YEQT102 last 18.06.2010
1853196F12F0F9E4 pkg YEQT103 last 18.06.2010
185319701CE30586 pkg YEQT104 last 18.06.2010
185319711BEC3A6A pkg YEQT105 last 18.06.2010
18531973008A6B08 pkg YEQT106 last 18.06.2010
185319761C50E51B pkg YEQT107 last 18.06.2010
185319750D82E40E pkg YEQT108 last 18.06.2010
185319760C8DDC19 pkg YEQT109 last 18.06.2010
185319771972C549 pkg YEQT110 last 18.06.2010
185319790C3F20DE pkg YEQT111 last 18.06.2010
1853197B1D0F0AD8 pkg YEQT200 last 20.06.2010
1853197C1D6C1A6E pkg YEQT202 last 20.06.2010
1853197E0260FCB8 pkg YEQT203 last 18.06.2010
1853197F12C55A68 pkg YEQT204 last 18.06.2010
1853198012AF200C pkg YEQT205 last 18.06.2010
18531981191646B9 pkg YEQT206 last 20.06.2010
1853198303A86673 pkg YEQT207 last 18.06.2010
185319841F72C5FE pkg YEQT208 last 18.06.2010
1853198608E64074 pkg YEQT300 last 18.06.2010
18531988096AEA74 pkg YEQT301 last 18.06.2010
185319891B013B28 pkg YEQT302 last 18.06.2010
1853198B13D01C3B pkg YEQT303 last 18.06.2010
1853198C19807ADE pkg YEQT304 last 18.06.2010
1853198E0F1796DB pkg YEQT305 last 18.06.2010
1853199305DBF28E pkg YEQT306 last 18.06.2010
185132D91C5B6B8E pkg YEQT900 last 20.06.2010
185132DB06A25759 pkg YEQT903 last 17.06.2010
185132DB1A7D2D3D pkg YEQT910 last 17.06.2010
185132DA1C43EC05 pkg YEQT990 last 20.06.2010
185132DC127DA3E8 pkg YEQT991 last 15.06.2010
185132600826FF29 pkg YEQUEER last 16.06.2010
18BA5C9F0C25E3E2 pkg YERBER last 19.06.2010
188D86D71777F0CE pkg YERCCUR last 18.06.2010
188D86D911BD6255 pkg YERCDEL last 18.06.2010
188D86DA12B56AFF pkg YERCGET last 18.06.2010
188D86DB11BBCEBD pkg YERCINS last 18.06.2010
188D86DC0F4C9C36 pkg YERCUPD last 18.06.2010
18B7374F079B8248 pkg YERDCUR last 19.06.2010
18B737430603BB7E pkg YERDDEL last 18.06.2010
18B737EC12820E7C pkg YERDGET last 19.06.2010
18BA5C981EFCE5FC pkg YERDINS last 18.06.2010
18B73743063646ED pkg YERDUPD last 19.06.2010
18B7377D1FA8DC19 pkg YERPRI last 17.06.2010
188D86E108BDA492 pkg YERSEAM last 18.06.2010
188D86E2109E0AF8 pkg YERSFUN last 18.06.2010
18AC3C200932FFFE pkg YERSGFE last 31.05.2010
186E9A74131E1C42 pkg YERSGFU last 31.05.2010
186E9A7D18BEA4B5 pkg YERSGNA last 31.05.2010
18B7374505D1DDEE pkg YERSGRI last 18.06.2010
186E9B370DCC24EC pkg YERSGSI last 31.05.2010
188D86E30DC4EF7D pkg YERSRAT last 19.06.2010
18BA5CA01032155E pkg YERSTO last 15.06.2010
18B7374807380B2A pkg YER0124 last 19.06.2010
18B7375012FC3226 pkg YER0202 last 16.06.2010
18B39C910D54FBB2 pkg YEU900 last 20.06.2010
188A4BC9115CE74B pkg YEVNTB last 17.06.2010
189BD5DD00E58714 pkg YEV0661 last 17.06.2010
188A4BE105FE5658 pkg YEV0662 last 03.06.2010
188A6889193088E8 pkg YEV0663 last 31.05.2010
188A689407D6312C pkg YEV0664 last 03.06.2010
188A689B17296DFB pkg YEV0666 last 17.06.2010
18B4B6FB068E830E pkg YEXD021 last 08.06.2010
18B4B6FE1A766D16 pkg YEXD022 last 18.06.2010
18B4B701195317BC pkg YEXD023 last 16.06.2010
18B4B7040BC294A7 pkg YEXD025 last 09.06.2010
18B4B70B04C9CCFA pkg YEXD027 last 15.06.2010
18B4B70D07B48C3E pkg YEXD028 last 15.06.2010
18B4B71201CE7FDD pkg YEXD029 last 14.06.2010
1895170D10BC1351 pkg YEXD030 last 15.06.2010
18B4B71413F7E192 pkg YEXD031 last 10.06.2010
18B4B7181ADDEB50 pkg YEXD032 last 10.06.2010
18B4B71B0EBA778B pkg YEXD036 last 11.06.2010
18B4B5550B6163D4 pkg YEXETXT last 19.06.2010
18B4B720161123F2 pkg YEXG021 last 17.06.2010
18B4B7231F428447 pkg YEXG022 last 18.06.2010
18B4B725089879A4 pkg YEXG023 last 19.06.2010
18B4B7271BA6E77A pkg YEXG024 last 18.06.2010
18B4B7291E63192A pkg YEXG025 last 18.06.2010
18B4B72C110E4B0E pkg YEXG026 last 10.06.2010
18B4D04710ABB7C0 pkg YEXG027 last 15.06.2010
18B4D04A01AC28D4 pkg YEXG028 last 18.06.2010
18B4D05511166C0C pkg YEXG029 last 15.06.2010
1887DD620B9A5DF0 pkg YEXG030 last 18.06.2010
18B4D0561C2D0A5A pkg YEXG031 last 14.06.2010
18B4D058191319AA pkg YEXG032 last 10.06.2010
18B4D0680DA455C8 pkg YEXG033 last 18.06.2010
18B4D06B143D4E2C pkg YEXG035 last 18.06.2010
18B4D06D1FF5E5E8 pkg YEXG036 last 11.06.2010
18B4D070120F10D4 pkg YEXG037 last 18.06.2010
18B4D07E18DC3652 pkg YEXI021 last 08.06.2010
18B4D0841AE3ED9C pkg YEXI022 last 18.06.2010
18B4D0881D54A4CE pkg YEXI023 last 16.06.2010
18B4D08B10FC3B97 pkg YEXI024 last 17.06.2010
18B4D08E0BA4D80C pkg YEXI025 last 09.06.2010
18B4D09308D78CFA pkg YEXI027 last 15.06.2010
18B4D09512D17E2C pkg YEXI028 last 18.06.2010
18B4D09809793509 pkg YEXI029 last 14.06.2010
189799EA0A2F2F06 pkg YEXI030 last 15.06.2010
18B4D09A15B87C04 pkg YEXI031 last 10.06.2010
18B4D0A31CCCCAB0 pkg YEXI036 last 11.06.2010
18B4D0AC05FB2472 pkg YEXS022 last 18.06.2010
18B4D0B412BC7C1A pkg YEXS024 last 15.06.2010
18B6453F1978588C pkg YEX0003 last 17.06.2010
183127F30D2A3881 pkg YFFFEBT last 18.06.2010
182CE0481E5D74B1 pkg YFFFEHL last 02.06.2010
189E3BBD1138EA23 pkg YFF0002 last 20.06.2010
18406BB60F38E14A pkg YFF0006 last 20.06.2010
18B70AB31A4FA20E pkg YFF0009 last 20.06.2010
189E3BCB0C6F74A9 pkg YFF0013 last 20.06.2010
18917860050BFBB2 pkg YFF0022 last 17.06.2010
189EA82608BA3C00 pkg YFF0023 last 18.06.2010
188D4A6E0F1211C1 pkg YFF0024 last 20.06.2010
189EAC0A0FDD7E1D pkg YFF0027 last 18.06.2010
18B70AB809DF68A4 pkg YFF03ZA last 20.06.2010
188D49C300B618B1 pkg YFF0510 last 20.06.2010
18A38DFB1D52DB78 pkg YFIADJU last 18.06.2010
18BEE143117D9832 pkg YFIDAL1 last 18.06.2010
18C48D4412780588 pkg YFIDAL1 last 19.06.2010
18BCFDB1057E7FA0 pkg YFIDAL2 last 18.06.2010
18C02BA913B9C560 pkg YFILOAD last 31.05.2010
18C1E1921932E63C pkg YFILOAD last 04.06.2010
18C2F800083980D4 pkg YFILOAD last 10.06.2010
18C27E621953D440 pkg YFILOAD last 07.06.2010
18C36F2809902278 pkg YFILOAD last 18.06.2010
18C4AF8D1F71238E pkg YFILOAD last 20.06.2010
18C02BA114275CA2 pkg YFIMAST last 29.05.2010
18C1E7E30BFA31BE pkg YFIMAST last 04.06.2010
18C2FB5F1BB49476 pkg YFIMAST last 19.06.2010
18C20872142D4E8A pkg YFIMAST last 07.06.2010
188EA0B1190F979B pkg YFIWMKG last 04.06.2010
18A7A30E0D89CABB pkg YFI0130 last 18.06.2010
18BB9C82154560CC pkg YFI0140 last 11.06.2010
18C0070B11CE8078 pkg YFI0140 last 18.06.2010
18A7A310090EC9B0 pkg YFI0150 last 11.06.2010
18C16F61009D8860 pkg YFI0150 last 20.06.2010
18A7A3210BA2C06C pkg YFI021 last 18.06.2010
18BDA39717A300D0 pkg YFI021 last 19.06.2010
18BDA3981A6D8F18 pkg YFI025 last 19.06.2010
188A43661AB002BC pkg YFI7501 last 19.06.2010
18A6B85D131DE292 pkg YFI7502 last 19.06.2010
188A4366101D5696 pkg YFI7503 last 19.06.2010
188A436819A4E164 pkg YFI7504 last 19.06.2010
188A43690F52D8AB pkg YFI7505 last 19.06.2010
188A436902BA950E pkg YFI7506 last 19.06.2010
188A43690BA37EA9 pkg YFI7507 last 19.06.2010
188A4369081BEEF0 pkg YFI7508 last 19.06.2010
188A436A1508E7C1 pkg YFI7509 last 19.06.2010
18BFDFD60158C226 pkg YFI940 last 19.06.2010
18A7D42A08F73EA8 pkg YFZLCM last 16.06.2010
18A7D45E05DA98EE pkg YFZMFS last 18.06.2010
18A7D4B4051A490E pkg YFZZAHL last 18.06.2010
18858F941F4CCCB5 pkg YGAFMNO last 18.06.2010
188AE578143563A2 pkg YGA0110 last 18.06.2010
188AE56B1D4AC3AC pkg YGA0120 last 18.06.2010
187CE06F028B4181 pkg YGEBA01 last 19.06.2010
189ECF7A0D67BECE pkg YGEEL01 last 19.06.2010
189ECF6E0EEF09F8 pkg YGEFKON last 17.06.2010
189EFD531A3614B7 pkg YGEPTAB last 20.06.2010
188EADE51588226F pkg YGE0003 last 20.06.2010
188EADE61000D24C pkg YGE0004 last 20.06.2010
189EFC950CF788FE pkg YGE0040 last 18.06.2010
189EB5251D66153B pkg YGE0050 last 20.06.2010
189EFCFD10AEBC25 pkg YGE0070 last 18.06.2010
18A7F2C900AFE074 pkg YGMISRC last 20.06.2010
189AC7D50B504D98 pkg YGMLIMP last 18.06.2010
189AC7D71F7EA4A6 pkg YGMSTEU last 20.06.2010
189B8AD509C97B90 pkg YGMTA3U last 19.06.2010
1896121E03515966 pkg YGM0061 last 19.06.2010
18B93D08089C3DE6 pkg YGM0210 last 18.06.2010
187DB65F16FF6094 pkg YGM0801 last 17.06.2010
181E9A801DC36845 pkg YHBASGL last 11.06.2010
181E9A7E105E01FD pkg YHBASGT last 02.06.2010
187BCD78162A4EED pkg YHBKAS last 19.06.2010
18B509A7118D945E pkg YHBKNBX last 20.06.2010
189637AB04EE7FF1 pkg YHBK002 last 17.06.2010
1894C3941BB16A5E pkg YHBK003 last 24.05.2010
18960F5F17C200CF pkg YHBK004 last 18.06.2010
1894F4F1136704B0 pkg YHBK005 last 24.05.2010
1894C3C91E6A79E8 pkg YHBK006 last 15.06.2010
187BCD781B7E788D pkg YHBK007 last 24.05.2010
189F554A06B15D66 pkg YHBK008 last 18.06.2010
188E85690345E904 pkg YHBK009 last 18.06.2010
18965D18115CF784 pkg YHBK012 last 18.06.2010
18BBC4350AB170A0 pkg YHBK013 last 18.06.2010
18509AB00656DB3B pkg YHBK013 last 08.06.2010
18BBC4581E864C4A pkg YHBK017 last 18.06.2010
18509AB314E219D3 pkg YHBK017 last 08.06.2010
1892C1E00F28E9DC pkg YHBK018 last 18.06.2010
18A39380080DDD3F pkg YHBK026 last 18.06.2010
1894C3C412B8E470 pkg YHBK027 last 15.06.2010
18B52C421CCAA56C pkg YHBLOAD last 18.06.2010
18B509A40881EF09 pkg YHBRG last 20.06.2010
18B4DAAC0C559D50 pkg YHBRT last 20.06.2010
189C05BA1BD39411 pkg YHB14MT last 10.06.2010
189C05BC140D68A5 pkg YHB14TG last 19.06.2010
180F3A5118C1A7DB pkg YHYISKH last 15.06.2010
1850BF8E075D3B39 pkg YHYJ003 last 18.06.2010
1850BF8D07417118 pkg YHYJ005 last 18.06.2010
1850BF8C18B53C70 pkg YHYJ011 last 16.06.2010
1850BF8E10F6248D pkg YHYJ012 last 18.06.2010
1850BF900F45EB22 pkg YHYJ121 last 18.06.2010
185B8E210F4112D5 pkg YHYJ122 last 18.06.2010
1850BF911A7E6779 pkg YHYJ130 last 18.06.2010
1850BF910C99DC32 pkg YHYJ140 last 18.06.2010
1850BF921AFDCA0E pkg YHYJ141 last 19.06.2010
1850BF9518D7CC57 pkg YHYJ142 last 20.06.2010
1850BF980E1B4520 pkg YHYJ143 last 19.06.2010
1850BF970AFC3C34 pkg YHYJ150 last 18.06.2010
1850BF970C2FFD4B pkg YHYJ161 last 19.06.2010
1850BF9C1E42F27A pkg YHYM100 last 20.06.2010
1850BFA0048A61BD pkg YHYM110 last 18.06.2010
1850BF9D0D8B18F8 pkg YHYM120 last 18.06.2010
1850BF9D1D99C3F0 pkg YHYM121 last 18.06.2010
1850BFA014DE1014 pkg YHYM122 last 18.06.2010
1850BFA416918B53 pkg YHYM130 last 18.06.2010
1850BFA303534149 pkg YHYM140 last 19.06.2010
1850BFA30C4BBC5E pkg YHYM141 last 18.06.2010
1850BFA4186E97EE pkg YHYM142 last 18.06.2010
1850BFA7178408D5 pkg YHYM143 last 18.06.2010
1850BFA90C9CD812 pkg YHYM145 last 19.06.2010
1850BFA80755ED0F pkg YHYM146 last 18.06.2010
1850BFA803CC9D8F pkg YHYM147 last 18.06.2010
1850BFA91819CF0B pkg YHYM150 last 18.06.2010
1850BFAD04390589 pkg YHYM151 last 09.06.2010
1850BFAE0D89DC95 pkg YHYM152 last 18.06.2010
1850BFAE0B7BD50A pkg YHYM160 last 18.06.2010
1850BFAC1E9486BD pkg YHYM161 last 18.06.2010
1850BFB80A34749F pkg YHYM170 last 18.06.2010
1850BFB90E92C30C pkg YHYM181 last 14.06.2010
1850BFB71F91BE20 pkg YHYM190 last 20.06.2010
1850BFBB09CA2F2B pkg YHYM191 last 19.06.2010
1850BFBE1F2F03D2 pkg YHYM192 last 18.06.2010
1850BFC010E2D74A pkg YHYM193 last 18.06.2010
1850BFC00E665684 pkg YHYM194 last 18.06.2010
180FB2DD050464C6 pkg YHYTRCL last 20.06.2010
1850BF5D0F4D3408 pkg YHYT001 last 19.06.2010
1850BF5F045B7318 pkg YHYT004 last 18.06.2010
1850BF63125506FD pkg YHYT006 last 18.06.2010
1850BF6319E90A08 pkg YHYT007 last 18.06.2010
1850BF640A7965C4 pkg YHYT008 last 20.06.2010
1850BF65094E67E1 pkg YHYT009 last 18.06.2010
1850BF641503C648 pkg YHYT010 last 18.06.2010
1850BF6917061120 pkg YHYT013 last 18.06.2010
1850BF6A0E3A103E pkg YHYT018 last 18.06.2010
1850BF691EE078FC pkg YHYT100 last 20.06.2010
1850BF6F0C2942C4 pkg YHYT110 last 19.06.2010
1850BF6E10F71F5E pkg YHYT120 last 20.06.2010
1850BF700967BCF4 pkg YHYT121 last 18.06.2010
1850BF700845B3F8 pkg YHYT122 last 19.06.2010
1850BF700954894E pkg YHYT123 last 19.06.2010
1850BF740BDB8A91 pkg YHYT125 last 19.06.2010
1850BF751541DDDC pkg YHYT130 last 19.06.2010
1850BF750F972880 pkg YHYT140 last 20.06.2010
1850BF761B459BFF pkg YHYT141 last 19.06.2010
1850BF75179A872B pkg YHYT142 last 18.06.2010
1850BF791AE1DBCA pkg YHYT143 last 18.06.2010
1850BF7A1A990D4A pkg YHYT145 last 18.06.2010
1850BF7C00BEC460 pkg YHYT147 last 18.06.2010
1850BF7B08241E45 pkg YHYT150 last 20.06.2010
1850BF7E136C6429 pkg YHYT151 last 19.06.2010
1850BF7F126B2351 pkg YHYT152 last 18.06.2010
1850BF810E70D095 pkg YHYT160 last 20.06.2010
1850BF80105F77EF pkg YHYT161 last 18.06.2010
1850BF8607EEB6D5 pkg YHYT171 last 18.06.2010
1850BF871E35D95F pkg YHYT181 last 20.06.2010
1850BF891E06B184 pkg YHYT190 last 10.06.2010
1850BFE008DEAAF1 pkg YHYUBBA last 18.06.2010
1850BFDC03BBCEC0 pkg YHYUBKA last 18.06.2010
188B35BF09D18DC3 pkg YHYUKAU last 18.06.2010
189683A018D550E9 pkg YHYUMIW last 20.06.2010
18B39ED31EDAE91E pkg YHYUPS1 last 18.06.2010
186FB00B0B4C1508 pkg YHYWKEH last 20.06.2010
18B736AF03810652 pkg YICTGCP last 19.06.2010
188DC0F611E88CD6 pkg YIDDOCS last 19.06.2010
18BE286F067F8CDA pkg YIDXREQ last 19.06.2010
1814B66016D3AFA9 pkg YID0008 last 20.06.2010
1894C44F163144F6 pkg YID0009 last 20.06.2010
1814B670141914DF pkg YID0011 last 20.06.2010
1814B67502AA7534 pkg YID0012 last 19.06.2010
18296F5E1B141785 pkg YID0013 last 19.06.2010
18460D0B1B0E4C2E pkg YID0015 last 19.06.2010
18296F8B03D4B8B4 pkg YID0016 last 19.06.2010
1814B69705ED720D pkg YID0019 last 20.06.2010
1814B69B0D7D51C7 pkg YID0020 last 19.06.2010
1814B6A3170F343B pkg YID0022 last 19.06.2010
1814B6A71ADC3AC8 pkg YID0023 last 20.06.2010
1814B6B6048BD690 pkg YID0025 last 20.06.2010
18AE9A8F0E4732BE pkg YID0027 last 20.06.2010
18296F900E80F843 pkg YID0028 last 20.06.2010
18AE9A9A159E8168 pkg YID0034 last 19.06.2010
1814B70E021BEE66 pkg YID0035 last 08.06.2010
18BFAE1D1F8662FA pkg YID0050 last 20.06.2010
188B14621015804A pkg YID0050 last 11.06.2010
181252AD0F917929 pkg YITPAR last 20.06.2010
18429C10175654CB pkg YITRFTG last 20.06.2010
18187CCB00AA129C pkg YITRFTS last 20.06.2010
1822867209498E7B pkg YIT0021 last 18.06.2010
1822642C0DFABB6D pkg YIT0022 last 18.06.2010
18B82E22047FB10A pkg YIT0040 last 20.06.2010
184EAD5218D15BE4 pkg YIT0041 last 20.06.2010
18A7F6591E9CC2A8 pkg YIT0045 last 09.06.2010
181B283C15A0DA27 pkg YJMPROV last 18.06.2010
181B284D0F61C203 pkg YJMSTP last 18.06.2010
1837E61C0035C6E4 pkg YJMT125 last 16.06.2010
18B503D10526A7AF pkg YKBCRDT last 19.06.2010
18794EC80CB5A64A pkg YKBCRUS last 20.06.2010
18B503E70077DA99 pkg YKBGETK last 19.06.2010
184ED3D213DB7B9B pkg YKCBUCR last 20.06.2010
185017CF19DD05D0 pkg YKCBUCS last 20.06.2010
184A96AC0CD58D4B pkg YKCBUDE last 19.06.2010
187EEDCD07D63890 pkg YKCBUGE last 20.06.2010
186B49E405F4E670 pkg YKCBUKE last 20.06.2010
18B98695017154FD pkg YKCBUPL last 18.06.2010
18B7FDF91A96A45E pkg YKCBUUP last 20.06.2010
188A46C9061B0085 pkg YKCFLAG last 20.06.2010
188588931411550A pkg YKCFLAS last 20.06.2010
188B32180429D4A1 pkg YKCKAND last 20.06.2010
18B641C80A875DB4 pkg YKCKANG last 20.06.2010
183447941BDA6508 pkg YKCKANG last 20.06.2010
18B641EB08EE24E2 pkg YKCKANI last 20.06.2010
186B9E52054A2482 pkg YKCLOGI last 18.06.2010
186B9E5501992239 pkg YKCLOGS last 18.06.2010
188125761D69F30C pkg YKCT011 last 19.06.2010
1881264D127556EE pkg YKCT013 last 19.06.2010
18A45DB915221409 pkg YKCT099 last 19.06.2010
18B61ED219DE5B72 pkg YKCWFAG last 20.06.2010
18B61ED807ED4A4D pkg YKCWFAI last 19.06.2010
18B61EDD0D839488 pkg YKCWFAU last 20.06.2010
18799E170A0435C8 pkg YKCWFCD last 18.06.2010
18799D480B2D0766 pkg YKCWFCG last 19.06.2010
18799D0D1AD2252A pkg YKCWFCI last 19.06.2010
18799CEB02625EA2 pkg YKCWFCP last 19.06.2010
18799CDF028AD4C9 pkg YKCWFCU last 19.06.2010
18799CC617D2AA2D pkg YKCWFSG last 18.06.2010
18799C760D6A95C2 pkg YKCWFSI last 20.06.2010
18799C5C05501B98 pkg YKCWFVG last 19.06.2010
18799C440EA63DD2 pkg YKCWFVI last 19.06.2010
18799C2C1DBB3737 pkg YKCWFVU last 19.06.2010
18799B410FEEA84C pkg YKCWFZG last 20.06.2010
18B61EE00071C431 pkg YKCWFZI last 19.06.2010
18B61EE3097B02F1 pkg YKCWFZU last 19.06.2010
18B558990C5E75F0 pkg YKC011U last 20.06.2010
1879963C04332190 pkg YKC013G last 20.06.2010
188A46C605A15A29 pkg YKC0520 last 19.06.2010
18B2AA3F037ECD4A pkg YKC0540 last 18.06.2010
18B5589A00776820 pkg YKC099G last 19.06.2010
1845BA391898DF0B pkg YKDPDIG last 20.06.2010
184E830616BBFC64 pkg YKEA001 last 20.06.2010
185B17B315F44885 pkg YKEA006 last 19.06.2010
185B1DE51A193852 pkg YKEA010 last 20.06.2010
18785450106620FB pkg YKEA011 last 20.06.2010
1863C93B01998E32 pkg YKEA012 last 20.06.2010
189B92841FBFD57E pkg YKEA016 last 20.06.2010
18A9B01B1148734E pkg YKEA017 last 20.06.2010
188B80170C552160 pkg YKEA018 last 20.06.2010
189BFF2F16C06382 pkg YKEA019 last 20.06.2010
18B857FE0B15A664 pkg YKEA025 last 18.06.2010
1863C94508253A0E pkg YKEA028 last 20.06.2010
1863C94C08B3158A pkg YKEA029 last 20.06.2010
185B17BD03791E82 pkg YKEA031 last 20.06.2010
1863C94A1F3D557F pkg YKEA032 last 20.06.2010
188B7FF90D3C48E5 pkg YKEA033 last 18.06.2010
1863C9470CCF18EE pkg YKEA034 last 18.06.2010
1863C95E08B039F2 pkg YKEA037 last 20.06.2010
1863C9690276EE23 pkg YKEA038 last 19.06.2010
1863C92407142093 pkg YKEA039 last 18.06.2010
1863C9621388770B pkg YKEA040 last 20.06.2010
1863C96A03400DCF pkg YKEA041 last 20.06.2010
1863C930023CBF53 pkg YKEA042 last 20.06.2010
1863C9680C6AAE8C pkg YKEA043 last 19.06.2010
1863C9301A7DC888 pkg YKEA045 last 20.06.2010
1863C96310963F5F pkg YKEA046 last 18.06.2010
18A7D254177DABEC pkg YKEA048 last 20.06.2010
1863C9360426C6BC pkg YKEA049 last 18.06.2010
1863C9670C4602B0 pkg YKEA050 last 18.06.2010
1863C9300238DEC1 pkg YKEA051 last 18.06.2010
1863C96D1A5AE08F pkg YKEA054 last 20.06.2010
1863C936044A53B0 pkg YKEA056 last 18.06.2010
1863C97612B60D54 pkg YKEA057 last 18.06.2010
189F259E0DB13A43 pkg YKEA058 last 18.06.2010
1863C97010089889 pkg YKEA059 last 18.06.2010
185B17C00AF32784 pkg YKEA060 last 18.06.2010
185B17C310C9F782 pkg YKEA061 last 18.06.2010
187DDAF017A385E5 pkg YKEA066 last 20.06.2010
1863C91E140AEA55 pkg YKEA067 last 20.06.2010
1859643C0EF92D9E pkg YKEA070 last 20.06.2010
1863C97113A5A3E5 pkg YKEA071 last 19.06.2010
1863C97214448BAF pkg YKEA072 last 18.06.2010
1863C96C0DCD792E pkg YKEA075 last 18.06.2010
1863C97209DC3589 pkg YKEA076 last 18.06.2010
189515FF19EC3B6C pkg YKEA077 last 20.06.2010
189519B419D3E61B pkg YKEA078 last 20.06.2010
1863C96D03F806B4 pkg YKEA079 last 20.06.2010
1863C96403EC2FFE pkg YKEA080 last 20.06.2010
1863C95D02A7B24B pkg YKEA081 last 18.06.2010
18B66F5C158BF5DC pkg YKEA082 last 20.06.2010
18B66F5E12FB916C pkg YKEA083 last 18.06.2010
1863C9621CA52BC9 pkg YKEA085 last 18.06.2010
185964451CA616AE pkg YKEA087 last 20.06.2010
1863C9580DDF0EBC pkg YKEA094 last 20.06.2010
1863C91A0D0C1C16 pkg YKEA096 last 16.06.2010
18B852BE159000B8 pkg YKEA097 last 18.06.2010
188B8020080D2C01 pkg YKEA099 last 18.06.2010
188B8026088CFD00 pkg YKEA101 last 20.06.2010
1863C93002BDFE85 pkg YKEA104 last 20.06.2010
1863C92706F7D1D5 pkg YKEA105 last 20.06.2010
1863C91B02A6A6EB pkg YKEA108 last 20.06.2010
1863C91B1728FCDF pkg YKEA109 last 20.06.2010
18572C5908CBBAF4 pkg YKEA110 last 20.06.2010
188B381A18B5D54D pkg YKEA111 last 20.06.2010
187F1E461406C9F0 pkg YKEA112 last 14.06.2010
1863C957063B7E42 pkg YKEA113 last 19.06.2010
186FB2F1186ABB4F pkg YKEA117 last 20.06.2010
1879771C0E08CEBC pkg YKEA118 last 19.06.2010
1863C9551199CCD6 pkg YKEA119 last 18.06.2010
1863C9260F6FCE3E pkg YKEA120 last 18.06.2010
18B852C90BA35E56 pkg YKEA121 last 20.06.2010
188B802A06263E72 pkg YKEA123 last 20.06.2010
1871E3E31E185E6E pkg YKEA124 last 20.06.2010
1871E3EC023CDC2A pkg YKEA125 last 20.06.2010
1863C94C0E54DB36 pkg YKEA126 last 20.06.2010
1863C934138FB121 pkg YKEA128 last 18.06.2010
1863C950044697BE pkg YKEA129 last 18.06.2010
187A8DAD1CFCB628 pkg YKEA133 last 18.06.2010
1863C9511EA35141 pkg YKEA134 last 18.06.2010
1863D0AF10D37BBC pkg YKEA135 last 20.06.2010
1863C9491B2EB47C pkg YKEA136 last 18.06.2010
1863C9210FAF8CE9 pkg YKEA137 last 20.06.2010
188B803216FE221A pkg YKEA138 last 20.06.2010
18707A6D19EDC57C pkg YKEA139 last 18.06.2010
18AC64E2016924EC pkg YKEA141 last 20.06.2010
18AB24121568F6D2 pkg YKEA142 last 20.06.2010
18707BB002BBFC19 pkg YKEA146 last 20.06.2010
18B8584910F9FBFF pkg YKEM100 last 20.06.2010
1863C93513CB29A1 pkg YKEQRDL last 18.06.2010
18B8581204FA5D1C pkg YKET602 last 19.06.2010
1899857E1184F203 pkg YKRKAT last 18.06.2010
185D24C31A744614 pkg YKRM139 last 19.06.2010
184E6487014B739E pkg YKRM432 last 19.06.2010
183A17691249C1F0 pkg YKRM501 last 20.06.2010
189985E8090AD527 pkg YKRM511 last 20.06.2010
182F985C078AF466 pkg YKRM513 last 19.06.2010
183A17631000BA47 pkg YKRM515 last 19.06.2010
183A175A0FA48315 pkg YKRM517 last 20.06.2010
183A175302B9B1B8 pkg YKRM518 last 19.06.2010
189985DA1E11EFE5 pkg YKRM519 last 20.06.2010
1812B35E19C7A87A pkg YKRM521 last 20.06.2010
1812B35B1C074FF9 pkg YKRM522 last 20.06.2010
183A17411248BD6F pkg YKRM560 last 20.06.2010
183A173501FBD371 pkg YKRM562 last 19.06.2010
183A17281B205297 pkg YKRM564 last 19.06.2010
183A171C01FC31EF pkg YKRM566 last 19.06.2010
183A1704108D7EC3 pkg YKRM567 last 19.06.2010
182F986105E8DB5D pkg YKRM584 last 20.06.2010
183A16F01350345E pkg YKRM586 last 20.06.2010
1812B3640B03F4DC pkg YKRM587 last 19.06.2010
183A16B1086DAE68 pkg YKRM588 last 19.06.2010
183A16A507F97B86 pkg YKRM589 last 20.06.2010
183A16981615CA2E pkg YKRM592 last 19.06.2010
183A168D007147E2 pkg YKRM620 last 19.06.2010
183A16801B88483E pkg YKRM621 last 19.06.2010
183A167310899E6B pkg YKRM622 last 19.06.2010
18A365181591907E pkg YKRM624 last 19.06.2010
185133551C943A24 pkg YKRM902 last 20.06.2010
185D06D517EBE4D7 pkg YKRT005 last 19.06.2010
189985F80E5A508A pkg YKRT025 last 19.06.2010
185CFC300C2279F4 pkg YKRT139 last 19.06.2010
184E648F19625FCA pkg YKRT140 last 19.06.2010
185D21331320E5C6 pkg YKRT149 last 19.06.2010
186EEAAC0BC896B4 pkg YKRT244 last 17.06.2010
1863E8E90728CF79 pkg YKRT247 last 17.06.2010
184E649306E4E6D4 pkg YKRT316 last 20.06.2010
184EDECE0DFF9EA5 pkg YKRT323 last 19.06.2010
184E649B1DCCC161 pkg YKRT398 last 19.06.2010
185D0655167C45A0 pkg YKRT431 last 19.06.2010
185D045400BAD04E pkg YKRT432 last 18.06.2010
18BAAB0A1AC6B10C pkg YKRT501 last 20.06.2010
189985FB0513B033 pkg YKRT501 last 18.06.2010
189985E71F1D0BA8 pkg YKRT511 last 20.06.2010
1812B3451CFE82A0 pkg YKRT513 last 20.06.2010
1812B3491D7B11B3 pkg YKRT515 last 20.06.2010
1812B34A0C7E7498 pkg YKRT517 last 20.06.2010
1812B34A0D9696FB pkg YKRT518 last 20.06.2010
1812B34C0A004F86 pkg YKRT519 last 20.06.2010
1812B3490C56EA2B pkg YKRT521 last 20.06.2010
1812B34E05804812 pkg YKRT522 last 20.06.2010
18264C0604113EDC pkg YKRT560 last 20.06.2010
1812B34E0F4D242C pkg YKRT562 last 20.06.2010
1828021615FFF6C8 pkg YKRT564 last 20.06.2010
1812B35106381F80 pkg YKRT566 last 20.06.2010
1812B34D103D63B6 pkg YKRT567 last 20.06.2010
1812B352080BCF49 pkg YKRT584 last 20.06.2010
182F975D01F589E5 pkg YKRT586 last 20.06.2010
1812B353010D63F8 pkg YKRT587 last 20.06.2010
1812B3541F7589FD pkg YKRT588 last 20.06.2010
1812B351196DF984 pkg YKRT589 last 20.06.2010
185133581EC152FD pkg YKRT620 last 20.06.2010
1812B356066BCC96 pkg YKRT621 last 19.06.2010
1812B3561BEDB88C pkg YKRT622 last 19.06.2010
1812B358062E3B09 pkg YKRT624 last 20.06.2010
1812B3541F292382 pkg YKRT902 last 20.06.2010
18B64B0A10D543DA pkg YKSCIFE last 20.06.2010
186E49800078CA84 pkg YKSD04 last 20.06.2010
186E499007CB74EA pkg YKST261 last 19.06.2010
1888D7A508296632 pkg YKS04DA last 18.06.2010
18B7F9F70F856110 pkg YLB0091 last 20.06.2010
18B82B4801B9C4D5 pkg YLCJRPT last 17.06.2010
18B78B8711A5F005 pkg YLCJTRN last 18.06.2010
18B75C8D1FF87E16 pkg YLCJ056 last 18.06.2010
18B786D310F83B48 pkg YLCM058 last 18.06.2010
18B850240D0D7CAC pkg YLCM065 last 03.06.2010
18B78C7500F619DE pkg YLCTF05 last 16.06.2010
18B78C7808BA6415 pkg YLCTF06 last 16.06.2010
18333AEF0CCF925A pkg YLCTF08 last 10.06.2010
1896FDCF170823C4 pkg YLCT050 last 18.06.2010
18B321C51FC63745 pkg YLCT053 last 18.06.2010
18BA7F890134CD96 pkg YLCT059 last 18.06.2010
18B321B103F646C2 pkg YLCT062 last 10.06.2010
189A9FD317BBB996 pkg YLCT063 last 18.06.2010
18B6EBE61C1A6BC7 pkg YLCT065 last 18.06.2010
18BDCAFD1A61FC38 pkg YLGAUSL last 18.06.2010
1890880A11A8F2C9 pkg YLWAEEU last 19.06.2010
189A93B20F8B1906 pkg YLW0570 last 20.06.2010
18B98EAC0658ED5A pkg YLXCHKD last 20.06.2010
18A9B1C1160332D6 pkg YMBTRCK last 20.06.2010
18B3C461105C50D0 pkg YMB5122 last 20.06.2010
18B3BEF41CC34810 pkg YMB5222 last 20.06.2010
188A4DE31FFE3FCA pkg YMCCS01 last 18.06.2010
188A437C08D52EDA pkg YMCNS01 last 16.06.2010
18B64BE1146C0477 pkg YMC041L last 18.06.2010
188A4E741CF1E3C2 pkg YMC042L last 18.06.2010
18B64BC310A2E2B6 pkg YMC043L last 18.06.2010
18B64BBC02E31C22 pkg YMC044L last 20.06.2010
188A4E7B147E5816 pkg YMC085L last 18.06.2010
188A43810E5AE428 pkg YMC086L last 15.06.2010
18B642A115FA150A pkg YMC110L last 10.06.2010
188A44F61C38BC23 pkg YMC112L last 16.06.2010
18B642A016D979A6 pkg YMC113L last 17.06.2010
188A439306C434DB pkg YMC114L last 17.06.2010
188A43CB10746C98 pkg YMC117L last 15.06.2010
187E011B142FD4B8 pkg YMC121L last 15.06.2010
187E00FA06A25638 pkg YMC125L last 15.06.2010
188A43D00853F589 pkg YMC126L last 02.06.2010
188A43D712E14705 pkg YMC127L last 15.06.2010
187E02A60A548DFB pkg YMC134L last 17.06.2010
187DFC9110AEB39C pkg YMC142L last 17.06.2010
18B6428C12116992 pkg YMC152L last 15.06.2010
18A9DBB41BC3382E pkg YMC153L last 15.06.2010
18A9DBB30C20C2FA pkg YMC160L last 15.06.2010
18A9DBB11B7815CA pkg YMC161L last 15.06.2010
18A9DAD1188165B0 pkg YMC233L last 19.06.2010
18A9DB4315A276A6 pkg YMC241L last 14.06.2010
18A9DB4504EA94EE pkg YMC242L last 20.06.2010
18B64B9F14D19F7A pkg YMC244L last 18.06.2010
18B64B9E0DA7CD88 pkg YMC245L last 18.06.2010
187E26B5116D0B17 pkg YMC250L last 20.06.2010
188A4E9C1E931988 pkg YMC253L last 18.06.2010
188A4E980717012D pkg YMC254L last 18.06.2010
187E252A0819EB0E pkg YMC255L last 18.06.2010
18867A3E03BAF0CF pkg YMC257L last 18.06.2010
18867A3B0A95D316 pkg YMC258L last 17.06.2010
187E253004548BC1 pkg YMC262L last 20.06.2010
18A9DACF17960035 pkg YMC265L last 18.06.2010
18BF507C1D999C3A pkg YMFAURA last 19.06.2010
18BAA77617549990 pkg YMFCT0X last 19.06.2010
18C32B790B2BD900 pkg YMFCT0X last 18.06.2010
18A9D603107A063A pkg YMFC016 last 20.06.2010
18BBEEBB04D7FBC2 pkg YMFC101 last 20.06.2010
18A9D7460DA45DB0 pkg YMFC104 last 20.06.2010
18BBEEC417AAFD92 pkg YMFC105 last 20.06.2010
18B1E0E100900C71 pkg YMFC106 last 20.06.2010
1871BBF80CB3CBD3 pkg YMFC107 last 19.06.2010
18B1E1C30EBF62E2 pkg YMFC108 last 20.06.2010
18A9D7690E6A1214 pkg YMFC110 last 20.06.2010
188C01F016BE787B pkg YMFC112 last 20.06.2010
186A579001EDFC3C pkg YMFC113 last 20.06.2010
1873F4221EFB664E pkg YMFC114 last 20.06.2010
18A81AF81BD3A0F5 pkg YMFC115 last 18.06.2010
18A9D76B132C2640 pkg YMFC118 last 20.06.2010
18A9D76E1E4802C6 pkg YMFC119 last 18.06.2010
18A9D77B0EB5B660 pkg YMFC120 last 17.06.2010
18A9D77E12E455F0 pkg YMFC155 last 20.06.2010
18A81B1A08439481 pkg YMFC202 last 20.06.2010
18A81BBD06A70AA0 pkg YMFC203 last 20.06.2010
18A81C0212F6C577 pkg YMFC209 last 20.06.2010
18B1B9A90A960402 pkg YMFC211 last 18.06.2010
18A9ADD714BC51F8 pkg YMFC217 last 18.06.2010
18A9ADE80B4BDEE0 pkg YMFC219 last 20.06.2010
18A9D79C1FDFA3D0 pkg YMFC220 last 20.06.2010
18AD56FA085839CC pkg YMFGP0X last 20.06.2010
18709FD115BAAAC2 pkg YMFINFO last 20.06.2010
18750DCE038C2DFE pkg YMFLPID last 19.06.2010
1863C59A013109DA pkg YMFRF0X last 19.06.2010
1841A2DA18D50866 pkg YMFWSYX last 19.06.2010
1897497207BD2044 pkg YMFWS9X last 19.06.2010
18A9D79A1DDDC2EA pkg YMFX155 last 20.06.2010
18AB17DB1BE45F3A pkg YMIAUTH last 18.06.2010
1899A1DD01BB01CF pkg YMIHIER last 20.06.2010
187DDF5F122E62EF pkg YMIJ100 last 20.06.2010
1871B92F0E4227CC pkg YMIJ400 last 20.06.2010
1871B9341DEBA56E pkg YMIJ420 last 20.06.2010
18A781EB0D498D4A pkg YMIM100 last 20.06.2010
1871C05D0757572C pkg YMIM200 last 18.06.2010
1871C05F0398C98E pkg YMIM210 last 18.06.2010
1871C061144698B0 pkg YMIM211 last 18.06.2010
1871C06412D6EF5E pkg YMIM212 last 18.06.2010
1871C0671FDE9859 pkg YMIM213 last 18.06.2010
1871C06A0340FCEA pkg YMIM214 last 18.06.2010
1871C06C18E30836 pkg YMIM215 last 18.06.2010
1871C06F02BD6EAF pkg YMIM220 last 18.06.2010
1871C072068DBD76 pkg YMIM230 last 18.06.2010
1871C0751B54402F pkg YMIM240 last 20.06.2010
1871C077165DCAB9 pkg YMIM300 last 20.06.2010
1871C07A083C1BA2 pkg YMIM310 last 18.06.2010
1871C07C0E89B935 pkg YMIM311 last 18.06.2010
1871C07E01F8CB7C pkg YMIM400 last 09.06.2010
1871C0810D39926C pkg YMIM410 last 18.06.2010
1871C0C503CFF7F0 pkg YMIM420 last 20.06.2010
1871C0841527E32C pkg YMIM430 last 18.06.2010
187DDF5D1EBB292E pkg YMIPOS last 20.06.2010
1871B9B40547D830 pkg YMIRSRC last 20.06.2010
1871C08D1BDDFCE4 pkg YMISYS last 20.06.2010
1871C091125FE81D pkg YMITIME last 20.06.2010
1871C0940E1E5EA7 pkg YMITRA last 20.06.2010
186227711BEC7777 pkg YMIT100 last 20.06.2010
1871C09E0D42EB3E pkg YMIT140 last 20.06.2010
1871C0A41344A922 pkg YMIT200 last 20.06.2010
1871C0A81472F25A pkg YMIT210 last 20.06.2010
1871BB4B0D5131CC pkg YMIT211 last 20.06.2010
1871BB551E918A15 pkg YMIT212 last 20.06.2010
1871BB5909858127 pkg YMIT213 last 20.06.2010
1871BB601B742137 pkg YMIT214 last 20.06.2010
1871BB631F436B36 pkg YMIT215 last 20.06.2010
1871BB6810AFFB4E pkg YMIT220 last 20.06.2010
1871BB6C08ACE841 pkg YMIT230 last 20.06.2010
1871BB7007F79187 pkg YMIT240 last 20.06.2010
1871BB781ECF92E6 pkg YMIT302 last 20.06.2010
1871BB7C03252038 pkg YMIT310 last 20.06.2010
1871BBB71F5E97C6 pkg YMIT311 last 20.06.2010
1871BBBC1F959AC0 pkg YMIT400 last 09.06.2010
1871BBBF10653E44 pkg YMIT410 last 20.06.2010
18A82485063607FC pkg YMIT430 last 20.06.2010
1871BBC6109C2DA6 pkg YMIT500 last 20.06.2010
1871BBCC1E61D296 pkg YMIT520 last 20.06.2010
1871BBD01802C5EE pkg YMIT541 last 20.06.2010
188563A41985D7F9 pkg YMI51AB last 20.06.2010
1875FAEC12941E8A pkg YMI52AB last 20.06.2010
18A6D6320A14FE44 pkg YMI52CB last 21.06.2010
18960FD615901634 pkg YMI52DB last 18.06.2010
1871BC0A1FC1C399 pkg YMI53BB last 18.06.2010
18BF3CDD0E69B964 pkg YMI54BB last 20.06.2010
1899A29D0FF46B21 pkg YMI54BB last 11.06.2010
1871BC22001F0F55 pkg YMI55AB last 18.06.2010
18A7F89F0B022AC4 pkg YMI74AB last 20.06.2010
183496EC1F8F9D8E pkg YNFABST last 19.06.2010
187B0EAF0517A714 pkg YNFBE01 last 20.06.2010
1817D12007927830 pkg YNFBE02 last 20.06.2010
189CA1C81952F50D pkg YNFCGOE last 20.06.2010
18B7FC4F15837F2A pkg YNFDLUA last 19.06.2010
189CF7851E3BDADD pkg YNFE427 last 20.06.2010
189CF7891505C143 pkg YNFE440 last 20.06.2010
1886008B1BA15B0E pkg YNFGFME last 20.06.2010
18AAF85819DA19BF pkg YNFIBA0 last 18.06.2010
18AAF2570BFBE45C pkg YNFIB11 last 18.06.2010
18AAF268172B40C0 pkg YNFIB13 last 17.06.2010
1890B41D1B025288 pkg YNFIB14 last 18.06.2010
18AAF25E1B8FF8A9 pkg YNFIB15 last 17.06.2010
18B7058D1EE03A18 pkg YNFIB16 last 18.06.2010
18B7058F0517047A pkg YNFIB17 last 18.06.2010
185663CB01AD0F03 pkg YNFIP3 last 20.06.2010
18B7FC5D1CDD2CB4 pkg YNFLLBA last 19.06.2010
1855501D0F631C1E pkg YNFSTAE last 20.06.2010
1844CF53120B6243 pkg YNFTCOD last 20.06.2010
185894BC05DA5236 pkg YNFTRAN last 20.06.2010
189CF7641951BE66 pkg YNFU449 last 20.06.2010
189CF76719BDB5A6 pkg YNFU468 last 20.06.2010
189CF76709D351A5 pkg YNFU469 last 20.06.2010
189B5B7A16C5365A pkg YNFVMG4 last 20.06.2010
183247300CDE5ABD pkg YNFVMM4 last 20.06.2010
183247331BF8B25A pkg YNFV21 last 20.06.2010
185438B407255A32 pkg YNFWMK last 20.06.2010
188560691788355E pkg YNF0100 last 20.06.2010
18169DE8095D91FF pkg YNG$SWC last 18.06.2010
18B64C3E1337C948 pkg YNGACCT last 01.06.2010
187A622D154BA919 pkg YNGAPAB last 16.06.2010
18169DE90AA8C803 pkg YNGBEAT last 20.06.2010
18169DEB1808C366 pkg YNGBEAW last 20.06.2010
1899B152057A1A68 pkg YNGBIBO last 18.06.2010
18A6B665149E5316 pkg YNGBITE last 18.06.2010
1828F2A21D01FF52 pkg YNGBMFR last 18.06.2010
18169DE9173BBE42 pkg YNGBNBS last 20.06.2010
1899D83E002F176E pkg YNGBOOP last 18.06.2010
1899B0ED1EE5B284 pkg YNGBOSW last 11.06.2010
18169DD3197C83C1 pkg YNGBSSW last 20.06.2010
1899B0E412FEEF96 pkg YNGCATB last 18.06.2010
187AB9F60334603B pkg YNGCPAB last 08.06.2010
182607871C9757CE pkg YNGCPAW last 10.06.2010
182CC1AC138E0B89 pkg YNGCPPW last 18.06.2010
187A8DBF1DF60B12 pkg YNGDPAB last 18.06.2010
182741171F6B2914 pkg YNGEPAS last 07.06.2010
1827411813517D98 pkg YNGEPAW last 10.06.2010
1827411E08B13B08 pkg YNGEPPW last 18.06.2010
187A8DE801567796 pkg YNGERFT last 28.05.2010
1899B1771DE70C38 pkg YNGGKHB last 18.06.2010
18239DC703BE60D3 pkg YNGGMPD last 18.06.2010
187A8E040946C657 pkg YNGGPAU last 18.06.2010
182861760C75F6BC pkg YNGGPPU last 18.06.2010
1899D84501CF55AF pkg YNGINTE last 15.06.2010
18276F6C16803BCB pkg YNGIPAS last 07.06.2010
182CC1E4064374C0 pkg YNGIPAW last 07.06.2010
182CC1FB000FCA63 pkg YNGIPPW last 15.06.2010
183F7BF814E30BA6 pkg YNGJ024 last 20.06.2010
183F7BFB024C120F pkg YNGJ043 last 20.06.2010
183DDE241BB35273 pkg YNGJ046 last 20.06.2010
183F9A711465E412 pkg YNGJ207 last 18.06.2010
183F7BFD0946E4EA pkg YNGJ254 last 20.06.2010
183F7BFE0BDDEB65 pkg YNGJ255 last 20.06.2010
187AB08A1DEE8D1F pkg YNGKPPB last 16.06.2010
187AB0950C0D9065 pkg YNGKPRT last 08.06.2010
1817B3AD0C9FD4DE pkg YNGKSWC last 20.06.2010
1832EA080F9FD472 pkg YNGKSWL last 19.06.2010
18187B7117732828 pkg YNGKWEL last 19.06.2010
186A125A1FAA1068 pkg YNGKWEL last 20.06.2010
183DDE240653506B pkg YNGK255 last 20.06.2010
1899D84A0C062AD6 pkg YNGLKOP last 18.06.2010
187AB0C5183142D7 pkg YNGLPAB last 18.06.2010
187AB0CB1A5B369B pkg YNGMPAB last 18.06.2010
1899B0A41E614854 pkg YNGMUTL last 18.06.2010
1879C4601E69E342 pkg YNGM005 last 14.06.2010
1879C46709518180 pkg YNGM007 last 16.06.2010
1879C46D097F5367 pkg YNGM024 last 10.06.2010
1879C47804C6071F pkg YNGM037 last 10.06.2010
1879C54712CB9747 pkg YNGM256 last 18.06.2010
1827411D00663073 pkg YNGNAUT last 18.06.2010
189ABCC10DDD5340 pkg YNGNNBS last 20.06.2010
1827411B06297473 pkg YNGNPRT last 18.06.2010
18A6917C03315EFA pkg YNGNUOP last 18.06.2010
187ABBF4177A5ECE pkg YNGPAUT last 18.06.2010
18169DED1620220D pkg YNGPKDA last 19.06.2010
18169DED0ABE0EF5 pkg YNGPKKT last 20.06.2010
1899D85403FB31F7 pkg YNGPLAU last 18.06.2010
18545FA3182FBDEC pkg YNGPMFR last 18.06.2010
187ABC231918BE2A pkg YNGPPAB last 18.06.2010
18169DF0109E07BA pkg YNGPPKB last 20.06.2010
1817B3A31A0AD3A0 pkg YNGPPKT last 20.06.2010
1817B3FA16869DA8 pkg YNGPPK2 last 20.06.2010
185319C506DF18D8 pkg YNGPPPB last 18.06.2010
18169DF213645CF6 pkg YNGPPRB last 20.06.2010
187ABC3601FF95F8 pkg YNGPPRT last 18.06.2010
18169DC900120CDC pkg YNGPRDA last 20.06.2010
18169DC904911F21 pkg YNGPRDL last 18.06.2010
18169DC81CB96A97 pkg YNGPRKT last 20.06.2010
1817AF4103C6ADF0 pkg YNGPRRL last 18.06.2010
18169DDE0CA4A269 pkg YNGPSWL last 19.06.2010
1817AF4D0DA63003 pkg YNGPWEL last 19.06.2010
186A12601C4C7EE4 pkg YNGPWEL last 20.06.2010
1899D8561A27CC26 pkg YNGRGOP last 18.06.2010
1899D8581C830CF3 pkg YNGSSOP last 11.06.2010
18A69173109D590A pkg YNGSWOP last 18.06.2010
1899D85F0F5FDAF9 pkg YNGTLOP last 18.06.2010
1899D86200719049 pkg YNGTXOP last 18.06.2010
1879C54F1629E05C pkg YNGT005 last 20.06.2010
183DDE1D1BEF9313 pkg YNGT007 last 20.06.2010
1879C56B05F5AE0A pkg YNGT038 last 18.06.2010
1879C57815F767A4 pkg YNGT039 last 18.06.2010
183DDE1B18AF5F6C pkg YNGT040 last 20.06.2010
1879C58006534E75 pkg YNGT043 last 19.06.2010
1879C5851A5DA7FA pkg YNGT049 last 19.06.2010
1879C5B40FED234D pkg YNGT054 last 18.06.2010
183DDE191B2BF3E4 pkg YNGT207 last 20.06.2010
183DDE190B8FD9C3 pkg YNGT240 last 20.06.2010
183DDE1818FB6B36 pkg YNGT249 last 20.06.2010
183F7C18139D8EB4 pkg YNGT256 last 20.06.2010
187ABA4405F9AA2C pkg YNGUPAT last 08.06.2010
183F26C90E734A9A pkg YNGURFT last 28.05.2010
18A6916E112AFB44 pkg YNGWBOP last 18.06.2010
1899D86608E24CF2 pkg YNGWRFL last 18.06.2010
18B61F6C0ADCF10E pkg YNG317L last 15.06.2010
18B64B761A58EE2C pkg YNG318L last 16.06.2010
18B64B7E05450492 pkg YNG319L last 18.06.2010
1879A3B80D1C73B1 pkg YNG3220 last 28.05.2010
18B64B861DC11B5A pkg YNG323L last 15.06.2010
18B64BA21D12E1E8 pkg YNG329L last 18.06.2010
1899B15D171267FE pkg YNG3310 last 18.06.2010
1899B0081D409170 pkg YNG3311 last 18.06.2010
1899AFF9131A6CD0 pkg YNG3313 last 17.06.2010
1879C0A0175FA56F pkg YNG3320 last 18.06.2010
18B64BBC19415646 pkg YNG334L last 18.06.2010
1879C0A30E837DEA pkg YNG3350 last 19.06.2010
1879C0A6184CDEA8 pkg YNG3370 last 18.06.2010
1879C0AA0A206786 pkg YNG3380 last 18.06.2010
18B64C49064FED0A pkg YNG3400 last 16.06.2010
18B64BC4198CC5EA pkg YNG341L last 18.06.2010
18B64BCD03DAC082 pkg YNG342L last 18.06.2010
18B757F611982E70 pkg YNG3440 last 11.06.2010
18B64BE21FB308E4 pkg YNG349L last 08.06.2010
18B64BEB0E6F151A pkg YNG350L last 15.06.2010
1879A3A119A12348 pkg YNG3520 last 09.06.2010
1879A3A917774DC5 pkg YNG3610 last 28.05.2010
1879BDAC04895966 pkg YNG3620 last 28.05.2010
18B64C0018A1996E pkg YNG365L last 19.06.2010
18AFA8E301B32549 pkg YNIAGG last 20.06.2010
1827E24F1C9D3E07 pkg YNIBSKG last 20.06.2010
18AFA8E1167F541C pkg YNICAMG last 20.06.2010
182C4D571E43B6AE pkg YNICARU last 19.06.2010
182C6A3801677FA7 pkg YNICBAG last 20.06.2010
1827E1FB170E35D3 pkg YNICFLG last 20.06.2010
184091C218A6E1CD pkg YNICFSG last 19.06.2010
1827DCEE105F4F4C pkg YNICLFG last 20.06.2010
18B2832D0E9F460C pkg YNICLMC last 17.06.2010
1853E57216067216 pkg YNICLMG last 20.06.2010
18B3E6A01CE9E336 pkg YNICLMU last 18.06.2010
187DE0F80ED9CB20 pkg YNICLPG last 20.06.2010
18B1DC0704319CD5 pkg YNICL03 last 19.06.2010
182830C511036238 pkg YNICMWG last 19.06.2010
187C9CCF0EFF0B78 pkg YNICMWU last 17.06.2010
182CECE1196B8A1D pkg YNICORG last 19.06.2010
18AFAF920D966BFA pkg YNICORU last 19.06.2010
184092EA06336B7E pkg YNICPRU last 19.06.2010
1889F2301EE81515 pkg YNICRC last 20.06.2010
18AFA8EC08113DD6 pkg YNICREG last 20.06.2010
18B0C7EB053596F6 pkg YNICRSS last 19.06.2010
18BAB20312FEB1DA pkg YNICS00 last 19.06.2010
18B1ED45094831CA pkg YNICTEG last 19.06.2010
18B1DF17145CEB50 pkg YNICTEU last 19.06.2010
18AC898E0518F9E4 pkg YNICTRG last 20.06.2010
184091641ABDFE13 pkg YNICTRU last 19.06.2010
18B7FE5B05CEBEEE pkg YNICVB last 19.06.2010
186F67BB126B204D pkg YNICVG last 20.06.2010
182C6AB1089DDDA7 pkg YNICVP last 19.06.2010
182D8C151EB1281B pkg YNICVU last 19.06.2010
1851D3560EB4A392 pkg YNIDBFG last 20.06.2010
1851CF2E0ED3356B pkg YNIDCFG last 20.06.2010
1833F4E9075B1B9B pkg YNIDCFU last 18.06.2010
1851CF3607605E49 pkg YNIDIPG last 19.06.2010
186E75AF0A638ED2 pkg YNIDISG last 19.06.2010
1887C38D1C3C6197 pkg YNIDT last 20.06.2010
1840901E064123B5 pkg YNIGFLL last 20.06.2010
18B851080E1C60E4 pkg YNIICRG last 20.06.2010
18BCE5B700600224 pkg YNIK200 last 19.06.2010
187D3A961FD76650 pkg YNIMPRG last 20.06.2010
1889F2F51A693206 pkg YNIMPRU last 19.06.2010
187E2F231C97D923 pkg YNIMTCH last 19.06.2010
1844FB1400C68C1F pkg YNINPRU last 19.06.2010
18AFA8E70FA31130 pkg YNINP01 last 18.06.2010
18AFAFAA10BA53D6 pkg YNINP02 last 18.06.2010
18B077DD11D7D78C pkg YNINP03 last 19.06.2010
18AFA8E80C3E6CA9 pkg YNIPACG last 19.06.2010
18AFA8EE10250EBA pkg YNIPAMG last 20.06.2010
18AFAFAC0338C378 pkg YNIPAMH last 17.06.2010
18AFA8EB18BBB3D3 pkg YNIPFLG last 19.06.2010
182D8C5317435639 pkg YNIPMU last 18.06.2010
18AFA8EB09F7E8B7 pkg YNIPOSG last 18.06.2010
18C1466915AD3E64 pkg YNIPOSG last 20.06.2010
18AFAFAD1713027E pkg YNIPOSH last 19.06.2010
18AFA8E205A2195F pkg YNIPOSU last 19.06.2010
18AFA8EB12E3EBC0 pkg YNIPOSX last 19.06.2010
18AFAFAF1463DB4A pkg YNIPOXL last 19.06.2010
18BFFF2506CC8ADA pkg YNIPPIR last 11.06.2010
18C1E8B70A064798 pkg YNIPPIR last 19.06.2010
18B191FB12D18310 pkg YNIPREG last 20.06.2010
1840455608335BF2 pkg YNIPROF last 20.06.2010
18B96B540C3DC0AE pkg YNIPTEG last 19.06.2010
18BA60E9119CB4D2 pkg YNIPTEU last 19.06.2010
1889F25814DFF5A5 pkg YNIPVSF last 20.06.2010
188A428813DE7966 pkg YNIRCI last 19.06.2010
1827E2931E37E37D pkg YNIREGG last 20.06.2010
18B197990EBF5DDA pkg YNIREPS last 20.06.2010
18AFA8EE154592A8 pkg YNIREST last 03.06.2010
18AFA8EF13C2A130 pkg YNITAGG last 19.06.2010
184045AF0062BBF8 pkg YNITDEG last 19.06.2010
18A4B00106D74ECC pkg YNITPAR last 20.06.2010
187C9C790E6A6F22 pkg YNITRHU last 19.06.2010
1884C20D16B4798F pkg YNITRXG last 20.06.2010
189A469B0336A9DC pkg YNITRXH last 19.06.2010
1884C2130D1C6E02 pkg YNITRXU last 19.06.2010
1887C2F309360E44 pkg YNITS last 19.06.2010
1841325C0DE21565 pkg YNIVSBG last 10.06.2010
1826C4C81235E96E pkg YNIXANL last 20.06.2010
18349E3119EA394E pkg YNIXGLT last 20.06.2010
184044BC09CF224E pkg YNIYTLG last 20.06.2010
1840404908B05F3A pkg YNIYTLU last 20.06.2010
18AFAFC41F860980 pkg YNI0131 last 18.06.2010
18AFAFC90F94E5EF pkg YNI0151 last 18.06.2010
189E0863123D38A4 pkg YNI0161 last 20.06.2010
18AFA8F3063E4246 pkg YNI0182 last 20.06.2010
189DF0DB0D8969C5 pkg YNI0221 last 20.06.2010
18AFAF44187ED388 pkg YNI0281 last 20.06.2010
189CC9800F3C3076 pkg YNI0294 last 20.06.2010
18AFAF4E04EE58C8 pkg YNI0321 last 16.06.2010
18AFAF4F1DCB0268 pkg YNI0322 last 20.06.2010
18AFAF520BD39840 pkg YNI0331 last 18.06.2010
18AFAF540EAECF64 pkg YNI0332 last 17.06.2010
18B991B4023304E0 pkg YNI0334 last 18.06.2010
18AFA8F00F010E3A pkg YNI0350 last 17.06.2010
18AFAF5D1B6107C4 pkg YNI0381 last 19.06.2010
18AFAF5F0DBD125C pkg YNI0382 last 18.06.2010
18B195650C4DF488 pkg YNI0384 last 20.06.2010
18AFAF620F178567 pkg YNI0385 last 10.06.2010
18AFA8F401D243E0 pkg YNI0402 last 20.06.2010
18AFAF6D027D0ED0 pkg YNI0403 last 20.06.2010
18B7FE881C42521D pkg YNI0411 last 20.06.2010
18B7FE971429D725 pkg YNI0701 last 18.06.2010
18B1DE5302D19C92 pkg YNI0702 last 18.06.2010
18BFB69812118BF8 pkg YNI0710 last 11.06.2010
18C26045050C6BF6 pkg YNI0710 last 19.06.2010
18BFB6910F475114 pkg YNI0712 last 11.06.2010
18C27DFB063BA34A pkg YNI0712 last 17.06.2010
18B6444E0831F4F8 pkg YNI1015 last 11.06.2010
18C1E86B0ED49844 pkg YNI1015 last 19.06.2010
18BCE5B11CE06572 pkg YNI2206 last 11.06.2010
18C13F5906B38A98 pkg YNI2206 last 19.06.2010
18B415791A4D2C06 pkg YNI56FL last 19.06.2010
18BBCBF517F2180A pkg YNI56SR last 17.06.2010
18BFDB8119B1D386 pkg YNI56SS last 11.06.2010
18C143AA13E41FDE pkg YNI56SS last 18.06.2010
18C46245142063E2 pkg YNI56SS last 19.06.2010
18B2832E113F8B82 pkg YNI56VI last 19.06.2010
18B64FF91B5A8320 pkg YNI601G last 19.06.2010
18B6444201966420 pkg YNI601U last 19.06.2010
1887C24A152A451C pkg YNI602G last 19.06.2010
1887C2480E8E5F3F pkg YNI602U last 19.06.2010
18B64447039E08C2 pkg YNI603G last 19.06.2010
18B6444D09FC3A02 pkg YNI603U last 19.06.2010
1887C250000A1C20 pkg YNI604G last 19.06.2010
1887C24B04A28F27 pkg YNI604U last 19.06.2010
188D8CD309B8CAEA pkg YNI605G last 03.06.2010
1887C2520B3C64AC pkg YNI605U last 19.06.2010
18B6444A1FE3A496 pkg YNI606G last 19.06.2010
1887C247144C34B4 pkg YNI608G last 20.06.2010
1887C250069520BB pkg YNI610G last 19.06.2010
188D90B218A42C10 pkg YNI612G last 19.06.2010
1887C27215BA33A7 pkg YNI612U last 19.06.2010
1887C24F133EC5BA pkg YNI613G last 19.06.2010
1887C2750619F00C pkg YNI613U last 19.06.2010
1887C252010532BA pkg YNI614G last 19.06.2010
1887C27A0232BCF8 pkg YNI614U last 19.06.2010
1887C25312FE30AD pkg YNI615G last 19.06.2010
18B6443510A8A213 pkg YNI617G last 19.06.2010
18B6443718642965 pkg YNI617U last 19.06.2010
18B644331547ED76 pkg YNI618G last 19.06.2010
18B644351366FB10 pkg YNI618U last 19.06.2010
18A827C305992AFC pkg YNI619G last 19.06.2010
1887C28D17BA15D2 pkg YNI619U last 19.06.2010
1887C291128880FA pkg YNI620U last 19.06.2010
18BE93BE18D4BE46 pkg YNI621G last 19.06.2010
18B325DD064F8A14 pkg YNI622G last 19.06.2010
18B325DE0662D94E pkg YNI622U last 19.06.2010
18BBA3FA1DA5F4CE pkg YNI640G last 19.06.2010
18B807741F738E60 pkg YNI660G last 19.06.2010
18BCDD040C468944 pkg YNI681G last 19.06.2010
18BCDD07062F4D44 pkg YNI682G last 19.06.2010
18BCDD091EBBA2AE pkg YNI683G last 19.06.2010
18B84909050814A8 pkg YNI8710 last 08.06.2010
18BB97060249C0C6 pkg YNI8730 last 19.06.2010
18B7595716BB6370 pkg YNJDB11 last 20.06.2010
18B7595807A99109 pkg YNJDB12 last 20.06.2010
18B622EF11B15E58 pkg YNJDB31 last 20.06.2010
18B622F804C0658C pkg YNJDB42 last 20.06.2010
18B622FF0C5DD566 pkg YNJDB45 last 20.06.2010
18B6188005882E9D pkg YNJDB46 last 20.06.2010
189B88D00D3C8533 pkg YNJ501 last 20.06.2010
189B88D10B5F3C18 pkg YNJ503 last 20.06.2010
1893D9ED1805D3C9 pkg YNLDIFF last 19.06.2010
18B52CC508529DF6 pkg YNLFRC last 11.06.2010
18B52CBE1CDDE3C2 pkg YNLF24 last 11.06.2010
187CEDB511DF05B0 pkg YNLG010 last 19.06.2010
187CEDBA0605A084 pkg YNLG020 last 19.06.2010
187CEDB51C62B922 pkg YNLG021 last 11.06.2010
187CEDB70935E7F6 pkg YNLG03M last 11.06.2010
187CEDB70BF576D4 pkg YNLG040 last 11.06.2010
18AFD4DA01603B7D pkg YNLG070 last 09.06.2010
187CEDB8106DCBE5 pkg YNLG120 last 19.06.2010
187CEDBF017253E7 pkg YNLG121 last 19.06.2010
187CEDB90D7F3FBF pkg YNLG130 last 19.06.2010
187CEDBC06C245B9 pkg YNLG140 last 19.06.2010
18B8229708DA2764 pkg YNLIVAT last 19.06.2010
18B52CD6090A32E8 pkg YNLM131 last 11.06.2010
18B52CE11AF23F2E pkg YNLOUT last 11.06.2010
18B52CF110668FE0 pkg YNLPRIO last 19.06.2010
187BCF7407EDF589 pkg YNLVATG last 18.06.2010
189A70361BCDFD0A pkg YNL0200 last 18.06.2010
188C6F8100FC519A pkg YNL0650 last 19.06.2010
18B6E42B10246510 pkg YNOAUFV last 18.06.2010
187C16790B640C09 pkg YNOBUWE last 19.06.2010
18B6E00F109907FF pkg YNO0034 last 18.06.2010
18545F351836EB03 pkg YNPT02M last 18.06.2010
184EADC111F986EE pkg YNP01MO last 18.06.2010
181AA87B02FC30B5 pkg YNT320A last 18.06.2010
18B1DB4716617840 pkg YNZADGE last 20.06.2010
18B616FA1C364594 pkg YNZCHCK last 18.06.2010
18415A64069169ED pkg YNZCOSC last 20.06.2010
1871E91F0CEC3CD6 pkg YNZDEAK last 18.06.2010
18A8C4E40A83D04C pkg YNZDETA last 18.06.2010
18B616F41CBC12FE pkg YNZDVPS last 18.06.2010
18397B970B7596E5 pkg YNZEMBE last 20.06.2010
181252980C2B0A71 pkg YNZERR last 18.06.2010
18BACC5F0443D808 pkg YNZFGIN last 31.05.2010
18C1E11F0D3F87D6 pkg YNZFGIN last 20.06.2010
18B645B112C1B9BF pkg YNZFWGV last 20.06.2010
18B616F30C041F10 pkg YNZGFM1 last 20.06.2010
18B4DBFB1F040DCA pkg YNZHIST last 20.06.2010
189C9F5D0E3C8DA4 pkg YNZISRT last 20.06.2010
18794AFE0DC5F925 pkg YNZKOM3 last 20.06.2010
18A6B85802BC9402 pkg YNZMQP last 20.06.2010
1812054B02B574C9 pkg YNZPARM last 20.06.2010
1884BC1E094F4788 pkg YNZSICI last 19.06.2010
18B616EF06458B40 pkg YNZSICO last 20.06.2010
18AAF9D300B4DFB8 pkg YNZSRVB last 20.06.2010
18AC87D50A622332 pkg YNZSRVO last 20.06.2010
18A9B64517DE3EA2 pkg YNZSSKK last 20.06.2010
18B616EB018D53AC pkg YNZSWFT last 02.06.2010
18A7CB43118E108B pkg YNZSWIB last 20.06.2010
18794B071CB8DA56 pkg YNZT310 last 20.06.2010
18B4DCC81B2F41A8 pkg YNZZAC2 last 20.06.2010
189CA7C402C4D08D pkg YNZZALI last 20.06.2010
188AE3F4178B27B2 pkg YNZZWPM last 20.06.2010
186E5142174547B8 pkg YNZZW01 last 19.06.2010
18B63C8F1066A320 pkg YNZZW02 last 20.06.2010
186E51460E3AE52C pkg YNZZW03 last 18.06.2010
188A6F3D083377F2 pkg YNZZW04 last 18.06.2010
186E51491C4D9619 pkg YNZZW06 last 19.06.2010
186E514B08BD96EE pkg YNZZW07 last 18.06.2010
186E514C1577B466 pkg YNZZW09 last 19.06.2010
186E514E0CC1A93E pkg YNZZW10 last 18.06.2010
186E514F107276A7 pkg YNZZW11 last 18.06.2010
186E51521A8E94BE pkg YNZZW13 last 18.06.2010
186E51550D3EBB22 pkg YNZZW14 last 18.06.2010
186E51561C14E8C6 pkg YNZZW15 last 18.06.2010
186E515816AB992A pkg YNZZW16 last 19.06.2010
18B63C8F1543AE79 pkg YNZZW20 last 19.06.2010
187E0AC306BAB3BC pkg YNZZW22 last 20.06.2010
18B63C901FF8599E pkg YNZZW25 last 18.06.2010
186E51660F1B766C pkg YNZZW30 last 20.06.2010
186E516702ADE9CE pkg YNZZW31 last 09.06.2010
18B63C91159320B6 pkg YNZZW38 last 20.06.2010
186E51730B8BB61E pkg YNZZW39 last 17.06.2010
186E51751920E0D6 pkg YNZZW41 last 18.06.2010
186E51791043B408 pkg YNZZW43 last 18.06.2010
186E517A13A6A9FA pkg YNZZW44 last 20.06.2010
186E518412F2EE32 pkg YNZZW45 last 18.06.2010
1889D02C17C1BF1C pkg YNZZW46 last 20.06.2010
18B63C921177B116 pkg YNZZW50 last 18.06.2010
186E51911547ACA4 pkg YNZZW56 last 18.06.2010
18A68F4E081CC592 pkg YNZZW57 last 19.06.2010
187213CE06375EC0 pkg YNZ0200 last 18.06.2010
1818F4B0177ADEFA pkg YOEADO last 20.06.2010
185597FE04C665F8 pkg YOEAURA last 20.06.2010
1826EE6017BF7BDA pkg YOEDEF last 20.06.2010
1818F2BA1C501C06 pkg YOEFIGP last 20.06.2010
1818757C09F15005 pkg YOEFTEK last 20.06.2010
1818F28F176B5EEB pkg YOEFTGP last 20.06.2010
1818F2BC17848C76 pkg YOEFTPR last 18.06.2010
182142C80E009978 pkg YOEFTSU last 19.06.2010
1818F2BE137EF19C pkg YOEHIGP last 20.06.2010
1826EEDD14AEA149 pkg YOELOGC last 13.06.2010
1818F22810DAA616 pkg YOEMAGP last 20.06.2010
181875650140BF25 pkg YOEMETA last 20.06.2010
181875681DD19E14 pkg YOEOEBP last 03.06.2010
1818F22A06FF4FC2 pkg YOEOEGP last 20.06.2010
1826EEE000B94CE9 pkg YOEP209 last 15.06.2010
1818756B1ACED5EA pkg YOESDB last 20.06.2010
1826EEE5073D543E pkg YOESUCH last 19.06.2010
1826EEE70D7A9C7F pkg YOESUH last 18.06.2010
1826EEE90D96DE18 pkg YOES150 last 18.06.2010
1826EEEB09CCD15C pkg YOES151 last 18.06.2010
1818756E127FC102 pkg YOES200 last 19.06.2010
1826EEEE149F79B6 pkg YOES208 last 18.06.2010
18187573044310A0 pkg YOES209 last 20.06.2010
1826EEF1161809EE pkg YOEU150 last 18.06.2010
1826EEF3143CDB25 pkg YOEU209 last 18.06.2010
185618610B19A45D pkg YOEZAMU last 15.06.2010
181D7CFB08CB7592 pkg YOEZAT last 20.06.2010
181875770D5720BE pkg YOEZSC last 20.06.2010
183F4C340D495B5E pkg YOE0610 last 20.06.2010
1818F29119210371 pkg YOE2ADN last 20.06.2010
1825D8660007FC65 pkg YOE2BU last 20.06.2010
1826EEF8019D48EF pkg YOE2CNT last 18.06.2010
1818F29502BFCB4A pkg YOE2FTA last 20.06.2010
1818F22D125FBBC8 pkg YOE2FTI last 20.06.2010
1818F2C019388CB4 pkg YOE2FTW last 20.06.2010
1818F2611D7A02C0 pkg YOE2GET last 20.06.2010
18191218004D1399 pkg YOE2HIE last 20.06.2010
181874C3039FCC83 pkg YOE2HIL last 20.06.2010
1826EEFC01A5326D pkg YOE2LOE last 18.06.2010
1818F2C21869232D pkg YOE2MTA last 20.06.2010
1818F26417A9D790 pkg YOE2SRC last 20.06.2010
18341C171C205B85 pkg YOE3FTA last 20.06.2010
181874CA1D5956A1 pkg YOE9ADN last 20.06.2010
1825D86C0539440E pkg YOE9BU last 20.06.2010
181874D115F72148 pkg YOE9GET last 20.06.2010
18B98D3409EA29E4 pkg YOOAIE3 last 20.06.2010
187E54F11804FB64 pkg YOOAIE4 last 20.06.2010
188E614D05093374 pkg YOOAIUE last 20.06.2010
18A65DE81361509E pkg YOOFOVE last 20.06.2010
1835B0C8164F4BEE pkg YOOTICH last 20.06.2010
18AB20D0121418AE pkg YOOTI9E last 20.06.2010
18812A3B007DB245 pkg YOOT005 last 20.06.2010
188378C11BF8D8DA pkg YOOT007 last 20.06.2010
188177940A8E5A9C pkg YOOT008 last 20.06.2010
18812A4901524E6A pkg YOOT012 last 20.06.2010
18812A4C0E34DA2B pkg YOOT018 last 18.06.2010
187E4981104784BB pkg YOOWMME last 20.06.2010
186A83ED0069E6C0 pkg YOOWPS last 20.06.2010
187E573910E3D1B5 pkg YOOX011 last 20.06.2010
1846395A02660FD6 pkg YOOX021 last 20.06.2010
1891F4111BAC4F3B pkg YOO0740 last 19.06.2010
18B66F320ABC7436 pkg YOO0770 last 20.06.2010
1834204616BC490B pkg YPCBUMA last 20.06.2010
183307AA01FDE950 pkg YPCCAEX last 20.06.2010
189FC4BF03066028 pkg YPCCAHI last 20.06.2010
18BCDFC9177CF2F6 pkg YPCCORI last 11.06.2010
18C2882E0957D592 pkg YPCCORI last 20.06.2010
18AC5ACC1DE75CD6 pkg YPCDURA last 20.06.2010
187DFD8B1C089BFC pkg YPCEQSR last 20.06.2010
187DFD8D1290E093 pkg YPCEQUS last 20.06.2010
187DFD931095EF03 pkg YPCFULO last 18.06.2010
187DFD9416D9014E pkg YPCFUNO last 20.06.2010
18C0544119E8947C pkg YPCGRUP last 19.06.2010
18741D32189C078F pkg YPCGRUP last 11.06.2010
183307B60139903E pkg YPCLIMI last 20.06.2010
18BB6DE702ADF77E pkg YPCLOCA last 20.06.2010
183307B70B8400B0 pkg YPCMD1 last 20.06.2010
183307B80A5290A8 pkg YPCNUFO last 19.06.2010
183307B91879A0CE pkg YPCONLO last 20.06.2010
187DFD961B44D1CA pkg YPCPROD last 20.06.2010
183307BE030C0F13 pkg YPCSPER last 20.06.2010
187DFD881056F998 pkg YPCSWHI last 19.06.2010
18B8289B1276CFDB pkg YPCTECH last 20.06.2010
18BB7694149C5CEC pkg YPC0500 last 11.06.2010
18C05584031FB386 pkg YPC0500 last 20.06.2010
18BB76950300B15A pkg YPC0510 last 20.06.2010
18BB76951ECD1610 pkg YPC0530 last 08.06.2010
18C0558410BD5484 pkg YPC0530 last 17.06.2010
18BB769700C61220 pkg YPC0550 last 15.06.2010
18BB76981BC1C186 pkg YPC0580 last 11.06.2010
18C0558505FF01EA pkg YPC0580 last 20.06.2010
18BB7699020590B0 pkg YPC0590 last 19.06.2010
18BB76991520BB40 pkg YPC0600 last 11.06.2010
18C055851A976A42 pkg YPC0600 last 15.06.2010
18BB769A0929C79C pkg YPC0610 last 11.06.2010
18C055851056EB9C pkg YPC0610 last 20.06.2010
18BB769A1E95B7E6 pkg YPC0620 last 19.06.2010
18BB769A1EA57CC0 pkg YPC0630 last 20.06.2010
18BB769B12288252 pkg YPC0640 last 26.05.2010
18BB769C17CA6A9C pkg YPC0650 last 11.06.2010
18C0558510CD988E pkg YPC0650 last 20.06.2010
18B994C203416EDA pkg YPC0670 last 20.06.2010
18BB769D07464C2E pkg YPC0680 last 11.06.2010
18C055860F33916A pkg YPC0680 last 20.06.2010
18BB769D03CF75D4 pkg YPC0690 last 11.06.2010
18C055861AF3FE0A pkg YPC0690 last 20.06.2010
18BB769E04FBE86E pkg YPC0710 last 11.06.2010
18C05587173C4702 pkg YPC0710 last 20.06.2010
18BB769F07AD8D48 pkg YPC0720 last 20.06.2010
18BB769F0E749EDE pkg YPC0730 last 11.06.2010
18C055871B032F8C pkg YPC0730 last 20.06.2010
18BB769F0FCF6422 pkg YPC0740 last 11.06.2010
18C054C91D6AEB96 pkg YPC0740 last 20.06.2010
18BB769F1755D3BA pkg YPC0750 last 20.06.2010
18BB76A0171CDE80 pkg YPC0760 last 11.06.2010
18C05588052F9278 pkg YPC0760 last 20.06.2010
18BB76A114153B40 pkg YPC0780 last 20.06.2010
18BB76A20A7F78B6 pkg YPC0790 last 11.06.2010
18C20484077DD33E pkg YPC0790 last 20.06.2010
18C300E617072706 pkg YPC0800 last 20.06.2010
18BB76A407C58E50 pkg YPC0810 last 20.06.2010
18BB76A600721CA8 pkg YPC0820 last 11.06.2010
18C05589096AF64C pkg YPC0820 last 20.06.2010
18BB76A608F882D2 pkg YPC0830 last 19.06.2010
18BB76A61B10DA1E pkg YPC0840 last 11.06.2010
18C055890F4FD35A pkg YPC0840 last 20.06.2010
18BB76A7095D7ADA pkg YPC0850 last 11.06.2010
18C0558916CA8002 pkg YPC0850 last 20.06.2010
18BB76AA156829FA pkg YPC0890 last 20.06.2010
18BD09360EAEAE38 pkg YPC1010 last 11.06.2010
18C0558B01D7D522 pkg YPC1010 last 20.06.2010
18BC60341138884A pkg YPC1020 last 10.06.2010
18C2050C19AF13C4 pkg YPC1020 last 18.06.2010
18BD023409070E0E pkg YPC1030 last 11.06.2010
18C288351A199F6C pkg YPC1030 last 20.06.2010
189BAE6B019C7CE4 pkg YPRADA last 19.06.2010
1871933F05AA301E pkg YPRAID last 18.06.2010
18B736F41F4FD4E4 pkg YPRDTXT last 19.06.2010
186E9BC213871102 pkg YPRIMAT last 20.06.2010
187193400699576E pkg YPRPEND last 18.06.2010
18719341039D8F86 pkg YPRREVE last 19.06.2010
186E9C870301F84E pkg YPRSUPM last 18.06.2010
18719343103F0D2E pkg YPR095I last 19.06.2010
184183FE1DB4FB20 pkg YPWGCTS last 19.06.2010
187A862A0FDFCD93 pkg YPWSAU5 last 15.06.2010
1889273213BD5840 pkg YPWSCQ5 last 18.06.2010
187A865008FFC3F7 pkg YPWSEQ5 last 19.06.2010
189B857D0C4E397E pkg YPWSEU5 last 18.06.2010
187A875D193BB9CD pkg YPWSIQ6 last 19.06.2010
187A878D14680546 pkg YPWSIU6 last 18.06.2010
187A87AE06972C95 pkg YPWSKQ5 last 19.06.2010
187A88080F0C6A2D pkg YPWSMQ5 last 19.06.2010
187A881E0EE48ED9 pkg YPWSMQ6 last 19.06.2010
187A88371E3F5323 pkg YPWSMU5 last 15.06.2010
187A90251B8A4BFA pkg YPWSMU6 last 15.06.2010
187AAFFD11D6A47E pkg YPWSPQ5 last 15.06.2010
188E89621A377F7C pkg YPWSTE5 last 19.06.2010
18490EDA1E2D8B37 pkg YPW2FST last 20.06.2010
187AB0B30223F2B4 pkg YPW2KAB last 20.06.2010
187AB0F51DD0A2C4 pkg YPW2KAF last 19.06.2010
187AB11B0C886E61 pkg YPW2KDV last 20.06.2010
187AB14E0AC00B7C pkg YPW2KEA last 20.06.2010
187AB176061F808A pkg YPW2KEB last 20.06.2010
187AB21718010DDE pkg YPW2KED last 20.06.2010
187AB5AE1FE19141 pkg YPW2KEI last 20.06.2010
187AB5C107332679 pkg YPW2KEP last 19.06.2010
187AB5D906B8CD46 pkg YPW2KFA last 20.06.2010
187AB5F00B9B4D73 pkg YPW2KFD last 20.06.2010
187ABA47118000CB pkg YPW2KFI last 20.06.2010
187AD7391D8FF21F pkg YPW2KIF last 20.06.2010
187AD8071F561FD1 pkg YPW2KKP last 20.06.2010
187AD82014823D13 pkg YPW2KMP last 20.06.2010
187AD848023F4B6A pkg YPW2KPI last 20.06.2010
187AD8530A4B79A0 pkg YPW2KPM last 20.06.2010
187AD8630E15B91A pkg YPW2KPS last 15.06.2010
187AD8841CCF5005 pkg YPW2KRP last 17.06.2010
187AD8931A79F8F3 pkg YPW2KSF last 18.06.2010
187AD8B505DC8011 pkg YPW2KTE last 20.06.2010
1867DD2F048C842B pkg YPW2REA last 17.06.2010
1845B654064C189D pkg YPXAKTI last 20.06.2010
1845B6571DA302FD pkg YPXDATE last 16.06.2010
1845B65910DEC7F9 pkg YPXINST last 16.06.2010
1845B65B06EF468A pkg YPXOEBP last 08.06.2010
187E543A0C5DE772 pkg YPXSTAU last 18.06.2010
187E55161AFBE71B pkg YPXSTPR last 20.06.2010
18589A131E4A552E pkg YPXUSER last 20.06.2010
185898120C04AE6B pkg YPXZULA last 20.06.2010
18545E4907E31A87 pkg YPX0381 last 09.06.2010
189E15431FE1AA83 pkg YRBRBK2 last 02.06.2010
189E32C7134B41A6 pkg YRBRBU1 last 01.06.2010
189E15430F73F05B pkg YRBRCS1 last 02.06.2010
1842C2040A955250 pkg YRBRMA1 last 02.06.2010
1842C2051603FEB9 pkg YRBRWS1 last 02.06.2010
189ED7A118544598 pkg YRBRXX1 last 02.06.2010
189FEE5D1101EC97 pkg YRBRXX2 last 02.06.2010
189EFCCB04BB5B4B pkg YRBRXX3 last 02.06.2010
189E15430714E89A pkg YRBRXX4 last 02.06.2010
1842C20E16BBC1FD pkg YRBRXX5 last 02.06.2010
189E154111BB3404 pkg YRBRXX6 last 02.06.2010
189ED6F200B52B56 pkg YRBRXX7 last 31.05.2010
1842C21309B4E258 pkg YRBUMA1 last 02.06.2010
18B4FCB91360E26C pkg YRBUXX1 last 04.06.2010
18B4FCB91AA618C0 pkg YRBUXY1 last 05.06.2010
186BA28C05CD5678 pkg YREM001 last 20.06.2010
189D245E0A95130E pkg YREM002 last 18.06.2010
186BA294010E33ED pkg YREM004 last 20.06.2010
18A3657C12723DC2 pkg YREM005 last 20.06.2010
186BA2D10BE6CEA5 pkg YREM202 last 07.06.2010
18794B3319D98DA6 pkg YRETOLP last 20.06.2010
186DD0671D709F19 pkg YREU200 last 20.06.2010
18A023491FD7F9D4 pkg YREU300 last 18.06.2010
18794B350990CA80 pkg YREZSUP last 20.06.2010
188B047D039AFF74 pkg YRFKDE last 07.06.2010
18B0E4F509F58E08 pkg YRMBAUM last 20.06.2010
18B847AC044A01B2 pkg YRMCGP last 20.06.2010
18B0E511162945A4 pkg YRMCIFP last 18.06.2010
18B52C89072159C3 pkg YRMFMNR last 20.06.2010
18B0E5170750D1C0 pkg YRMGGL last 20.06.2010
18B6EAC7094919B6 pkg YRMHOCH last 20.06.2010
188A14970F06232E pkg YRMINIT last 20.06.2010
18B0E51F1C028FAA pkg YRMKCG last 20.06.2010
18B1DF79083E27EE pkg YRMORGB last 20.06.2010
18B0E5020F07FA0C pkg YRMORGP last 20.06.2010
18B0E52D1C75BADC pkg YRMPEGE last 20.06.2010
18B0E5631391D328 pkg YRMREL last 20.06.2010
18264EA409F9D0A5 pkg YRMREL last 17.06.2010
18B0E56902347901 pkg YRMSTCI last 20.06.2010
18B162ED1B6D62B7 pkg YRMSTCS last 20.06.2010
18B162F50B0BD5A0 pkg YRMSTDE last 19.06.2010
18B162FC14CA4DA2 pkg YRMSTO last 20.06.2010
18B1630908EC3113 pkg YRMSTUB last 20.06.2010
18812A541EE89C5C pkg YRMT010 last 17.06.2010
18812A58191AB294 pkg YRMT017 last 18.06.2010
18812A5F066148DC pkg YRMT020 last 20.06.2010
18B1685B055126E0 pkg YRMT021 last 20.06.2010
18B16310162DC0DE pkg YRMVER last 20.06.2010
18B0E5081FDECC88 pkg YRMVUG last 20.06.2010
18B2AC6F1C1F36AE pkg YRM0620 last 20.06.2010
18B553831A1EBE86 pkg YRM064M last 18.06.2010
18B621CE0FCB3CA4 pkg YRM068B last 25.05.2010
18B621D01337D1D2 pkg YRM068U last 20.06.2010
18B8031F1E5D2185 pkg YRM068V last 20.06.2010
187EF5FA01B57C84 pkg YRM084S last 18.06.2010
18B0704013CBF194 pkg YRM1210 last 20.06.2010
18B070410A998C87 pkg YRM1211 last 18.06.2010
18B0704E05B82658 pkg YRM1212 last 18.06.2010
18B070410F0324E0 pkg YRM1213 last 20.06.2010
18B7FF6B1305B62A pkg YRM1214 last 20.06.2010
18BB6C300D5C68F0 pkg YRM1215 last 20.06.2010
18B070430A0598B4 pkg YRM1216 last 18.06.2010
18B2D11C0A841A0E pkg YRM1217 last 20.06.2010
18BA585517B3A990 pkg YRM1218 last 20.06.2010
18B54EDF0AE6318D pkg YRM1219 last 20.06.2010
18BAD06D0BEA42FC pkg YRM1221 last 20.06.2010
18B7FF370A92E302 pkg YRM1222 last 20.06.2010
18B2A2E4119FA20C pkg YRM1223 last 18.06.2010
18B2A2E504BBBBEA pkg YRM1224 last 27.05.2010
18B788CE1145D4DD pkg YRM1233 last 18.06.2010
188A13030430C1B0 pkg YRM1235 last 20.06.2010
18B070481F96B6B2 pkg YRM1255 last 20.06.2010
18B1631A0D73092C pkg YRM1257 last 20.06.2010
18B0704913AFF486 pkg YRM1399 last 20.06.2010
18B2A88107B46058 pkg YRM1452 last 20.06.2010
18B5536A087CE832 pkg YRM1821 last 18.06.2010
18B674B2131C61AC pkg YRM8220 last 20.06.2010
18B876DA19492AC0 pkg YRM9213 last 20.06.2010
18B2A882098EFBBE pkg YRM9452 last 20.06.2010
18214CC71FBCC7C0 pkg YRPBAUF last 20.06.2010
1820D6001D59767F pkg YRPMEXP last 20.06.2010
1818C705072C91FC pkg YRPMMNR last 20.06.2010
1818CB321A67A9E9 pkg YRPMVAL last 14.06.2010
18B2CC061123BEFE pkg YRPMWHG last 20.06.2010
18A7FA180ED18D4A pkg YRPNCAL last 20.06.2010
18A7FA19020EDA62 pkg YRPNFCK last 20.06.2010
18A7FA19179E0800 pkg YRPNIMP last 20.06.2010
189D199D1AC844CF pkg YRPNJRN last 18.06.2010
1871F06E0E80C0CE pkg YRPNPLN last 19.06.2010
18A7FA1A09834A06 pkg YRPNPVC last 10.06.2010
18C005FC1E469BD6 pkg YRPNPVC last 20.06.2010
18A7FA1B009B05C4 pkg YRPNVLB last 20.06.2010
18A2A2B81823BE0D pkg YRPNXAC last 19.06.2010
18221062117D4425 pkg YRPW131 last 18.06.2010
182210631ECBBE60 pkg YRPW132 last 18.06.2010
18221066061D684E pkg YRPW133 last 20.06.2010
182210690FC6FA77 pkg YRPW141 last 18.06.2010
1822106B02AFE8FF pkg YRPW142 last 14.06.2010
1822106C18C47C52 pkg YRPW143 last 18.06.2010
1822107112F89F15 pkg YRPW152 last 20.06.2010
1871EF331B3A4380 pkg YRPW171 last 19.06.2010
1871EF371049945A pkg YRPW172 last 20.06.2010
1871EF3D0819E0D6 pkg YRPW174 last 20.06.2010
18A6BA5415154099 pkg YRPW175 last 20.06.2010
1871EF44132B4BD4 pkg YRPW176 last 20.06.2010
186AE0C718816E2F pkg YRPW181 last 18.06.2010
1869699C02BD9415 pkg YRPXLCE last 20.06.2010
1893383604BFC990 pkg YRPXRUK last 19.06.2010
18AF36F0058769E2 pkg YRPXSEC last 10.06.2010
18BF3D620060673A pkg YRPXSEC last 20.06.2010
18C0D7590CA7BAC6 pkg YRQFLD1 last 20.06.2010
189525861854A0F8 pkg YRQFLD1 last 10.06.2010
183FCBF901D45D1A pkg YRQ011 last 20.06.2010
183FCBFD1BC78F9A pkg YRQ013 last 20.06.2010
1877EE5E0E433B10 pkg YRQ021 last 18.06.2010
1877EE5C0BE9A035 pkg YRQ022 last 20.06.2010
18C1464616D456E4 pkg YRQ023 last 20.06.2010
188811BA138FD5DC pkg YRQ023 last 10.06.2010
1877EE5C03DE6314 pkg YRQ024 last 20.06.2010
1877EE5D1A4B1A96 pkg YRQ025 last 20.06.2010
183310F50AE2CB3B pkg YRQ031 last 20.06.2010
183310F91DAC1CBE pkg YRQ032 last 18.06.2010
183310FC16F0D356 pkg YRQ033 last 18.06.2010
183310FF07708017 pkg YRQ034 last 20.06.2010
1833110512A28288 pkg YRQ036 last 09.06.2010
1842E8B3123FDAC5 pkg YRQ041 last 03.06.2010
18B2CC8B01570D30 pkg YRQ051 last 14.06.2010
18B2CBC71ADB231E pkg YRQ052 last 10.06.2010
18C144610F97D2CA pkg YRQ052 last 16.06.2010
18B2D5051E4460BB pkg YRQ053 last 20.06.2010
1842ECA602FC756E pkg YRQ061 last 20.06.2010
1842ECB2081CF5E7 pkg YRQ062 last 02.06.2010
1893D6FD1DC1FDB7 pkg YRQ064 last 19.06.2010
18A33C900D08CA2A pkg YRQ071 last 10.06.2010
18C075A70E8F11A4 pkg YRQ071 last 20.06.2010
1877EE59121FF49E pkg YRQ072 last 20.06.2010
1877EE590E0A6793 pkg YRQ073 last 20.06.2010
18A180310DDF09AD pkg YRQ074 last 03.06.2010
187C976915D81AAE pkg YRQ075 last 20.06.2010
1877EE59044C2E7E pkg YRQ076 last 20.06.2010
18814E020933B33C pkg YRQ081 last 19.06.2010
1871F43210DF89B5 pkg YRQ082 last 17.06.2010
18C029550A925916 pkg YRQ091 last 20.06.2010
1871F5C504DD1E14 pkg YRQ091 last 10.06.2010
18C029551C04E274 pkg YRQ092 last 20.06.2010
1871F5C709ED0ED8 pkg YRQ092 last 10.06.2010
18C029561F1A1884 pkg YRQ093 last 20.06.2010
1885AEEC02CE6EB5 pkg YRQ093 last 10.06.2010
18BD005F16FE0358 pkg YRQ101 last 17.06.2010
18C029590F740BD0 pkg YRQ111 last 18.06.2010
185504F80147D87C pkg YRQ111 last 10.06.2010
18C029350EB6A5C8 pkg YRQ131 last 18.06.2010
18332F500017ACC4 pkg YRQ131 last 10.06.2010
18C0294404546B9A pkg YRQ132 last 18.06.2010
18332F5206A637DC pkg YRQ132 last 10.06.2010
18C029460035E994 pkg YRQ133 last 20.06.2010
18332F540F1FDDD7 pkg YRQ133 last 10.06.2010
18C029461E0D0572 pkg YRQ141 last 18.06.2010
18332F91104DB438 pkg YRQ141 last 10.06.2010
18C0294810CEF31E pkg YRQ142 last 14.06.2010
18332F941FAC94CF pkg YRQ142 last 31.05.2010
18C029491F4E5F5A pkg YRQ143 last 18.06.2010
18332F98078B83F1 pkg YRQ143 last 10.06.2010
18332FC217D17782 pkg YRQ151 last 20.06.2010
18C029361CCAC5C8 pkg YRQ152 last 20.06.2010
18332FD305ED8246 pkg YRQ152 last 10.06.2010
1879BC3C1774C0F9 pkg YRQ171 last 19.06.2010
1879BC3F0500401F pkg YRQ174 last 20.06.2010
18A6BA461DF405C9 pkg YRQ175 last 20.06.2010
1879BC401CF5BA4E pkg YRQ176 last 20.06.2010
18C0294B1C08E6E8 pkg YRQ181 last 18.06.2010
186AE0C518FF5F12 pkg YRQ181 last 10.06.2010
185408E51BB55D03 pkg YRQ191 last 18.06.2010
185BEFD8061F2C72 pkg YRQ202 last 18.06.2010
188199320C71926A pkg YRQ211 last 10.06.2010
186B74A308B9D77B pkg YRQ213 last 17.06.2010
18C029501AAD9156 pkg YRQ221 last 17.06.2010
186A8F0607B1E95A pkg YRQ221 last 10.06.2010
18C0295108AB4B48 pkg YRQ231 last 18.06.2010
184BB91908F5796C pkg YRQ231 last 10.06.2010
18333587003664A2 pkg YRQ241 last 20.06.2010
188262C0015D8DF3 pkg YRQ251 last 20.06.2010
188199B31ACE237D pkg YRQ252 last 10.06.2010
187512A21ABB7E70 pkg YRQ261 last 18.06.2010
18A7FA1E15BC892A pkg YRQ271 last 20.06.2010
18A7FA1F06AC5EFE pkg YRQ272 last 10.06.2010
18C0295215EBD956 pkg YRQ272 last 18.06.2010
18B1DFFA057E5D27 pkg YRQ273 last 10.06.2010
18C029521ADE3530 pkg YRQ273 last 20.06.2010
184BB9BF0DF79783 pkg YRQ291 last 09.06.2010
186FE1B00E1A1286 pkg YRQ292 last 20.06.2010
1863C14202462B46 pkg YRQ301 last 20.06.2010
1867BB041069E886 pkg YRQ302 last 20.06.2010
1867DDAF1AF9474D pkg YRQ303 last 20.06.2010
18C20F651147C67C pkg YRQ311 last 19.06.2010
18C1E448123F3A9E pkg YRQ321 last 18.06.2010
18C1E457183FAF9A pkg YRQ331 last 18.06.2010
18B642C8053A0452 pkg YRVBOOK last 20.06.2010
18AF2D7B1770BD6D pkg YRVCURR last 20.06.2010
187DDD6A1573385F pkg YRVHSIP last 19.06.2010
189E0F780C4BE4FB pkg YRVINSL last 20.06.2010
18B642DD0146C242 pkg YRVOVDT last 19.06.2010
18B642F30C1EE516 pkg YRVPERF last 20.06.2010
189B5CA802602079 pkg YRVPSTN last 20.06.2010
187F3C890CA183C8 pkg YRVRATE last 20.06.2010
186DF9A018E8EDCE pkg YRVRND last 20.06.2010
18B39E4F013BA719 pkg YRVSEC last 20.06.2010
187DDD73123EA02A pkg YRVSTAT last 19.06.2010
1863EDBB03CE039D pkg YRVSYS last 20.06.2010
1894CFE40796CD4F pkg YRVTOOL last 20.06.2010
1863EDBE1521402D pkg YRVTRC last 20.06.2010
18B193C303F5E62E pkg YRVUNCP last 20.06.2010
187DDD831C7E11C5 pkg YRVUPOS last 20.06.2010
18B643021794F360 pkg YRVWOFF last 17.06.2010
1878CDA11DCBE000 pkg YSAFLOG last 20.06.2010
1878D5661504B9BA pkg YSAPART last 20.06.2010
186DCBAA044ED960 pkg YSAT001 last 19.06.2010
1879B8C313DA332B pkg YSAT004 last 19.06.2010
1879B8D81D9CC289 pkg YSAT005 last 10.06.2010
188FBA4809CAA1E3 pkg YSAT033 last 20.06.2010
1895651C0E7A7DC6 pkg YSAT037 last 20.06.2010
189560BA0AE34D8A pkg YSAT038 last 20.06.2010
186C3E3611A35A69 pkg YSAT039 last 20.06.2010
1878D6DC1F732CFC pkg YSAT045 last 18.06.2010
186C3E7F10AC817D pkg YSAT047 last 17.06.2010
1878D6F613F86AF1 pkg YSAT062 last 19.06.2010
188F75940AEE1F3D pkg YSAT063 last 20.06.2010
18B5EAFE08D98789 pkg YSAT065 last 18.06.2010
1878D6EB13DD8410 pkg YSAT066 last 18.06.2010
1878D6EE1FDB40C5 pkg YSAT067 last 18.06.2010
186C416F006BFEDD pkg YSAT081 last 20.06.2010
186C420109C37564 pkg YSAT082 last 11.06.2010
1879B92215454608 pkg YSAT087 last 20.06.2010
186C4209155CDF3B pkg YSAT089 last 20.06.2010
186C421205074C92 pkg YSAT090 last 20.06.2010
1878D70E1C168C91 pkg YSAT091 last 18.06.2010
1878D7161815DD10 pkg YSAT092 last 18.06.2010
1878D722152A1D73 pkg YSAT093 last 20.06.2010
1878D725119B9EFA pkg YSAT094 last 18.06.2010
1878D72C1EFC8529 pkg YSAT095 last 18.06.2010
1878D72E1B8412A9 pkg YSAT096 last 18.06.2010
186C42321E9CA35A pkg YSAT097 last 20.06.2010
1878D7301196E35E pkg YSAT099 last 20.06.2010
1878D76214752B25 pkg YSAT101 last 20.06.2010
1878D76602C78B30 pkg YSAT102 last 20.06.2010
1878D766171C35BF pkg YSAT103 last 20.06.2010
1878D76A02DC4B8E pkg YSAT104 last 20.06.2010
1878D76D1808ABEF pkg YSAT105 last 18.06.2010
186C42500EB9B277 pkg YSAT107 last 20.06.2010
1879CC6E15AAD1BA pkg YSA523B last 20.06.2010
1879CC8500D81D7E pkg YSA523C last 18.06.2010
18A65BD80F864200 pkg YSA523Z last 19.06.2010
188E3077024BDBE0 pkg YSBORES last 19.06.2010
188C793410FA2B3F pkg YSF0530 last 18.06.2010
187CC4FB184E915E pkg YSF0531 last 18.06.2010
1832DF8211D602CD pkg YSF0535 last 17.06.2010
18BDFA181AF9A002 pkg YSNA005 last 19.06.2010
18A90F250CB320E1 pkg YSNA008 last 19.06.2010
18B6EC6E06960C4A pkg YSNA012 last 19.06.2010
18AEBFC007E19B62 pkg YSNA016 last 19.06.2010
18B67361093A090A pkg YSNB011 last 19.06.2010
18A0720F0C0636DD pkg YSNB016 last 19.06.2010
189F504D0B6C5141 pkg YSNB020 last 19.06.2010
18B7134A1FEB8432 pkg YSNB021 last 02.06.2010
18A4ACC61F347528 pkg YSNB023 last 19.06.2010
189F5057145C8C71 pkg YSNB024 last 19.06.2010
18B18C0008789822 pkg YSNB025 last 19.06.2010
18B6E3C417C45586 pkg YSNB026 last 19.06.2010
18A8E5B103E62A9C pkg YSNB027 last 19.06.2010
18BCDA51017DBF76 pkg YSNB030 last 18.06.2010
18AE47F7049FC444 pkg YSNB032 last 19.06.2010
189F504911B89376 pkg YSND001 last 19.06.2010
189F50491C1CA1B1 pkg YSND003 last 19.06.2010
189F504812A2966C pkg YSND004 last 19.06.2010
189F50490199ACB8 pkg YSND005 last 19.06.2010
189F5054179739A5 pkg YSND007 last 18.06.2010
189F504A0735C26B pkg YSND008 last 18.06.2010
18BBE8E91128E88C pkg YSND011 last 18.06.2010
18A5ECDD0127E5A4 pkg YSND012 last 19.06.2010
189F504A0260CBAC pkg YSND014 last 19.06.2010
189F504C059E971A pkg YSND015 last 19.06.2010
189F504E064C0A74 pkg YSND017 last 03.06.2010
18B1E5BC073609EA pkg YSND050 last 19.06.2010
189F50441F0065B4 pkg YSNI001 last 19.06.2010
18A8005B1DA98294 pkg YSNI002 last 19.06.2010
18AE64540C8E9076 pkg YSNI003 last 16.06.2010
189F504811FBF934 pkg YSNI007 last 15.06.2010
189F50590744E0DB pkg YSN100I last 19.06.2010
189F50541E9F5B7D pkg YSN101I last 19.06.2010
189F50571CE4EBFC pkg YSN103I last 19.06.2010
189F505016E186C1 pkg YSN110I last 19.06.2010
189F505217C69730 pkg YSN111I last 19.06.2010
18BCDF0213358516 pkg YSN111L last 19.06.2010
18ACFDCD0B0C7EA9 pkg YSN113I last 19.06.2010
189F50561777EC64 pkg YSN120 last 20.06.2010
18A7FDA30A549BB0 pkg YSN131L last 15.06.2010
189C84A31F795587 pkg YSN132L last 03.06.2010
18B5753816DF98AD pkg YSN141L last 18.06.2010
18B6197C09734E66 pkg YSN142L last 19.06.2010
189C84A514274076 pkg YSN151L last 16.06.2010
18A554871BD7465E pkg YSN161L last 18.06.2010
18C118151220F24C pkg YSN161L last 18.06.2010
18BA7D3403BCC71C pkg YSN162L last 18.06.2010
18BFFE821B6CBEFE pkg YSN163L last 18.06.2010
18C117E415A71D1A pkg YSN163L last 18.06.2010
18AC14850CBDB32E pkg YSN171L last 18.06.2010
18A3640B12BAE8D6 pkg YSN173L last 18.06.2010
18A438781ADC1E92 pkg YSN175L last 18.06.2010
18B5F03810310179 pkg YSN176L last 18.06.2010
18BDA41E0A478BF0 pkg YSN177L last 18.06.2010
18B619801D65B17B pkg YSN177L last 11.06.2010
18C48D930011C5A4 pkg YSN177L last 18.06.2010
18B7824A069EE3F8 pkg YSN178L last 18.06.2010
189F505A0DDD0ED2 pkg YSN183I last 19.06.2010
189F50530943FF77 pkg YSN184I last 18.06.2010
189F50550DFFBB04 pkg YSN187I last 19.06.2010
18A131C91CF84A93 pkg YSN191L last 18.06.2010
18A910351EA2C57B pkg YSN192L last 18.06.2010
18AB42E6068B4996 pkg YSN193L last 18.06.2010
189F505C0F358C65 pkg YSN202I last 18.06.2010
18B3EF3D16B026F4 pkg YSN211L last 18.06.2010
18BD78EE13C46138 pkg YSN212L last 18.06.2010
18B6E9A71F2DF016 pkg YSN212L last 18.06.2010
18B6198111FDCAC6 pkg YSN221L last 18.06.2010
18B397F90C8B1A28 pkg YSN222L last 18.06.2010
18B619820A31A72D pkg YSN223L last 18.06.2010
18B78BA608E99326 pkg YSN231L last 19.06.2010
18C2575D1A2612A0 pkg YSN231L last 18.06.2010
18B78BD11A4CC0F0 pkg YSN232L last 19.06.2010
18C2575E0B6A4F52 pkg YSN232L last 18.06.2010
18B78C011ABF3FDA pkg YSN233L last 19.06.2010
18C2575E1601A1EA pkg YSN233L last 18.06.2010
18B8242F19122782 pkg YSULOGS last 11.06.2010
188A3FBF050504B2 pkg YSVADR last 14.06.2010
187853E31A0C4E80 pkg YSVANOG last 18.06.2010
188CA09D0590DB04 pkg YSVAUFR last 18.06.2010
187BF8F205F82996 pkg YSVAUSF last 18.06.2010
18A8A133125E77CA pkg YSVAUSG last 11.06.2010
18BFBF710A9B72CC pkg YSVAUSG last 18.06.2010
18B6523E01A39906 pkg YSVAUST last 18.06.2010
187A98F7104E528F pkg YSVAUS2 last 18.06.2010
18B6524115C2E4AC pkg YSVCIF last 19.06.2010
187853E705DA2F4D pkg YSVCIFG last 20.06.2010
1873D2FB0A468FE2 pkg YSVDBA last 19.06.2010
1873D3121C844D64 pkg YSVDBA1 last 19.06.2010
187AB0890E978CA0 pkg YSVDISC last 19.06.2010
18AF307F0EBE9E8E pkg YSVD096 last 20.06.2010
187D302E106213C6 pkg YSVEUPL last 18.06.2010
187D30ED17C8DBA9 pkg YSVEUTV last 19.06.2010
1894F1FE01303827 pkg YSVFISZ last 18.06.2010
187CF14F1108636E pkg YSVFLOG last 18.06.2010
188B396B10385215 pkg YSVFME1 last 18.06.2010
187427F10822557C pkg YSVFUNK last 19.06.2010
187D304008223655 pkg YSVGDAT last 28.05.2010
18A7ABA60EC2C118 pkg YSVGEAU last 18.06.2010
18AB217E0C4F750F pkg YSVGVR last 19.06.2010
184FF5911919F13E pkg YSVG502 last 19.06.2010
1872AD471D624F33 pkg YSVKUN last 20.06.2010
1871ED2D146D0A20 pkg YSVLAN last 18.06.2010
18B8295315996844 pkg YSVMUTE last 18.06.2010
18942D6C16EB996E pkg YSVNRER last 18.06.2010
18B50CAB0D9FE810 pkg YSVSALD last 18.06.2010
187DADBA0BD4ECE0 pkg YSVSPUT last 19.06.2010
1873CEBA01F8CA60 pkg YSVSTAM last 20.06.2010
187A95720C434051 pkg YSVSTEK last 18.06.2010
1874E7B61DD5D3DC pkg YSVSTEP last 19.06.2010
18B6182D0C4867BC pkg YSVSTK last 18.06.2010
18B5C9E40A735F59 pkg YSVSTOE last 18.06.2010
18A8A1341080A63C pkg YSVTAR last 19.06.2010
1874E92D08BA0434 pkg YSVTXOB last 18.06.2010
1874E93403797BC8 pkg YSVTXOG last 20.06.2010
1874E9AA1A4619EA pkg YSVTXOM last 19.06.2010
1865F62216007E54 pkg YSVUFVS last 19.06.2010
187BF50F0C87BBA0 pkg YSVVORD last 18.06.2010
188A401B0FD5E3D3 pkg YSVZAW last 20.06.2010
185130D2120469A5 pkg YSV022D last 04.06.2010
185130D518DDBB48 pkg YSV023D last 04.06.2010
18606FC612E2376E pkg YSV024D last 04.06.2010
185130DB0C45DEAD pkg YSV025D last 04.06.2010
1893B051055D565A pkg YSV101G last 18.06.2010
188B0E7D11918D48 pkg YSV122G last 19.06.2010
18B6524402DFB1D4 pkg YSV1251 last 19.06.2010
18B652461937B19C pkg YSV1252 last 19.06.2010
18B2D4691D2FA61D pkg YSV1254 last 18.06.2010
185BF1941C981114 pkg YSV130D last 19.06.2010
18A065F8000876E9 pkg YSV351D last 18.06.2010
18A06683198EA9AA pkg YSV352D last 18.06.2010
18A065FF0EF950C1 pkg YSV360D last 18.06.2010
18A066051252B935 pkg YSV361D last 18.06.2010
18A06608063E3870 pkg YSV362D last 18.06.2010
18B4D8AA029107EA pkg YSV363D last 18.06.2010
188B376601D9C646 pkg YSV490D last 19.06.2010
18A68D1F0F47DD0F pkg YSV491D last 19.06.2010
1894C7C91E979172 pkg YSV492D last 19.06.2010
18AC81EC157EE544 pkg YSV700D last 04.06.2010
18B2D70805820F44 pkg YSV710D last 04.06.2010
18AC823D12D64E97 pkg YSV720D last 04.06.2010
18AB404F0CC981DE pkg YSV721D last 04.06.2010
185130E8098EB93C pkg YSV722D last 04.06.2010
188B314F15838333 pkg YSV730D last 04.06.2010
188B316207CE2892 pkg YSV731D last 04.06.2010
18AB416313A5E2F0 pkg YSV95AG last 19.06.2010
18AB22E318CD38F0 pkg YSV95RF last 07.06.2010
18ACFB1618EB4EAB pkg YSV97RF last 15.06.2010
187DFDB30B0DD578 pkg YSWBENA last 18.06.2010
187DFDBA11994A24 pkg YSWDB2U last 20.06.2010
186D5EF51F64BB3E pkg YSWTGET last 18.06.2010
188D1B94043C811C pkg YSW101A last 18.06.2010
18B5EAF70D7EECA4 pkg YSXAANZ last 20.06.2010
189564A5115F99C3 pkg YSXAUID last 18.06.2010
18AE18AF06C274FC pkg YSXAUT last 20.06.2010
1885DB0D1CB01D35 pkg YSXKABE last 20.06.2010
186DCB5C1BF66CA3 pkg YSXOBP last 20.06.2010
18A6B1FA1FA0B5D9 pkg YSXPROK last 20.06.2010
18B5EAC419ABBE54 pkg YSXREAC last 20.06.2010
18B5EA6B09BB2AAC pkg YSXRELE last 11.06.2010
189560E11DAAEDAD pkg YSXSPEZ last 20.06.2010
18B5EA580D246BC0 pkg YSXSTOP last 20.06.2010
186DC7D00491B6B6 pkg YSXT001 last 18.06.2010
1879B9560558C79F pkg YSXT006 last 20.06.2010
18B5EA541526BDC1 pkg YSXT008 last 20.06.2010
186DCAE41B7D86A7 pkg YSXT009 last 20.06.2010
186DCAED12ED4725 pkg YSXT010 last 20.06.2010
18B98B75061F5A29 pkg YSXT013 last 19.06.2010
186DCB8B19A412CB pkg YSXT014 last 20.06.2010
186DCB170542C58B pkg YSXT016 last 20.06.2010
186DCB1F125A47FD pkg YSXT017 last 19.06.2010
186DCB2C1B6BC8A0 pkg YSXT018 last 20.06.2010
186DCB351CF84448 pkg YSXT019 last 20.06.2010
186DCB3F1FD8EF91 pkg YSXT020 last 20.06.2010
186DCB4517EF04C9 pkg YSXT021 last 19.06.2010
186DCB490CF303BA pkg YSXT022 last 20.06.2010
18B2FF651D24A234 pkg YSXT023 last 20.06.2010
1895648A10762DDC pkg YSXT024 last 20.06.2010
1878D5D509C6590B pkg YSXT027 last 20.06.2010
1886C6970974977F pkg YSXT028 last 19.06.2010
1878D5FC158384FE pkg YSXT029 last 20.06.2010
1878D5ED16D6BF55 pkg YSXT171 last 20.06.2010
1878D10600B88D94 pkg YSXT181 last 20.06.2010
1885DAE41F3BFDFA pkg YSX1312 last 20.06.2010
18B18CBF01E865D5 pkg YSX5108 last 20.06.2010
18B2FF7B1EB8519E pkg YSX7208 last 18.06.2010
18B1849F09CF8556 pkg YSX8108 last 20.06.2010
186C42B600A7FEE2 pkg YSX9045 last 11.06.2010
186D32FB0BDC352D pkg YTEF001 last 20.06.2010
186D33200736C8FC pkg YTEF002 last 20.06.2010
186D33C909EB6751 pkg YTEF003 last 18.06.2010
186D3446157E9D82 pkg YTEF005 last 20.06.2010
186D373C162DCEF8 pkg YTEF007 last 20.06.2010
186D375914577CA4 pkg YTEF008 last 20.06.2010
186D376B0ED2CD15 pkg YTEF009 last 20.06.2010
186D377C0A8D710E pkg YTEF010 last 18.06.2010
186D37CB19F6AB84 pkg YTEF011 last 19.06.2010
186D5EC1052C032B pkg YTEF012 last 19.06.2010
186D5F110E326874 pkg YTEF013 last 19.06.2010
186D5FC71748FBFC pkg YTEF014 last 19.06.2010
186D60061A3D3C7A pkg YTEF015 last 19.06.2010
186D60160D83B1AF pkg YTEF016 last 12.06.2010
186D603112771D06 pkg YTEF017 last 12.06.2010
186D605114EC404E pkg YTEF018 last 12.06.2010
186D60601EB92C2C pkg YTEF019 last 12.06.2010
186D60AA0394C4AA pkg YTEF020 last 20.06.2010
186D60C104F8CC84 pkg YTEF025 last 19.06.2010
186BA09714F6AC6E pkg YTEF026 last 20.06.2010
186BA074009F908F pkg YTEF027 last 19.06.2010
186B9BD7199CD80D pkg YTEF028 last 19.06.2010
186E4FA0112AAA02 pkg YTEF030 last 14.06.2010
186E76A20C01FBDA pkg YTEF031 last 19.06.2010
186E76A7017FAE28 pkg YTEF032 last 19.06.2010
1861161B1D056F7D pkg YTEF101 last 19.06.2010
186E9B1B0559988E pkg YTEF102 last 14.06.2010
186E9B000F591E89 pkg YTEF103 last 12.06.2010
186E9B0500C4643D pkg YTEF104 last 01.06.2010
1861161C12525860 pkg YTEF502 last 12.06.2010
18611620075F7545 pkg YTEF509 last 12.06.2010
186116211CE715D8 pkg YTEF510 last 19.06.2010
18BDFCD4069D0214 pkg YTGGCTT last 11.06.2010
18C23ABA12C5C12E pkg YTGGCTT last 20.06.2010
18B8211A0A453898 pkg YTNBOPH last 20.06.2010
18B820D8078A685A pkg YTNBOPP last 20.06.2010
1899279E158FE7E8 pkg YTNCHK last 20.06.2010
18A782BC117C8382 pkg YTNDEP last 20.06.2010
18B820B8092D4428 pkg YTNORD last 20.06.2010
18B820E300C89524 pkg YTNOTF last 19.06.2010
18B8208C12FDD8D4 pkg YTNPOS last 20.06.2010
18A782BC16F63452 pkg YTNSICH last 20.06.2010
187C24290B5C58CF pkg YTNTYPE last 20.06.2010
18B8207812A10438 pkg YTNUPD last 20.06.2010
189927801E2CAB2A pkg YTNWORD last 20.06.2010
18B8207310EFBA3C pkg YTNW100 last 20.06.2010
1899278C01164856 pkg YTNW120 last 19.06.2010
1899278103A203E4 pkg YTNW130 last 19.06.2010
18A7A14610CBB2EA pkg YTNW140 last 20.06.2010
189A92C113A6F9BC pkg YTNW150 last 20.06.2010
18A7A147111B2832 pkg YTNW170 last 20.06.2010
1899277C04E31EC1 pkg YTN0010 last 20.06.2010
18B820BA0C5AFAC4 pkg YTN0023 last 20.06.2010
18B820C5182A54FF pkg YTN0041 last 20.06.2010
18BDA0D60EB5A924 pkg YTN0055 last 20.06.2010
18BDA0D81D7D1C54 pkg YTN0065 last 20.06.2010
18BDA0DB18D7EF34 pkg YTN0075 last 18.06.2010
18BDC8270F98F042 pkg YTN0085 last 20.06.2010
18B820961515B4DA pkg YTN0101 last 20.06.2010
18B820941BE617D9 pkg YTN0104 last 20.06.2010
18BFDBCD0CEE3C0E pkg YTN0114 last 20.06.2010
18B845CF1449D022 pkg YTN0124 last 20.06.2010
18B845D010DB2784 pkg YTN0134 last 18.06.2010
18B845D11989FED3 pkg YTN0144 last 18.06.2010
18B8212112500306 pkg YTN0160 last 18.06.2010
18B820E504A45466 pkg YTN0161 last 19.06.2010
18B820EE188D3188 pkg YTN0170 last 20.06.2010
18B820CA18B0CF70 pkg YTN0180 last 18.06.2010
18BDA0E2138D567E pkg YTN0204 last 18.06.2010
18A7F84E1A94FD08 pkg YTN0210 last 18.06.2010
18B820C0169D0FD3 pkg YTN5012 last 19.06.2010
18B820F6131BD5E6 pkg YTN5013 last 19.06.2010
18AC32A51ACCE20E pkg YTPFLAG last 20.06.2010
18AC341509B1EAA6 pkg YTPOBS last 20.06.2010
18AC34150C454E5A pkg YTPRZ4 last 08.06.2010
18AC32981F218724 pkg YTPSTAT last 19.06.2010
18AC341513C1FCC7 pkg YTPTPS last 20.06.2010
181913031DAE7833 pkg YTRBUFI last 20.06.2010
187BF00B1E51199A pkg YTRCLMI last 19.06.2010
18A7CB51194147AC pkg YTRCONF last 20.06.2010
1886C7CC02308762 pkg YTRDISK last 20.06.2010
187C99DD158221C5 pkg YTREDBM last 18.06.2010
189F01E60BAC2A08 pkg YTREDB2 last 20.06.2010
1899851F1C1C99C9 pkg YTRHISG last 19.06.2010
189984BE1AF01810 pkg YTRHISP last 19.06.2010
187D09301CB2975C pkg YTRKTOB last 19.06.2010
1825A82A0CB8F624 pkg YTROEZI last 20.06.2010
187D093319DCB1B1 pkg YTRPROD last 15.06.2010
187BF01F0DF5728C pkg YTRZVF3 last 19.06.2010
186B2203097E2B34 pkg YTR061 last 18.06.2010
18A0E71407558423 pkg YTZPOSN last 19.06.2010
187C4B4C0A4B08D0 pkg YTZPRCN last 20.06.2010
18AB17FC0742E467 pkg YUIAUTH last 20.06.2010
18A38C310049CAC5 pkg YUIJ100 last 20.06.2010
18A38C4503EBE81A pkg YUIJ200 last 20.06.2010
18A38C480EFF2737 pkg YUIJ300 last 20.06.2010
18A38C4B01F28260 pkg YUIJ410 last 20.06.2010
18568EDC0866FB08 pkg YUIJ420 last 20.06.2010
18A38C4F0EA0CC21 pkg YUIJ431 last 16.06.2010
18510BF502155BB0 pkg YUITRA last 20.06.2010
18A38C540AC54566 pkg YUI51AB last 20.06.2010
18A38C5602C93ADF pkg YUI51BB last 18.06.2010
186EEAF715098668 pkg YUUDAT last 01.06.2010
186B23BD00813A6A pkg YUUFALL last 19.06.2010
18B505D818CA3B9C pkg YUUGET last 20.06.2010
18B786F2058C5F14 pkg YUUG700 last 19.06.2010
18B786E405455976 pkg YUURSDF last 20.06.2010
18B506CE0CCB88AC pkg YUUSRCH last 20.06.2010
18BFB240002E6590 pkg YUUTOOL last 20.06.2010
187C8E8518FB3A2F pkg YUU1001 last 20.06.2010
1871BA5B0AC1016E pkg YUU1002 last 19.06.2010
1871BA5F021547F4 pkg YUU1003 last 20.06.2010
1871BA6305B8CD47 pkg YUU1004 last 20.06.2010
1871C07C164AE467 pkg YUU1005 last 18.06.2010
187BAA2D138EFAE4 pkg YUU1006 last 20.06.2010
18BFB263068E2E4C pkg YUU1009 last 20.06.2010
18BFB2640AE0447A pkg YUU1010 last 20.06.2010
18B18F6F17F7E571 pkg YUU1011 last 19.06.2010
18AD04C21240001A pkg YUU1012 last 20.06.2010
1871BA72149F6309 pkg YUU1013 last 20.06.2010
186B22BD1DD98AAD pkg YUU1015 last 20.06.2010
187329ED0014E3E5 pkg YUU1016 last 20.06.2010
1871BA761EDB2553 pkg YUU1017 last 20.06.2010
1871BA790D46C2F4 pkg YUU1018 last 18.06.2010
1871BA7D071A076F pkg YUU1019 last 18.06.2010
1872FD0501EE8DD1 pkg YUU1022 last 19.06.2010
1871BA810BB47593 pkg YUU1023 last 20.06.2010
18B786CF1BB9AF6A pkg YUU1024 last 20.06.2010
187BAA2F0529DB2F pkg YUU1027 last 20.06.2010
188D631B0FCF3D92 pkg YUU1028 last 20.06.2010
188D63250D4E4296 pkg YUU1032 last 20.06.2010
1871BB0F152CFA7F pkg YUU1033 last 20.06.2010
1871BB13190C26EE pkg YUU1034 last 18.06.2010
1871BB16186CA073 pkg YUU2001 last 20.06.2010
187BAA2901314A58 pkg YUU2002 last 20.06.2010
1871BB1C1810811D pkg YUU2003 last 20.06.2010
1871BB200CED85A8 pkg YUU2006 last 20.06.2010
1871BB2619745861 pkg YUU2008 last 20.06.2010
1871BB290C26B352 pkg YUU2009 last 20.06.2010
1871BB2C16E170ED pkg YUU2011 last 20.06.2010
1871BB2F0DC76B4D pkg YUU2012 last 20.06.2010
1871BB3200D187F6 pkg YUU2013 last 20.06.2010
1871BB340CB4CFD5 pkg YUU3001 last 20.06.2010
188A66EB01A1B36C pkg YVDCR12 last 20.06.2010
1878AB1D1BE683A4 pkg YVDDFA last 20.06.2010
18B4DB0112D42A78 pkg YVDFMEM last 20.06.2010
18B4DE24018347FF pkg YVDLIEF last 20.06.2010
18A7CE7C121F9756 pkg YVDRES last 20.06.2010
18A7CF0E07C85D22 pkg YVDTIME last 20.06.2010
18B4DEA106361FB2 pkg YVD0742 last 20.06.2010
18B7F9F90B62F5E8 pkg YVKFIGP last 19.06.2010
1839CB8F18123396 pkg YVKFIGS last 19.06.2010
18B6E63810E9EE43 pkg YVKMDF last 20.06.2010
18B7F9FC08FBFC7C pkg YVKP6CM last 19.06.2010
18B4D69D1125A758 pkg YVPAUTH last 20.06.2010
1850EA921DC7EB74 pkg YVPM020 last 18.06.2010
1850EA9417D8971A pkg YVPM023 last 18.06.2010
1850EA98093848B4 pkg YVPM199 last 20.06.2010
1850EA9C00503D16 pkg YVPT020 last 20.06.2010
1850EA9D14A0D0F6 pkg YVPT023 last 20.06.2010
1850EAA203B0EA18 pkg YVPT520 last 20.06.2010
18B4D6AA1A8D3072 pkg YVP0300 last 20.06.2010
188EA1CE1236F53D pkg YVP0301 last 18.06.2010
18B4D6AE15B750BE pkg YVP0302 last 20.06.2010
18B4D6B41E188E72 pkg YVP0303 last 20.06.2010
18B4F975142E4B1D pkg YVP0304 last 03.06.2010
188EA1CE1563C23C pkg YVP0305 last 17.06.2010
18B4D6B91FBAFC3C pkg YVP0306 last 19.06.2010
188EA1CE0E6AB0D2 pkg YVP0307 last 18.06.2010
18B4D6C71999EAD4 pkg YVP0308 last 18.06.2010
18B4F9A003A587E9 pkg YVP0311 last 18.06.2010
18B4D6CD0FE9EEC8 pkg YVP0312 last 15.06.2010
18B4D6D1097E44AE pkg YVP0313 last 18.06.2010
187F4288146177E9 pkg YVP0318 last 18.06.2010
18B4D6D913CF8CD4 pkg YVP0321 last 08.06.2010
18B4D6DD095540C0 pkg YVP0322 last 15.06.2010
18B4D6E115A2B6F6 pkg YVP0336 last 18.06.2010
18B4D6E502BDCDF8 pkg YVP0337 last 18.06.2010
188EA1CE11FF923D pkg YVP0339 last 18.06.2010
18ADA56B08455942 pkg YVVCSFE last 20.06.2010
187D10480E3FB599 pkg YVVPLIE last 20.06.2010
187D10480EF0BCD9 pkg YVVPSPE last 18.06.2010
189A9C1705A49660 pkg YVVPTSE last 20.06.2010
187D104D0E3B9F91 pkg YVVPTXE last 20.06.2010
187D104E0BC7EDFA pkg YVVPVFE last 20.06.2010
189A9C22109FBBF0 pkg YVVPVRE last 20.06.2010
187D104E0994CD21 pkg YVVPVWE last 20.06.2010
18B782D5003F8D4B pkg YVVRALL last 20.06.2010
187DB08E09500B9A pkg YVVSLAE last 18.06.2010
187DB0890AF67838 pkg YVVSLBE last 20.06.2010
187DB09305B9AB28 pkg YVVSLIE last 18.06.2010
187DB09319530BAA pkg YVVSLLE last 18.06.2010
187DB08D0ED597F9 pkg YVVSLSE last 18.06.2010
187DB09409BFCF60 pkg YVVSLTA last 18.06.2010
1893310A02928223 pkg YVVSLTE last 20.06.2010
189330461D9FABAE pkg YVVSLVA last 18.06.2010
187DB09102581FCE pkg YVVSLVB last 14.06.2010
187DB097187AAF4C pkg YVVSLVE last 18.06.2010
18B990391D20F202 pkg YVVSQLE last 20.06.2010
18A7CE8C0705B3BC pkg YVVZZAR last 19.06.2010
18A7CE8D15E525DC pkg YVVZZNR last 19.06.2010
18A7CE8218D483F0 pkg YVVZZQR last 19.06.2010
18BB77F5194FAC72 pkg YVVZZ04 last 20.06.2010
18BC667A06DE72F8 pkg YVVZZ05 last 20.06.2010
18AB16C9127311BA pkg YVVZZ07 last 19.06.2010
18A7CE7E0B4037B8 pkg YVVZZ08 last 02.06.2010
18A7CE790F2A0168 pkg YVVZZ10 last 19.06.2010
18A7CE85103A889C pkg YVVZZ11 last 20.06.2010
18AB16CC06503A7A pkg YVVZZ12 last 20.06.2010
18A8C0A318E871F2 pkg YVVZZ13 last 20.06.2010
18A7CE7A113226C4 pkg YVVZZ14 last 20.06.2010
18A7CE8807236682 pkg YVVZZ15 last 20.06.2010
18AB16CC12400408 pkg YVVZZ16 last 19.06.2010
18A7CE73123DC7C6 pkg YVVZZ17 last 19.06.2010
18B18D15069DF928 pkg YVVZZ19 last 19.06.2010
18AB16D016BB2180 pkg YVVZZ20 last 19.06.2010
18A7CE841D00B756 pkg YVVZZ23 last 19.06.2010
18A7CE810B562A30 pkg YVVZZ24 last 18.06.2010
18A7CE6B10FD178A pkg YVVZZ25 last 19.06.2010
18AB16D311A9421A pkg YVVZZ28 last 19.06.2010
18AB16D319B6536D pkg YVVZZ29 last 19.06.2010
18A7CE841C8756AD pkg YVVZZ3R last 20.06.2010
18A7CE7D1BA8F4EF pkg YVVZZ31 last 19.06.2010
18A7CE771D04BB8E pkg YVVZZ32 last 18.06.2010
18AB16D41385C90E pkg YVVZZ33 last 19.06.2010
18B9901C0847F30A pkg YVV3000 last 20.06.2010
189A9BA908CD8044 pkg YVV3210 last 20.06.2010
18A7A4190A6CFA30 pkg YVV3240 last 20.06.2010
18B9901D09C85EB6 pkg YVV3250 last 18.06.2010
18B9901E0AFF7A54 pkg YVV3260 last 20.06.2010
18B9901F0A2CDE3C pkg YVV3300 last 20.06.2010
18A829570F427399 pkg YWADERB last 16.06.2010
18A82953020302D2 pkg YWAGAD last 20.06.2010
18B825841428C318 pkg YWAGENV last 20.06.2010
18BACAD91CA73800 pkg YWAGETA last 18.06.2010
187CEC7C128E3176 pkg YWAGE01 last 11.06.2010
18B992CB13992146 pkg YWAGVP last 18.06.2010
18BDC6781AA48544 pkg YWAHMUE last 11.06.2010
18C114EC0E4207A4 pkg YWAHMUE last 18.06.2010
18C00660149A80B0 pkg YWAPCUR last 19.06.2010
18A829650B8E4C74 pkg YWAPDEL last 18.06.2010
18B850C70CF15312 pkg YWAPGET last 20.06.2010
18B93B6C1C4D62B9 pkg YWAPHAS last 19.06.2010
18A8297216D2E49A pkg YWAPINS last 20.06.2010
18A8EA1003D6844E pkg YWAPK18 last 19.06.2010
18A829661B05ABE4 pkg YWAPREP last 20.06.2010
18A8295A00065A9B pkg YWAP91P last 02.06.2010
18B2F5BD1C7ADEF6 pkg YWAREFE last 19.06.2010
18A829720A2D9EB9 pkg YWAREPT last 20.06.2010
18A829721A9AB916 pkg YWASE01 last 04.06.2010
18B93BFA17FF929A pkg YWAVSTE last 20.06.2010
188EAE3A086F9E1B pkg YWAVTXT last 18.06.2010
18A8C0F61E2B917A pkg YWAWBU last 20.06.2010
18B8259209760A1A pkg YWAWERT last 20.06.2010
18B8218F1AEA73EA pkg YWBAPI last 19.06.2010
18B86F7108DBC15E pkg YWBBIS last 20.06.2010
18B820511E51B060 pkg YWBBODA last 20.06.2010
18C02A601D10BAC6 pkg YWBBOPN last 20.06.2010
18BFD29B1E32CF4A pkg YWBBOPR last 20.06.2010
18B870140336D3D6 pkg YWBBOPR last 12.06.2010
18AB162A08C75990 pkg YWBBT last 20.06.2010
18B820301699D11B pkg YWBBTO last 20.06.2010
18B81FA01A55F0A9 pkg YWBBU last 20.06.2010
18A7C8A005832F0F pkg YWBCHAN last 20.06.2010
18B81FD7036F57EA pkg YWBCIRP last 20.06.2010
18BB6C0C0B186164 pkg YWBCRTL last 20.06.2010
18B8203B1F40896A pkg YWBCTA last 18.06.2010
18B820210375647F pkg YWBDEP last 20.06.2010
18B8203403B13BF0 pkg YWBDEPV last 18.06.2010
18A7C8921F4E8771 pkg YWBDGP last 18.06.2010
18BA588F167F7078 pkg YWBDYN last 20.06.2010
18A7C8810F912AF9 pkg YWBECK last 20.06.2010
18997F80112AD041 pkg YWBERA last 18.06.2010
18A7A0A005775438 pkg YWBERR last 20.06.2010
18B81FD70371F7E8 pkg YWBEXC last 20.06.2010
18BD011C036E1D42 pkg YWBGENX last 12.06.2010
18C257D901A6EC74 pkg YWBGENX last 16.06.2010
18C461FA145A1E5A pkg YWBGENX last 20.06.2010
18A7C8730C827ECB pkg YWBHAKR last 20.06.2010
18B81FDB00FE33A2 pkg YWBHKN last 20.06.2010
18A7C8681052E058 pkg YWBHOLI last 20.06.2010
18B81FDE0C8C82CE pkg YWBIO last 20.06.2010
18B81FD91469B284 pkg YWBITER last 18.06.2010
18B8203D1D477038 pkg YWBKOM last 18.06.2010
18A7C8A91FFEEF58 pkg YWBKZV last 19.06.2010
18B8460111C54BA6 pkg YWBLIST last 20.06.2010
18B8203F10FAA8D2 pkg YWBMAKU last 20.06.2010
18A8E61303560E94 pkg YWBMAN last 20.06.2010
18B823311378FCE6 pkg YWBMAPP last 20.06.2010
18A7C8AB1E059F36 pkg YWBMAS last 19.06.2010
18BB6FA902FE4892 pkg YWBMOD last 19.06.2010
18AC301915E60AE3 pkg YWBMON last 20.06.2010
18B939311728F13E pkg YWBMO1 last 20.06.2010
18A7C8A715A1AB48 pkg YWBMO2 last 20.06.2010
18A7C86E1EADBDF5 pkg YWBMO3 last 19.06.2010
18B86F781B986DE6 pkg YWBNEU last 18.06.2010
18B8208B18B5E802 pkg YWBN100 last 20.06.2010
18A7A1BC0DDBCD71 pkg YWBN140 last 20.06.2010
18A7A1B503973A62 pkg YWBN150 last 20.06.2010
18B845E70EF461B2 pkg YWBN170 last 20.06.2010
18A7C8A91E279A97 pkg YWBORDL last 20.06.2010
18B8203B0B4E19E1 pkg YWBORTA last 20.06.2010
18B81FF115095E48 pkg YWBPAM last 18.06.2010
18B81FEE0198C333 pkg YWBPAQ last 24.05.2010
18A7C88C0ED8A8AB pkg YWBPRST last 20.06.2010
18B81FA201E576F8 pkg YWBRA last 28.05.2010
1851A82010C34DA2 pkg YWBRULE last 20.06.2010
18A7C8B3075283C9 pkg YWBSAT last 19.06.2010
18B8201212A762B0 pkg YWBSA2 last 18.06.2010
18A7C8B908BA1C59 pkg YWBSUM last 18.06.2010
1881967015D7E4AC pkg YWBSYM last 19.06.2010
18A7C8E50325148C pkg YWBTAHU last 20.06.2010
18BB6DFD08B0A98C pkg YWBTRGR last 20.06.2010
18B86FD517B32388 pkg YWBTRSI last 20.06.2010
18B820181220A912 pkg YWBVIR last 19.06.2010
187BF6000EB02AB4 pkg YWBVU last 18.06.2010
18A56F180D7716F4 pkg YWBV165 last 20.06.2010
18A56F190F5A9D7C pkg YWBV166 last 18.06.2010
188A18EC0A3B7BEA pkg YWBV173 last 19.06.2010
187BF600172D666E pkg YWBWEI last 20.06.2010
18B8204E1611F354 pkg YWBWRK last 18.06.2010
18B81FC60E468DA7 pkg YWB0309 last 17.06.2010
18B8206A162E0E6A pkg YWB031H last 18.06.2010
18B82062054CEB46 pkg YWB0491 last 18.06.2010
18A7A1AD19EA81EB pkg YWB0492 last 18.06.2010
18B8200900A61804 pkg YWB203 last 18.06.2010
18A7A0700D8846C2 pkg YWB207 last 20.06.2010
1863EE8A1CD328A9 pkg YWB208 last 20.06.2010
18B8233607EAD9E0 pkg YWB210 last 18.06.2010
18A9DA3B0410F6BE pkg YWB219 last 18.06.2010
18B8207C09F45435 pkg YWB263 last 20.06.2010
18B820020453F323 pkg YWB40H last 18.06.2010
18B81FF918F64CB4 pkg YWB40M last 18.06.2010
18BA589617545434 pkg YWB530 last 19.06.2010
18BA588E1C59DC82 pkg YWB532 last 19.06.2010
18A7C8D819DC83D2 pkg YWB533 last 20.06.2010
18B8202F08CA6C2C pkg YWB543 last 20.06.2010
18B81FC6063CF276 pkg YWB550 last 20.06.2010
18B81FD00CE6BED0 pkg YWB551 last 20.06.2010
18A7C8DA1EBC7962 pkg YWB553 last 20.06.2010
18A7C8D610241B3E pkg YWB554 last 20.06.2010
18B82178065CCE74 pkg YWB74GB last 19.06.2010
186077A004C55021 pkg YWB74VA last 19.06.2010
18A0EA62199EA48B pkg YWB74VB last 19.06.2010
18B8219B12839396 pkg YWB74VK last 19.06.2010
18B8216B10C085A0 pkg YWB74VS last 19.06.2010
186077950BCDA8FD pkg YWB74V5 last 19.06.2010
18A598AE0776AB54 pkg YWB74ZV last 19.06.2010
18B8218511FD3849 pkg YWC0101 last 18.06.2010
18B821771E410D5C pkg YWC0102 last 18.06.2010
18B821A107551B56 pkg YWC0103 last 18.06.2010
18B82199189A022E pkg YWC0106 last 09.06.2010
18A7C8DB1416446E pkg YWC0240 last 20.06.2010
188DB2D409C91EFD pkg YWDAPST last 20.06.2010
18B7358919833E26 pkg YWFAAUF last 19.06.2010
18BBC088127B86B6 pkg YWFAERS last 19.06.2010
185099E71FEF3162 pkg YWFBOSN last 20.06.2010
1834267A109FDB44 pkg YWFCAID last 18.06.2010
186C6967037B6852 pkg YWFCARR last 18.06.2010
188677EE0E1D2C26 pkg YWFCB02 last 20.06.2010
185099FC07DE42FA pkg YWFFNFA last 12.06.2010
18509A001E01854B pkg YWFLINK last 19.06.2010
1834275B0E746DD0 pkg YWFLKST last 19.06.2010
18509A0403D4F587 pkg YWFLNKI last 19.06.2010
18BBC0930601BD30 pkg YWFM537 last 20.06.2010
18BBC0A61DCBF02C pkg YWFM548 last 20.06.2010
18B81EAF0FDB3E52 pkg YWFM910 last 19.06.2010
1860483603EC6B72 pkg YWFPAGA last 19.06.2010
18723E8D09A5C07C pkg YWFPRFE last 18.06.2010
186F650D13C3A400 pkg YWFQUAL last 18.06.2010
18A3665B0E69E25C pkg YWFRHAN last 20.06.2010
189BB06E0965E552 pkg YWFROUT last 20.06.2010
188CA3B212D939A7 pkg YWFSEND last 20.06.2010
18BB4BD30CF4F4BC pkg YWFSWCE last 11.06.2010
18C140B91158C5B0 pkg YWFSWCE last 19.06.2010
1863C3D800B7CAED pkg YWFSWIE last 20.06.2010
18B81EAB01E565DC pkg YWFSWMT last 19.06.2010
183427D20B81F111 pkg YWFSWSI last 19.06.2010
186230FE0F02FDCF pkg YWF28ST last 20.06.2010
18BBC09C1BFDFF52 pkg YWF64CE last 19.06.2010
18BD81B10225DBC8 pkg YWF98CE last 11.06.2010
18C0F4EC00C424D8 pkg YWF98CE last 18.06.2010
18B16DA115EA2E40 pkg YWIABV last 20.06.2010
18A7FA0815154102 pkg YWIABV3 last 20.06.2010
18A7F9850A00CCBB pkg YWIACW1 last 18.06.2010
18A7FA0F10CE39DC pkg YWIADS last 18.06.2010
187CBA311682DD82 pkg YWIAFAM last 18.06.2010
18AAF0941ACFAFB8 pkg YWIANPF last 18.06.2010
187CC0741E63B02A pkg YWIAORT last 20.06.2010
18A7F3A30D90B39E pkg YWIAOTX last 20.06.2010
18A7F9860640A56E pkg YWIAOT2 last 18.06.2010
18A81BB71E7B0A2A pkg YWIAOT3 last 20.06.2010
18B96C6904CFD6C0 pkg YWIAS01 last 19.06.2010
18B96C690ED65CA0 pkg YWIAS02 last 18.06.2010
18B96C6A0A29DA02 pkg YWIAS03 last 19.06.2010
18B96C6A1DB0332A pkg YWIAS04 last 18.06.2010
18B96C6B11A30904 pkg YWIAS05 last 09.06.2010
18B96C6C05CE8FBA pkg YWIAS06 last 18.06.2010
18B96C6C17EE18C4 pkg YWIAS07 last 19.06.2010
18B96C6D1121A630 pkg YWIAS08 last 19.06.2010
18B96C6E020E3876 pkg YWIAS09 last 19.06.2010
18B96C6E0E6E46E8 pkg YWIAS10 last 19.06.2010
18A7F986155C4578 pkg YWIAWD last 19.06.2010
18A7F98704F40194 pkg YWIAWD2 last 20.06.2010
18A7F987107828EE pkg YWIAWI last 20.06.2010
187CC10F1456135F pkg YWIDBM last 19.06.2010
187CC12714B309E4 pkg YWIDIT last 20.06.2010
18A7D579041E8682 pkg YWIDOC last 19.06.2010
188831281B2D0206 pkg YWIDPSA last 20.06.2010
18BC67DE020099A2 pkg YWIDRU last 19.06.2010
188BF54215E99A8A pkg YWIDRUB last 19.06.2010
18B96C040B4DB1DC pkg YWIEGMS last 08.06.2010
18BC67C41F585D1A pkg YWIEKEY last 19.06.2010
18B8010418DA9478 pkg YWIESOQ last 19.06.2010
187CC1DB1A9FE155 pkg YWIFAB last 20.06.2010
186EF10202CBCD0F pkg YWIFAM last 20.06.2010
187CC219146D1638 pkg YWIFAX last 19.06.2010
187C985309F4B909 pkg YWIFLEP last 20.06.2010
187C985707D0438E pkg YWIFSPZ last 20.06.2010
189DE40E16F49D78 pkg YWIIDOC last 19.06.2010
187CC04F1393DB10 pkg YWIINDA last 20.06.2010
187F16AB0CB49976 pkg YWIINDI last 20.06.2010
187CC2A015666301 pkg YWIIORT last 20.06.2010
186EBE160C0C265D pkg YWIIRC last 20.06.2010
186EBE73170F9C0E pkg YWIIRLV last 20.06.2010
18BCFF6E1DCF03B4 pkg YWILODA last 19.06.2010
18971DFD15206846 pkg YWIMAEM last 19.06.2010
186E74CE02DBD50E pkg YWIMQNM last 20.06.2010
186F5E85089C11D8 pkg YWINA04 last 20.06.2010
18B5CE12106F5BB6 pkg YWINE01 last 20.06.2010
18B5CE1218F5E302 pkg YWINE09 last 20.06.2010
18B98F6F193FE77C pkg YWINSLF last 20.06.2010
18B5CE140E469F3C pkg YWINS01 last 20.06.2010
18B5CE15015B4EF4 pkg YWINS02 last 19.06.2010
18B5CE151E848B05 pkg YWINS03 last 20.06.2010
18B5CE171CE9281E pkg YWINS04 last 20.06.2010
18B5CE171FCF582E pkg YWINS05 last 18.06.2010
18B5CE1807211DBA pkg YWINS06 last 20.06.2010
18B5CE191005AFCA pkg YWINS07 last 19.06.2010
18B5CE19145618E4 pkg YWINS08 last 20.06.2010
18B5CE1A131E60FE pkg YWINS09 last 20.06.2010
18B5CE1A1E2C7B09 pkg YWINS10 last 19.06.2010
187CC22207D9FA24 pkg YWIOSCH last 19.06.2010
18BDD3D611B7B20C pkg YWIOUT last 11.06.2010
18C27FE51B722896 pkg YWIOUT last 19.06.2010
187CE4570348CE74 pkg YWIPFT last 20.06.2010
18A7F99E0B15C75C pkg YWIPFTH last 19.06.2010
18B98F871CC3F8E6 pkg YWIPF01 last 19.06.2010
18B98F9B0F6F8672 pkg YWIPF02 last 19.06.2010
18B98F8317F9A4BA pkg YWIPF03 last 19.06.2010
18B98F7510E47CDA pkg YWIPF04 last 19.06.2010
18B98F9F139F2196 pkg YWIPF05 last 19.06.2010
18B98F8D062D6350 pkg YWIPF06 last 19.06.2010
18B98FA004804E58 pkg YWIPF07 last 19.06.2010
18B98F871AD0C3A8 pkg YWIPF08 last 19.06.2010
18B98F7A1DDE785A pkg YWIPF09 last 19.06.2010
18B98FA408046E5E pkg YWIPF10 last 19.06.2010
18B8010C03C2F988 pkg YWIPUS2 last 20.06.2010
18A7F99F06711232 pkg YWIP48M last 17.06.2010
18A7ABEC0E45D9A6 pkg YWISAB last 20.06.2010
18B9626D0A9B709D pkg YWISABH last 31.05.2010
187C985B15732DAF pkg YWISAT2 last 20.06.2010
186EC5F7085516B3 pkg YWISA01 last 20.06.2010
186EC5FB08DCB339 pkg YWISA02 last 19.06.2010
186EC5FE186CFC6E pkg YWISA03 last 19.06.2010
186EC602137C7217 pkg YWISA04 last 20.06.2010
186EC6051D8E8510 pkg YWISA05 last 20.06.2010
187CC13219B2B93B pkg YWISA06 last 20.06.2010
186EC60F1804130B pkg YWISA07 last 19.06.2010
186EC61619B9586C pkg YWISA08 last 19.06.2010
186EC61C1423215A pkg YWISA09 last 20.06.2010
186EC67A1DAAC5E0 pkg YWISA10 last 19.06.2010
18BA56D201CA6072 pkg YWISEMQ last 18.06.2010
187CC1771DEA577A pkg YWISEQ last 19.06.2010
18719E201DA81A4F pkg YWISGSD last 18.06.2010
18B96C0D05487ADA pkg YWISGSL last 19.06.2010
18B961D00B05C59C pkg YWISINH last 20.06.2010
18719E4D1D52F0AA pkg YWISIN2 last 20.06.2010
186EC5D81AF07BEC pkg YWISTAN last 19.06.2010
186EC4C91D7D0B96 pkg YWITBL last 17.06.2010
186EC4D11FAD49B9 pkg YWITBS last 19.06.2010
186DD2E302F81640 pkg YWITBSS last 19.06.2010
186EC50D131E80D3 pkg YWITBSU last 16.06.2010
18C04D880C665D72 pkg YWIUOV last 11.06.2010
18C22FB30B1452F4 pkg YWIUOV last 14.06.2010
18C43E650930C7C6 pkg YWIUOV last 17.06.2010
18A9E2161D6B576A pkg YWIVIEW last 19.06.2010
186EC5CF1954303D pkg YWIZUCH last 18.06.2010
18A7FA170BACB862 pkg YWI1340 last 19.06.2010
18A7F9A500CF3F4A pkg YWI1350 last 19.06.2010
187DDEAF0A6055FB pkg YWI1500 last 20.06.2010
18B82958022AF1BC pkg YWI1520 last 19.06.2010
18A7F9A41C8C38AE pkg YWI1521 last 19.06.2010
18BCE1FA0F16317E pkg YWI251 last 20.06.2010
18A7F9A915067C5A pkg YWI595A last 19.06.2010
18A7F9AA00D91488 pkg YWI5951 last 19.06.2010
18A7F9AA0F84FFAE pkg YWI5952 last 19.06.2010
18A7F9AA1CF44822 pkg YWI5953 last 19.06.2010
18A7F9AB0FB1158A pkg YWI5954 last 19.06.2010
18A7F9AC026432C9 pkg YWI5955 last 19.06.2010
18A7F9AD00FC21BE pkg YWI5956 last 19.06.2010
18A7F9AD1115B9BE pkg YWI5957 last 19.06.2010
18A7F9AE01F9FDAA pkg YWI5958 last 19.06.2010
18A7F9AE10CE712C pkg YWI5959 last 19.06.2010
1891F2C2014CB1A0 pkg YWI8820 last 18.06.2010
188FEE730F22C20D pkg YWJASSE last 18.06.2010
187DABC01FD2B86E pkg YWLPDDX last 16.06.2010
187CBBF71B5E0549 pkg YWLPER last 19.06.2010
187CBC0307B724F0 pkg YWLPRES last 19.06.2010
187CBC0512B95F4A pkg YWL50B1 last 19.06.2010
187CBFD1092FAA2E pkg YWL50B2 last 19.06.2010
187C929A1FB17093 pkg YWL51B1 last 16.06.2010
18B5CD0D1DDD240A pkg YWL803F last 02.06.2010
18BA879A116CDCCA pkg YWMBUAE last 18.06.2010
18BB4F121A31DD88 pkg YWM051A last 19.06.2010
18B8214E13F39682 pkg YWNBASG last 18.06.2010
18BBC332044EA3A8 pkg YWNBAVI last 07.06.2010
18B820F50627A4BC pkg YWNBESH last 20.06.2010
18A7A2BE06F70F64 pkg YWNFLES last 20.06.2010
18A7A2C50F4F822C pkg YWNFUPD last 19.06.2010
18B821701B67B416 pkg YWNGENA last 18.06.2010
18BAA5140A4DE8E8 pkg YWNLESN last 20.06.2010
18BBC334158D96E2 pkg YWNMUTI last 18.06.2010
18B8211A05CFE892 pkg YWNN20B last 18.06.2010
18BC60721DFBB63A pkg YWNOINI last 12.06.2010
18C16EB210C3BC90 pkg YWNOINI last 20.06.2010
18B87119107685D0 pkg YWNOINV last 20.06.2010
18B848091838DF56 pkg YWNOLOG last 20.06.2010
18A7A2901A701B4E pkg YWNPAMS last 20.06.2010
18B8216715F3B036 pkg YWNPMSF last 18.06.2010
18B8217F13942418 pkg YWNPMSG last 20.06.2010
18B8213D0C1D3AE9 pkg YWNPOOL last 18.06.2010
18B8216F1EAB13B0 pkg YWNPOVA last 18.06.2010
18AC8073193B045E pkg YWNPRIC last 20.06.2010
18AC30CA138CF3FF pkg YWNSELA last 19.06.2010
18BAA5320D97F9F8 pkg YWNSTEF last 09.06.2010
18A7A2DA0F81F551 pkg YWNUDB2 last 19.06.2010
18BAA51F1CF30686 pkg YWNUPDN last 20.06.2010
187A959618A6E5BE pkg YWPA#BB last 20.06.2010
187A95981DAD63D9 pkg YWPA#BV last 20.06.2010
187A95950A824420 pkg YWPABEW last 26.05.2010
18A33E801205D142 pkg YWPAPOS last 18.06.2010
187CBD3818E77422 pkg YWPD#X1 last 20.06.2010
187A95920EC78D33 pkg YWPLBB1 last 19.06.2010
18A5C64D083A6E42 pkg YWPLCP1 last 18.06.2010
18B84BB110524C64 pkg YWPLDB1 last 18.06.2010
18A5C6761A17C273 pkg YWPLDP1 last 17.06.2010
18AA111D016B62A2 pkg YWPLEB1 last 18.06.2010
18AA10391B7B8EF4 pkg YWPLEP1 last 20.06.2010
18AA11230FCE1E6A pkg YWPLFB1 last 17.06.2010
18AA103F0A32E388 pkg YWPLFP1 last 26.05.2010
18A69B720B43B18E pkg YWPLHP1 last 27.05.2010
182623501575B45E pkg YWPLXL3 last 18.06.2010
182623551C8508D7 pkg YWPL1A1 last 20.06.2010
187A95890AE2CA80 pkg YWPL1B1 last 19.06.2010
187A95891B3E7D1A pkg YWPL1B2 last 19.06.2010
1826C2DC1086E66B pkg YWPL1D5 last 20.06.2010
1826236C05584D0B pkg YWPL1K2 last 19.06.2010
1826236614306AC5 pkg YWPL1L3 last 19.06.2010
182623D70CC2C6D7 pkg YWPL1L4 last 18.06.2010
18A33EBD062E898D pkg YWPL1P1 last 20.06.2010
186C6D7B1DCC37D1 pkg YWPL1P2 last 16.06.2010
1826237D0D55B0B9 pkg YWPL1S5 last 19.06.2010
182623820D6F82ED pkg YWPL1T1 last 20.06.2010
186828200872B489 pkg YWPL1V1 last 20.06.2010
188330E6179CC7A3 pkg YWPL1W1 last 19.06.2010
187A958C01655A67 pkg YWPL2B1 last 16.06.2010
187A959A0DD9EDA2 pkg YWPL2B2 last 16.06.2010
187A958C023C0294 pkg YWPL2B3 last 16.06.2010
1826238804F88F38 pkg YWPL2L4 last 19.06.2010
18A33EBE1A4F8F56 pkg YWPL2P1 last 20.06.2010
18A77BB90B3E2DAE pkg YWPL2P2 last 20.06.2010
182623931AFB518A pkg YWPL2S6 last 20.06.2010
182623A20248BAD7 pkg YWPL2T1 last 20.06.2010
1868282510EB711A pkg YWPL2V1 last 20.06.2010
1826239D12BEDE3F pkg YWPL3A1 last 19.06.2010
18261CD916987238 pkg YWPL3K2 last 20.06.2010
182623AB18212769 pkg YWPL3L3 last 10.06.2010
18A33EC115C9D2BD pkg YWPL3P1 last 18.06.2010
182623C114612AEB pkg YWPL3S6 last 19.06.2010
182623CC0FA957B7 pkg YWPL3S7 last 20.06.2010
1868285F08EF3F56 pkg YWPL3V1 last 20.06.2010
187A958F1B396CC8 pkg YWPL4B1 last 19.06.2010
18A33EC512C1ED8D pkg YWPL4P1 last 19.06.2010
187A959D1EE02628 pkg YWPL5B1 last 19.06.2010
18A33EC913CE0366 pkg YWPL5P1 last 19.06.2010
187A958E032F4CE4 pkg YWPL7B1 last 19.06.2010
18A33ED300F5FFFF pkg YWPL7P1 last 18.06.2010
18A33ED417978646 pkg YWPL8P1 last 19.06.2010
18A33EDA0A39F7F4 pkg YWPL9P1 last 16.06.2010
187A95771D6F6E3E pkg YWPRABX last 20.06.2010
18A33EDE0F3228E8 pkg YWPRAPX last 20.06.2010
18A33EE1026CF288 pkg YWPRBPX last 19.06.2010
187A957806CBB6E0 pkg YWPRCBX last 20.06.2010
18A33EE401E36500 pkg YWPRCPX last 20.06.2010
18A33EE70A228CD8 pkg YWPRDPX last 20.06.2010
187A95871ABBEEF0 pkg YWPR1BX last 19.06.2010
187A95A608000DFF pkg YWPR1B2 last 20.06.2010
182623B111C944E0 pkg YWPR1D1 last 20.06.2010
18A77CA90FFFC1F4 pkg YWPR1HX last 20.06.2010
18A33EF313C794D0 pkg YWPR1PX last 20.06.2010
18A77CB80BCF4BCE pkg YWPR1P2 last 20.06.2010
18A33EEA0F0B569C pkg YWPR1QX last 20.06.2010
1824C17A0E29859E pkg YWPR1S4 last 18.06.2010
1824C17F01926E07 pkg YWPR1S5 last 20.06.2010
1824C1E308545F59 pkg YWPR1S7 last 19.06.2010
187A957B1F218E05 pkg YWPR2BX last 20.06.2010
182623BC01193952 pkg YWPR2D1 last 20.06.2010
18A4D5C50F1230BE pkg YWPR2HX last 20.06.2010
18A33EED11F16346 pkg YWPR2PX last 20.06.2010
1824C1A0102275DD pkg YWPR2S4 last 19.06.2010
186C6D9008420C8A pkg YWPR2S5 last 20.06.2010
1824C1A6126AF034 pkg YWPR2S7 last 20.06.2010
187A958A1B3C4AA0 pkg YWPR3BX last 20.06.2010
182A62880AEFFC30 pkg YWPR3D1 last 01.06.2010
18A4D5CB08DCEB7B pkg YWPR3HX last 19.06.2010
18A33EEF1A8CBA67 pkg YWPR3PX last 18.06.2010
187A957C03E6A2B8 pkg YWPR4BX last 19.06.2010
18A4D5D31EE82347 pkg YWPR4HX last 19.06.2010
18A33EF51682F78C pkg YWPR4PX last 19.06.2010
187A957B1D795878 pkg YWPR5BX last 19.06.2010
18A4D5DA0D07EAFC pkg YWPR5HX last 14.06.2010
18A33EF804CEC3F6 pkg YWPR5PX last 18.06.2010
187A958A1D382D95 pkg YWPR6BX last 20.06.2010
18A4D5DE11865A6D pkg YWPR6HX last 20.06.2010
18A33EFA19AC2C1C pkg YWPR6PX last 20.06.2010
187A95800206CB28 pkg YWPR7BX last 19.06.2010
18A4D5E61575BAA7 pkg YWPR7HX last 20.06.2010
18A5CF68139D7FE2 pkg YWPR7PX last 19.06.2010
18A4D5ED0973AE10 pkg YWPR8HX last 20.06.2010
18A69B4C16A695A1 pkg YWPR8PX last 18.06.2010
187A958D0CC3860C pkg YWPR9BX last 19.06.2010
18A4D5F414FE602D pkg YWPR9HX last 18.06.2010
18A69B4701D4BB62 pkg YWPR9PX last 18.06.2010
186C6D9F151A3F5B pkg YWPU#S4 last 19.06.2010
186C6DA20F6043AE pkg YWPU#S6 last 18.06.2010
182624131A609D58 pkg YWPU#T1 last 20.06.2010
186C6DA5154F7DC0 pkg YWPU#V1 last 19.06.2010
1826241E095F8960 pkg YWPU#W1 last 20.06.2010
1824E19D01917457 pkg YWPU1A1 last 20.06.2010
187A958009DE7105 pkg YWPU1B1 last 19.06.2010
187A95810756C55B pkg YWPU1B2 last 19.06.2010
187A958E069F9F0E pkg YWPU1B3 last 19.06.2010
1824E03B044E6186 pkg YWPU1D1 last 19.06.2010
182381BA145A4A49 pkg YWPU1D5 last 19.06.2010
187B088C0B7EB9D6 pkg YWPU1H1 last 20.06.2010
1824E14D1BDCA398 pkg YWPU1K2 last 20.06.2010
186828791FCDFCC7 pkg YWPU1L3 last 20.06.2010
18A786CE177A74AC pkg YWPU1P1 last 20.06.2010
18A77CBC12DA91E6 pkg YWPU1P2 last 19.06.2010
18A33F021B14E524 pkg YWPU1P5 last 19.06.2010
18A77CBC193E6CE2 pkg YWPU1P6 last 19.06.2010
1824E0460C70D4C0 pkg YWPU1S4 last 18.06.2010
187A95BD16B5F738 pkg YWPU1W1 last 19.06.2010
1824E18C1F3C6B99 pkg YWPU2A1 last 20.06.2010
18A3924F051FC267 pkg YWPU2BX last 18.06.2010
187A9583199331EA pkg YWPU2B1 last 20.06.2010
187A95901CD6ECFA pkg YWPU2B2 last 20.06.2010
187B088E18328B38 pkg YWPU2H1 last 07.06.2010
1824E1881A36724C pkg YWPU2L3 last 19.06.2010
18A33F08083D8F29 pkg YWPU2P1 last 19.06.2010
187A95831A35F87A pkg YWPU3B1 last 19.06.2010
187A95900FE5046E pkg YWPU3B2 last 19.06.2010
187A958604821060 pkg YWPU3B3 last 19.06.2010
1824E18304EF79F5 pkg YWPU3L3 last 19.06.2010
18A33F0502453DCE pkg YWPU3P1 last 20.06.2010
18A77CBD0D20EFA0 pkg YWPU3P2 last 20.06.2010
187A959218BD84C2 pkg YWPU4B1 last 16.06.2010
18A3924C1C854265 pkg YWPU4L3 last 10.06.2010
1869EB8B15AD190D pkg YWPXCAA last 20.06.2010
1869EB8D0B2EF196 pkg YWPXCAB last 19.06.2010
1869EB921130DD9A pkg YWPXCBA last 16.06.2010
1869EB970D5740C2 pkg YWPXCCA last 18.06.2010
1869EB991278CBA0 pkg YWPXCCB last 18.06.2010
1869EB9C00D2A26F pkg YWPXCDA last 20.06.2010
1869EB9D0A312B62 pkg YWPXCDB last 20.06.2010
1869EB9F0DCA2C6A pkg YWPXCFA last 19.06.2010
1869EBA10EEF06B6 pkg YWPXCFB last 19.06.2010
1869EBBA02AF456B pkg YWPXCHA last 19.06.2010
1869EBC2175E7940 pkg YWPXCIA last 19.06.2010
1869EBCA1069B995 pkg YWPXCIB last 19.06.2010
1869EBCC0F12BF17 pkg YWPXCKA last 20.06.2010
1869EBCE14418AE6 pkg YWPXCKB last 19.06.2010
1869EBD100EB959A pkg YWPXCLA last 18.06.2010
1869EBD508D3F9D8 pkg YWPXCLB last 18.06.2010
1869EBD713D7559A pkg YWPXCMA last 19.06.2010
1869EBDB0F3DC852 pkg YWPXCMB last 18.06.2010
1869EBDF1F3722E8 pkg YWPXCNA last 20.06.2010
1869EBE2004EFDB1 pkg YWPXCNB last 19.06.2010
1869EBE40DBDF13D pkg YWPXCOA last 20.06.2010
1869EBE61439C460 pkg YWPXCOB last 20.06.2010
1869EBE91D27A237 pkg YWPXCPA last 19.06.2010
1869EBEB0AE2FA22 pkg YWPXCPB last 19.06.2010
1869EBED119FA00A pkg YWPXGAA last 20.06.2010
1869EBEE16F9CB0C pkg YWPXGAB last 19.06.2010
1869EBF0143144E2 pkg YWPXGBA last 19.06.2010
1869EBF2051CEB1A pkg YWPXGBB last 18.06.2010
1869EBF70AEA756A pkg YWPXGDA last 18.06.2010
1869EC010EED9AB6 pkg YWPXGDB last 14.06.2010
1869EC220B478E49 pkg YWPXGFA last 19.06.2010
1869EC25081D3F74 pkg YWPXGFB last 02.06.2010
1869EC2C0BBFF910 pkg YWPXGGA last 16.06.2010
1869EC371D605AF5 pkg YWPXGIA last 18.06.2010
1869EC4A0041D152 pkg YWPXGJA last 18.06.2010
1869EC530AAF1AD5 pkg YWPXGJB last 18.06.2010
1869EC62049DC595 pkg YWPXGKA last 20.06.2010
1869EC6405EFC4BC pkg YWPXGKB last 11.06.2010
1869EC691F745E38 pkg YWPXGLA last 16.06.2010
1869EC6E11601CA3 pkg YWPXGMA last 19.06.2010
1869EC701C593143 pkg YWPXGMB last 19.06.2010
1869EC731F4F8EB4 pkg YWPXHAA last 18.06.2010
1869EC760BE5146D pkg YWPXHAB last 18.06.2010
1869EC7A0F7FE625 pkg YWPXHBA last 20.06.2010
1869EC800C90E406 pkg YWPXHBB last 19.06.2010
1869EC9801E0B4BB pkg YWPYCAA last 20.06.2010
1869EC9B16A3E849 pkg YWPYCAB last 19.06.2010
1869EC9E17E2A4C5 pkg YWPYGAA last 20.06.2010
1869ECA206DB4669 pkg YWPYGAB last 18.06.2010
1869ECAC111E431B pkg YWPYHAA last 20.06.2010
188DB2C114B2D4E8 pkg YWQAF01 last 20.06.2010
18B9373C1A8D7C30 pkg YWQAF02 last 20.06.2010
1899A52D14264FF9 pkg YWQATFM last 20.06.2010
18B9373B0860992B pkg YWQBC01 last 20.06.2010
18B937351E500163 pkg YWQBC02 last 20.06.2010
18B937380E652A55 pkg YWQBC03 last 20.06.2010
18B9373E1E344995 pkg YWQBC04 last 20.06.2010
18B9373911C32078 pkg YWQBC11 last 20.06.2010
18B9373E137AC526 pkg YWQBC12 last 20.06.2010
18B93739004E53F1 pkg YWQBERI last 18.06.2010
189CA2331828AA1F pkg YWQBUFF last 20.06.2010
18BFD15F1D96DA34 pkg YWQCANP last 18.06.2010
18B9374104073F5C pkg YWQCANP last 11.06.2010
18B937420A6B8328 pkg YWQCANR last 13.06.2010
18B937431F192BEB pkg YWQCR01 last 20.06.2010
18A665E805F40CA2 pkg YWQERME last 20.06.2010
188F75F61BC1D26C pkg YWQESEL last 20.06.2010
18B9373318EBDDE0 pkg YWQEVEO last 20.06.2010
189A700F180BED7C pkg YWQEXCP last 20.06.2010
1899539B076BD3CE pkg YWQEXST last 19.06.2010
18659CBC15214B21 pkg YWQFX91 last 20.06.2010
18A9FDC0008E2E10 pkg YWQKU37 last 20.06.2010
1871E85A10A4EC0E pkg YWQLWCD last 20.06.2010
18B9374518D55117 pkg YWQORET last 19.06.2010
18B9374B1DAEF1C4 pkg YWQPAIR last 20.06.2010
188DB2D51478D81D pkg YWQRA01 last 20.06.2010
18B9374D08A621A8 pkg YWQREPI last 19.06.2010
189953781C6DDE74 pkg YWQRE01 last 20.06.2010
18B9375210602EC7 pkg YWQRM01 last 20.06.2010
18B937651FDEC44B pkg YWQRP01 last 20.06.2010
18B9375216086D45 pkg YWQRTRV last 18.06.2010
18B9374E13A2E408 pkg YWQSHAP last 20.06.2010
1899539710224B66 pkg YWQTESA last 20.06.2010
18A47D1A1CF95ECD pkg YWQWAGE last 20.06.2010
18B937610EA069B2 pkg YWQ0702 last 18.06.2010
18A665F7024EFDEA pkg YWQ1001 last 18.06.2010
18A665FB1E1252CB pkg YWQ1002 last 18.06.2010
18A665FB093193FE pkg YWQ1101 last 17.06.2010
18A665F9131D57B8 pkg YWQ1102 last 09.06.2010
18A6660000D21042 pkg YWQ1501 last 18.06.2010
18A665FD0FA4AE40 pkg YWQ1701 last 17.06.2010
18B93764141D2D28 pkg YWQ2601 last 17.06.2010
18A6660D0D66C865 pkg YWQ6001 last 18.06.2010
186EBE1C0B11915D pkg YWUANRE last 18.06.2010
186EBEC30D95AEE6 pkg YWUDEAH last 20.06.2010
18BACDF0063425A4 pkg YWUDER last 20.06.2010
186EBF281DD370F5 pkg YWUD401 last 18.06.2010
186EBFCD0E37C2B8 pkg YWUD415 last 18.06.2010
186EBFD4031EA1B9 pkg YWUD421 last 20.06.2010
186EBFDA02D4365E pkg YWUD422 last 02.06.2010
186EBFE1008BA703 pkg YWUD423 last 20.06.2010
186EBFE701D3A41E pkg YWUD424 last 19.06.2010
186EBFED16B806C0 pkg YWUD425 last 17.06.2010
186EBFF31E9343D0 pkg YWUD428 last 20.06.2010
1830D47D0C530A65 pkg YWUD530 last 18.06.2010
1830D47E0BF5DF55 pkg YWUD532 last 19.06.2010
1830D47F0F29AF98 pkg YWUD540 last 07.06.2010
186EBFFB01F50E64 pkg YWUD600 last 18.06.2010
186EC00E0EAAB857 pkg YWUD610 last 18.06.2010
186EC0341B4BA397 pkg YWUD620 last 18.06.2010
1830D48012958C00 pkg YWUFART last 19.06.2010
1830D48901CEB72E pkg YWUFEF last 19.06.2010
1830D4920D33DEE2 pkg YWUFFEL last 19.06.2010
1830D49501D98C6D pkg YWUFIFA last 20.06.2010
1830D49715D114B8 pkg YWUFPL last 19.06.2010
1830D49B0C9FE55B pkg YWUFPL5 last 19.06.2010
187F41A50193472C pkg YWUFSU last 19.06.2010
186EC1100A51E492 pkg YWUGAHE last 20.06.2010
186EC13E1C442B18 pkg YWUGARF last 20.06.2010
186EC1470BDF2FB4 pkg YWUGBUA last 20.06.2010
186EC1AE09900448 pkg YWUGBUB last 20.06.2010
186EC1B5119DFD41 pkg YWUGBWB last 19.06.2010
186EC1C4130D3E7B pkg YWUGCI last 19.06.2010
186EC3890A65FB75 pkg YWUGDF last 19.06.2010
1899D4E601827391 pkg YWUGDI last 19.06.2010
186EC3970DC27989 pkg YWUGEID last 20.06.2010
186EC3A81A31783D pkg YWUGET last 19.06.2010
186EC3AE1DF904A8 pkg YWUGETA last 19.06.2010
186EC3B71D26A709 pkg YWUGETV last 20.06.2010
186EC3BD070BCA42 pkg YWUGEVA last 18.06.2010
186EC3C406AC43B6 pkg YWUGNOT last 19.06.2010
186EC3C915D7C897 pkg YWUGOE last 19.06.2010
188DB34211A97B08 pkg YWUGPK last 19.06.2010
188DB3440A1BA30A pkg YWUGPKL last 19.06.2010
188DB3451CBBCAEA pkg YWUGPKT last 19.06.2010
186EC3E707801725 pkg YWUGRFA last 17.06.2010
186EC3F60B551B03 pkg YWUGUID last 19.06.2010
18BBA060045AADD0 pkg YWUGWSZ last 20.06.2010
186EC4190ACF4AFA pkg YWUG101 last 18.06.2010
188DB34918936C84 pkg YWUG200 last 19.06.2010
186EC44B058B524F pkg YWUG334 last 20.06.2010
18B940F90DC7C7FF pkg YWUG350 last 19.06.2010
186EC4AC0EC399C0 pkg YWUG401 last 19.06.2010
186EC4B80CE11271 pkg YWUG410 last 19.06.2010
186EC4BE087EDA14 pkg YWUG415 last 19.06.2010
186EC4C213A3FC6E pkg YWUG422 last 19.06.2010
186EC4CC1108A54A pkg YWUG424 last 20.06.2010
186EC4D2000AA946 pkg YWUG425 last 20.06.2010
186EC4D7073C031D pkg YWUG428 last 20.06.2010
1830D46B1398388F pkg YWUG500 last 19.06.2010
18429D1218796B5E pkg YWUG501 last 20.06.2010
1830D46D1E58323C pkg YWUG502 last 20.06.2010
1830D46F098BC7E0 pkg YWUG511 last 19.06.2010
1830D4700C2A00C8 pkg YWUG520 last 19.06.2010
1830D4710E0852CB pkg YWUG530 last 20.06.2010
1830D47210167FF4 pkg YWUG531 last 19.06.2010
1830D47314E22CC1 pkg YWUG532 last 20.06.2010
1830D4741A7C586F pkg YWUG533 last 20.06.2010
1830D4760107D89F pkg YWUG534 last 20.06.2010
1830D47701235EA5 pkg YWUG540 last 19.06.2010
186EC4DD09BC6252 pkg YWUG600 last 20.06.2010
186EC4E315AC251E pkg YWUG601 last 19.06.2010
186EC4EC1188C720 pkg YWUG610 last 20.06.2010
186EC4F30E7CB375 pkg YWUG611 last 20.06.2010
186EC4F918EA60C7 pkg YWUG612 last 20.06.2010
186EC50008D8D87E pkg YWUG620 last 20.06.2010
186EC5070581701B pkg YWUG621 last 19.06.2010
186EC50E1314F105 pkg YWUIAH last 19.06.2010
186EC51A0E7281B3 pkg YWUICI last 19.06.2010
186EC52702BBFA2A pkg YWUIDEP last 19.06.2010
186EC52F0DD58B1F pkg YWUIDF last 19.06.2010
1899D4E702F25B32 pkg YWUIDI last 19.06.2010
186EC5820EF06FDE pkg YWUIOE last 19.06.2010
188DB34D14345202 pkg YWUIPK last 19.06.2010
186EE4C600ED5914 pkg YWUIPOS last 19.06.2010
1873581A16802F00 pkg YWUI334 last 20.06.2010
186EE4D706F21B98 pkg YWUI350 last 18.06.2010
186EE4EB19309A14 pkg YWUI401 last 19.06.2010
186EE4F009D8FC06 pkg YWUI410 last 20.06.2010
186EE4F6121DB3C2 pkg YWUI415 last 19.06.2010
186EE4FC1DCF9AF8 pkg YWUI420 last 20.06.2010
186EE502074F2AEC pkg YWUI421 last 20.06.2010
186EE5070E8B7639 pkg YWUI422 last 20.06.2010
186EE50C1A11847C pkg YWUI423 last 19.06.2010
186EE51408C91444 pkg YWUI424 last 20.06.2010
186EE519080507F6 pkg YWUI425 last 18.06.2010
186EE51F0BFF1CC9 pkg YWUI428 last 19.06.2010
1830D4780414976A pkg YWUI530 last 19.06.2010
1830D4630905BAE3 pkg YWUI531 last 19.06.2010
1830D4640C7AE452 pkg YWUI532 last 19.06.2010
1830D4650EF4A428 pkg YWUI533 last 19.06.2010
1830D466130B6998 pkg YWUI534 last 19.06.2010
1830D4671A7C6249 pkg YWUI540 last 17.06.2010
186EE524183AD778 pkg YWUI600 last 18.06.2010
186EE5281CC1BFEB pkg YWUI601 last 18.06.2010
186EE53D00B9CF6A pkg YWUI610 last 18.06.2010
186EE5410A27E84B pkg YWUI611 last 18.06.2010
186EE5460CC5D48D pkg YWUI612 last 18.06.2010
186EE5521C9FA032 pkg YWUI620 last 18.06.2010
186EE56007D960CA pkg YWUI621 last 18.06.2010
186EE5700A4BDAE5 pkg YWUPARM last 20.06.2010
186EE67018DB0A54 pkg YWUPUT last 20.06.2010
187DAEFB13C46A4F pkg YWUSTEU last 20.06.2010
186EE6EC16B6C8B0 pkg YWUTIME last 20.06.2010
186EE6F10F347DAA pkg YWUUCI last 18.06.2010
186EEC3205BA606C pkg YWUUDEP last 19.06.2010
186EE6FB1CA88018 pkg YWUUDF last 19.06.2010
1899D4E803796A9C pkg YWUUDI last 19.06.2010
186EE71B1F0449B6 pkg YWUUETS last 19.06.2010
186EE73405FAF47E pkg YWUUOE last 18.06.2010
188DB3651F0BB646 pkg YWUUPKI last 18.06.2010
188DB3670C5651ED pkg YWUUPKS last 19.06.2010
186EE7C50636E0F8 pkg YWUU334 last 20.06.2010
18B855530D2013B6 pkg YWUU350 last 18.06.2010
186EE7CF04FC189C pkg YWUU401 last 19.06.2010
186EE7D4114C4A12 pkg YWUU415 last 18.06.2010
186EE7DA069C13B0 pkg YWUU420 last 20.06.2010
186EE7E1072385DD pkg YWUU422 last 18.06.2010
186EE7E60E7D0FF3 pkg YWUU423 last 19.06.2010
1830D4691A6D128B pkg YWUU530 last 19.06.2010
1830D46A10F1A9EB pkg YWUU533 last 19.06.2010
186EE7FB17F95E69 pkg YWUU610 last 15.06.2010
186EE80D0301FE5E pkg YWUU620 last 09.06.2010
187F41A71DD3AFA0 pkg YWU0321 last 17.06.2010
186E49771377DCCE pkg YWU0343 last 17.06.2010
186E497A02AA3D2C pkg YWU0352 last 17.06.2010
187F41A911B8A323 pkg YWU0393 last 19.06.2010
188DB3731E98EFA0 pkg YWU0421 last 17.06.2010
186E9DA2086290BF pkg YWVDNOT last 02.06.2010
18670FFD18956E18 pkg YWVGAOP last 19.06.2010
18671002113D6E69 pkg YWVIAOP last 18.06.2010
187507EF11BC95FF pkg YWVNOTA last 20.06.2010
187469970CF8CCC4 pkg YWVNOTB last 19.06.2010
1896118213C08890 pkg YWVUSW last 20.06.2010
186E4EE215C53012 pkg YWV2310 last 18.06.2010
186E6F2E01B3091A pkg YWV2330 last 10.06.2010
186E9E0B1913A7B0 pkg YWV2350 last 02.06.2010
185AA10906C65FEA pkg YWWDCU last 18.06.2010
186E47B213308283 pkg YWWEAHD last 02.06.2010
18A68DB70DA74CF6 pkg YWWGAUF last 18.06.2010
1885661511B6E641 pkg YWWGBG last 19.06.2010
18492BEB1A00E00E pkg YWWGBGA last 20.06.2010
18492BF006541C4A pkg YWWGCD last 18.06.2010
1885DAB916E47433 pkg YWWGCL last 19.06.2010
1863E8D8021D098A pkg YWWGCU last 20.06.2010
1863E8DB05BFC7BD pkg YWWGCUA last 19.06.2010
1885661614482E7B pkg YWWGLB last 19.06.2010
1863E8DE0482930D pkg YWWGPOS last 19.06.2010
18492C0213FBB6D9 pkg YWWIAUF last 19.06.2010
18492C060306C7BC pkg YWWICD last 19.06.2010
1885DAE60C568B73 pkg YWWICL last 19.06.2010
186E484A1BC549BA pkg YWWICU last 19.06.2010
185546D709CFB951 pkg YWWIPOS last 19.06.2010
18492C180FA9EBC0 pkg YWWUAS last 19.06.2010
1885660207EA5D14 pkg YWWUBAN last 19.06.2010
18492C1C14683CC2 pkg YWWUBES last 19.06.2010
185AA11E1796EE00 pkg YWWUCU last 18.06.2010
1863E8E5076C6778 pkg YWWUPOS last 19.06.2010
18856608096E658A pkg YWWUSEL last 19.06.2010
1885660C1D3FE980 pkg YWWUVTS last 19.06.2010
183387141D7DD211 pkg YWYD100 last 02.06.2010
183387151CD2D7C0 pkg YWYD132 last 19.06.2010
1833871619BD5899 pkg YWYD210 last 18.06.2010
183387171811788E pkg YWYD250 last 19.06.2010
18338718158020AB pkg YWYD300 last 02.06.2010
1833871913E19947 pkg YWYD304 last 02.06.2010
1833871A1201CEE2 pkg YWYD305 last 19.06.2010
1833871B0EB15EA5 pkg YWYD306 last 19.06.2010
1833871C0C40EAD3 pkg YWYD307 last 02.06.2010
1833871D1B37AA9E pkg YWYD308 last 19.06.2010
1833871E1E011765 pkg YWYD400 last 18.06.2010
18338728032BADBA pkg YWYERTA last 18.06.2010
18338729046B4306 pkg YWYESA last 19.06.2010
1833872C059E8CE7 pkg YWYGBEZ last 20.06.2010
183387380535F140 pkg YWYGDTA last 18.06.2010
18AAC4591410D722 pkg YWYGER last 19.06.2010
1833873B0AE12A11 pkg YWYGESA last 19.06.2010
1833873C0CFC05CD pkg YWYGETI last 19.06.2010
1833873E1B862CB8 pkg YWYGLTA last 19.06.2010
183387401EC92A0B pkg YWYGPTP last 17.06.2010
18636B15124428BC pkg YWYGSTD last 19.06.2010
183387450D3A2B8A pkg YWYGSVL last 18.06.2010
18338748144A7E06 pkg YWYGTIA last 17.06.2010
1878A1AE06A9025D pkg YWYGTL last 18.06.2010
1833874B135570A2 pkg YWYGTLB last 18.06.2010
1833874C1D619394 pkg YWYGTTL last 18.06.2010
183387B20D4E8E3D pkg YWYG100 last 19.06.2010
183387BA16B76A0B pkg YWYG101 last 18.06.2010
183387BB1DF552DC pkg YWYG102 last 19.06.2010
183387BD056ECA8E pkg YWYG103 last 19.06.2010
183387BE11C12498 pkg YWYG105 last 19.06.2010
183387BF16ECFC28 pkg YWYG106 last 19.06.2010
183387C018723EDC pkg YWYG107 last 17.06.2010
183387C11B104E4D pkg YWYG108 last 19.06.2010
183387C21E10AA3A pkg YWYG109 last 19.06.2010
183387C401E3252D pkg YWYG110 last 18.06.2010
183387C50100F9A4 pkg YWYG111 last 19.06.2010
1878A1B009E43AC5 pkg YWYG112 last 19.06.2010
183387C7000C0349 pkg YWYG113 last 19.06.2010
1878A1B403FCCE42 pkg YWYG114 last 19.06.2010
183387C90710304B pkg YWYG116 last 18.06.2010
183387CA098CC8F3 pkg YWYG117 last 19.06.2010
183387CB0A4ADC06 pkg YWYG118 last 19.06.2010
183387CC08EB68EE pkg YWYG119 last 19.06.2010
183387CD09F0FFCC pkg YWYG120 last 19.06.2010
183387CE08BFFAB9 pkg YWYG121 last 19.06.2010
183387CF079C0686 pkg YWYG125 last 19.06.2010
183387D009E7084C pkg YWYG126 last 19.06.2010
183387D10DB0B9AA pkg YWYG127 last 19.06.2010
183387D20E9BC4AC pkg YWYG129 last 19.06.2010
1878A1B7066B16B1 pkg YWYG130 last 19.06.2010
183387D40F84B995 pkg YWYG131 last 19.06.2010
183387D50FBC730F pkg YWYG133 last 18.06.2010
183387D613CEC733 pkg YWYG134 last 19.06.2010
183387D716DCDE16 pkg YWYG210 last 20.06.2010
183387D81B6DC01E pkg YWYG250 last 19.06.2010
183387DA010E8664 pkg YWYG251 last 20.06.2010
183387DB0638567A pkg YWYG300 last 19.06.2010
183387DC0B8A5527 pkg YWYG302 last 19.06.2010
183387DD132594FB pkg YWYG303 last 19.06.2010
183387EF09ED7308 pkg YWYG304 last 20.06.2010
1851B26B00AB6371 pkg YWYG305 last 19.06.2010
183387F106DD6D56 pkg YWYG306 last 19.06.2010
183387F20886884D pkg YWYG308 last 19.06.2010
183387F311B22C42 pkg YWYG400 last 20.06.2010
183387F8028D49C1 pkg YWYIMES last 16.06.2010
183387F903E6D3DB pkg YWYIREG last 18.06.2010
183387FA068D7119 pkg YWYI100 last 19.06.2010
183387FB0CFE0209 pkg YWYI101 last 18.06.2010
183387FD1431D74C pkg YWYI102 last 18.06.2010
183387FE1E09C49D pkg YWYI103 last 18.06.2010
1833880005435192 pkg YWYI105 last 18.06.2010
183388010C2181B9 pkg YWYI106 last 16.06.2010
183388020F638C13 pkg YWYI107 last 16.06.2010
1833880313E2DF8D pkg YWYI108 last 18.06.2010
1833880417D60C5A pkg YWYI109 last 19.06.2010
1833880517787E6F pkg YWYI110 last 25.05.2010
18338806180809FA pkg YWYI111 last 18.06.2010
1878A1BA1FBAABE3 pkg YWYI112 last 18.06.2010
183388081E65F470 pkg YWYI113 last 18.06.2010
183388091F3FCD5D pkg YWYI114 last 19.06.2010
1833880B00D36BBC pkg YWYI115 last 18.06.2010
1833880E1A92C285 pkg YWYI116 last 18.06.2010
1833880F1D2BFAF2 pkg YWYI117 last 18.06.2010
18338811025C55A2 pkg YWYI118 last 18.06.2010
183388120708B527 pkg YWYI119 last 18.06.2010
1833881309DDFC78 pkg YWYI120 last 18.06.2010
183388140AF9B12A pkg YWYI121 last 18.06.2010
183388150CB3D603 pkg YWYI125 last 18.06.2010
183388161076B1F5 pkg YWYI126 last 19.06.2010
1833881715D80BA3 pkg YWYI127 last 18.06.2010
183388181CF75C32 pkg YWYI129 last 18.06.2010
183388191AA8BF36 pkg YWYI130 last 19.06.2010
1833881B0149AB90 pkg YWYI131 last 18.06.2010
18338887023786B4 pkg YWYI132 last 19.06.2010
183388880DB445E0 pkg YWYI133 last 18.06.2010
18338889113212B6 pkg YWYI134 last 19.06.2010
1833888B10A74347 pkg YWYI250 last 19.06.2010
1833888C143C750F pkg YWYI251 last 17.06.2010
1833888D1621DF46 pkg YWYI300 last 19.06.2010
1833888E164F534B pkg YWYI302 last 19.06.2010
1833888F1576268E pkg YWYI303 last 16.06.2010
18338890146B1532 pkg YWYI304 last 19.06.2010
1833889106E5D8F7 pkg YWYI305 last 19.06.2010
183388911DEF9514 pkg YWYI306 last 19.06.2010
183388921800B6B1 pkg YWYI307 last 18.06.2010
1833889315C4F031 pkg YWYI308 last 19.06.2010
183388940A05C814 pkg YWYI400 last 20.06.2010
1833889C082353A0 pkg YWYPBED last 18.06.2010
18338895015C58AB pkg YWYPDL last 17.06.2010
18338896030D4746 pkg YWYPERG last 17.06.2010
183388A3161E4034 pkg YWYPMBE last 25.05.2010
183388A416143D12 pkg YWYPPI last 25.05.2010
1878A1C31EE134D0 pkg YWYPTDE last 18.06.2010
183388A708ABB1A6 pkg YWYPTDF last 25.05.2010
1843DA6915E1AE16 pkg YWYPTL last 18.06.2010
183388AB09D7CB80 pkg YWYRETE last 19.06.2010
183388AC12118CD6 pkg YWYTTLE last 19.06.2010
183388AF15269CB7 pkg YWYUIOE last 20.06.2010
18A38F5D0090304A pkg YWYUSAM last 19.06.2010
183388B01A36DB7A pkg YWYUTOE last 03.06.2010
183388B20107E5F3 pkg YWYU100 last 19.06.2010
183388B30755C131 pkg YWYU101 last 25.05.2010
183388B40D875212 pkg YWYU103 last 18.06.2010
183388CA00E3F5A9 pkg YWYU108 last 25.05.2010
183388CA1F4B85D3 pkg YWYU110 last 25.05.2010
1878A1D007AEEAEC pkg YWYU112 last 17.06.2010
183388CE1E03FFBE pkg YWYU114 last 19.06.2010
183388D01ECA2EA5 pkg YWYU119 last 17.06.2010
183388D200FA0079 pkg YWYU120 last 18.06.2010
183388D21FA24DFC pkg YWYU121 last 25.05.2010
183388D4198168CB pkg YWYU126 last 19.06.2010
183388D517F4CB04 pkg YWYU129 last 25.05.2010
183388D6190E98C5 pkg YWYU130 last 19.06.2010
183388D816667BF4 pkg YWYU300 last 19.06.2010
183388DA0F305518 pkg YWYU304 last 19.06.2010
183388DB0C6A3784 pkg YWYU307 last 17.06.2010
183388DC0ABFDA6B pkg YWYU400 last 19.06.2010
1878A1D21B995137 pkg YWYVREG last 19.06.2010
18B8217C0018BF44 pkg YXA171C last 19.06.2010
18BFDB420CCAA0B0 pkg YXA171L last 20.06.2010
18B93F141583F9ED pkg YXBGKOP last 18.06.2010
189527891B606E3E pkg YXB9026 last 20.06.2010
1841D85E0E1583C9 pkg YXCE05L last 14.06.2010
183A9CBD15C5A799 pkg YXCE07L last 20.06.2010
183A9CDC19DCAFD2 pkg YXCE08L last 20.06.2010
1841D86D0179890F pkg YXCE11L last 18.06.2010
1841D9610526B831 pkg YXCE12L last 18.06.2010
18A5BE7A17F69FFF pkg YXCE13L last 17.06.2010
1841D8791F05D982 pkg YXCE14L last 18.06.2010
183A9C64072D3799 pkg YXCE15L last 20.06.2010
183A9D171E23A198 pkg YXCE16L last 20.06.2010
183A9E641BC21F06 pkg YXCE20L last 20.06.2010
184DE46C1EDD4915 pkg YXCE23L last 19.06.2010
1879505E1B1B1947 pkg YXCIBEZ last 20.06.2010
180E15C00A63FF35 pkg YXC112A last 19.06.2010
187004C01D22E3DA pkg YXDGT11 last 18.06.2010
189BE293068EFA7A pkg YXDGT31 last 18.06.2010
18B96CE615740C12 pkg YXEBV2E last 20.06.2010
189ED35C1FD4835C pkg YXGEUNL last 19.06.2010
18B5588C1C647E56 pkg YXKCPUT last 20.06.2010
1823EC551180036D pkg YXKCPUT last 17.06.2010
188B80F91004EF98 pkg YXML2FI last 20.06.2010
189F56D704BCFF99 pkg YXREPRH last 20.06.2010
1863454D18A8F988 pkg YXRE01L last 18.06.2010
185AA93D18234C60 pkg YXRE02L last 18.06.2010
185F07BA0F6CCCEF pkg YXRE03L last 18.06.2010
187D3C1E042F0005 pkg YXRE04L last 20.06.2010
187CBBA71243DFDE pkg YXRE06L last 18.06.2010
185D2B8C14685DCA pkg YXRE07L last 18.06.2010
18A4ADC90F0478D8 pkg YXRE08L last 18.06.2010
185D2BA717905311 pkg YXRE09L last 02.06.2010
186506EB094DDE4C pkg YXRE10L last 18.06.2010
185D2BAA19A56B75 pkg YXRE11L last 18.06.2010
185D2BAB1E1C9731 pkg YXRE12L last 18.06.2010
18650677199C366F pkg YXRE16L last 08.06.2010
186070D6038F2942 pkg YXRE17L last 18.06.2010
187835F51705E5E0 pkg YXRE18L last 18.06.2010
187510771F4F01BA pkg YXRE19L last 18.06.2010
185D2BB31CBDF729 pkg YXRE21L last 08.06.2010
186E46760E04359E pkg YXRE22L last 18.06.2010
185D2BBB11A5B2B4 pkg YXRE24L last 18.06.2010
18606F510AE291AE pkg YXRE25L last 19.06.2010
186232E21531D699 pkg YXRE26L last 18.06.2010
185D2BB80EE8C58C pkg YXRE27L last 16.06.2010
185F07C71B68B216 pkg YXRE28L last 04.06.2010
186B4853138DCEB0 pkg YXRE29L last 18.06.2010
185F07CD0ABB0EA1 pkg YXRE30L last 09.06.2010
1860250B186FEA57 pkg YXRE31L last 18.06.2010
1866BC4C1CBAEB8A pkg YXRE32L last 08.06.2010
186B48C600B87234 pkg YXRE49L last 20.06.2010
183248991CD7C97B pkg YXVPSI1 last 03.06.2010
18A7F9B103552E6E pkg YXWIAS1 last 20.06.2010
18A7F9B1118EBEAE pkg YXWICFI last 20.06.2010
186DD2780DF711A1 pkg YXWICGA last 18.06.2010
18A81CE218E1D167 pkg YXWIEOR last 20.06.2010
18A2A54C18865E67 pkg YXWILO last 20.06.2010
18321D6E1FB61224 pkg YXWIMGA last 20.06.2010
1824DF68052454BF pkg YXWISCH last 20.06.2010
18B961D41D877504 pkg YXWISHH last 19.06.2010
18B736AF1B6BCABC pkg YYAVGEL last 19.06.2010
18B93F140204F046 pkg YYBGCLM last 19.06.2010
18976EDB10BCBAD0 pkg YYBKURD last 20.06.2010
189E3846091384F9 pkg YYBTMO last 20.06.2010
188145511A0CD18C pkg YYBUIDD last 20.06.2010
188D6B240E402124 pkg YYCEAPE last 18.06.2010
18AB41F6133BDD11 pkg YYCINRV last 20.06.2010
18B805EA12F3C332 pkg YYDGST last 18.06.2010
181789321BFBB3D8 pkg YYDKS04 last 19.06.2010
181B2C7401A9FC9A pkg YYDKS8A last 20.06.2010
1879F1091ADCE689 pkg YYDOSFN last 19.06.2010
183301E706B4233F pkg YYDVT03 last 18.06.2010
18A8943D16338E8E pkg YYEUBEE last 20.06.2010
186EE7F60CD488D8 pkg YYEUBEW last 20.06.2010
186EE92F1F409408 pkg YYEUCIB last 19.06.2010
188C4A981E6E9230 pkg YYEUCIE last 19.06.2010
18B98C3C1F7E44E4 pkg YYEUSBE last 20.06.2010
186EE78D117F83F1 pkg YYEUSBT last 20.06.2010
18B82B461D96BE20 pkg YYEUSTE last 20.06.2010
186EE8D505EE0541 pkg YYEUSTR last 20.06.2010
18BAA63A1C7D9A2A pkg YYEUVAE last 20.06.2010
188BAC780154B422 pkg YYEUVAL last 20.06.2010
18B822861DFE33E6 pkg YYEUZNE last 11.06.2010
18C23A13149647C0 pkg YYEUZNE last 20.06.2010
188BABF307E2D7F0 pkg YYEUZNS last 20.06.2010
18B82B4D00198C70 pkg YYEUZZE last 20.06.2010
186EE9A10FC1B2D8 pkg YYEUZZM last 20.06.2010
18B990381523C23C pkg YYFALKA last 16.06.2010
18C46A870C4E1A26 pkg YYFALKA last 19.06.2010
187E2B101F3C907D pkg YYFIADE last 20.06.2010
188A436B069064B7 pkg YYFIHLK last 19.06.2010
18B990280B6CCD69 pkg YYFILSE last 19.06.2010
18AB17171194913F pkg YYFKURD last 11.06.2010
187B7D171A6CD7F5 pkg YYFRSP last 20.06.2010
189EFEA31EC04720 pkg YYGEBAF last 14.06.2010
189F005603D2925F pkg YYGEFIF last 17.06.2010
189ED3BE09F85021 pkg YYGEGLF last 14.06.2010
189F013400C673AE pkg YYGEPAF last 20.06.2010
189ED7EC1C921758 pkg YYGEPLF last 18.06.2010
189ED863172806FB pkg YYGEPMF last 18.06.2010
189F020B0987ED46 pkg YYGESAF last 18.06.2010
189F0244101B88ED pkg YYGESKF last 18.06.2010
18B8216417584F78 pkg YYGETCS last 20.06.2010
187C9515173D9F53 pkg YYGE010 last 20.06.2010
188A437714473E7B pkg YYHIKU last 19.06.2010
18A7A3710A67DC74 pkg YYHIKUN last 20.06.2010
1832443C1D84711B pkg YYINBPL last 20.06.2010
18B822650062DD43 pkg YYINDET last 20.06.2010
18ACFA3F04804376 pkg YYKA42E last 01.06.2010
182310A11B145BD8 pkg YYKONU last 20.06.2010
18B62677012C5608 pkg YYKORRE last 20.06.2010
18BAA7A81142E760 pkg YYLGGET last 19.06.2010
181A36B7138A6C8A pkg YYLGPUT last 19.06.2010
187A95AA09A506D6 pkg YYL1W1 last 19.06.2010
18B9906813E906B0 pkg YYMAKU last 20.06.2010
18BBECC9104F712A pkg YYMFGPH last 11.06.2010
18BFFDA00A2D1028 pkg YYMFGPH last 20.06.2010
187AE2C21D23B51E pkg YYNFEU4 last 18.06.2010
183247170B85EBB9 pkg YYNFOA4 last 20.06.2010
183DC362128E3FC2 pkg YYNFPLE last 19.06.2010
189E35EA0061244D pkg YYNFP36 last 20.06.2010
189CF7720DE16177 pkg YYNFP67 last 20.06.2010
18B2CB531233E42A pkg YYNLCPB last 20.06.2010
18B2CB551F965E2A pkg YYNLCPO last 20.06.2010
18B4DC1810FAE4E4 pkg YYNLVAB last 20.06.2010
18B557C41C8901AE pkg YYNLVAD last 20.06.2010
18B4D8FD1429F45C pkg YYNLVAO last 20.06.2010
18A6ADB21D7E2096 pkg YYOPAIS last 20.06.2010
18A8E6011AFE766E pkg YYOPGET last 18.06.2010
1823A39B06078CA3 pkg YYPRADR last 20.06.2010
180AA2BF1D5F1EE6 pkg YYPR02 last 20.06.2010
18BCDD0B0522035C pkg YYRGREG last 12.06.2010
18C22E3616CCC5D6 pkg YYRGREG last 20.06.2010
188AD9810DE66B2D pkg YYSELFX last 11.06.2010
18618E5B16CCB3F5 pkg YYSI2DB last 20.06.2010
187A6651140C2C12 pkg YYSN181 last 19.06.2010
18A666661ED6379A pkg YYSPUR last 20.06.2010
186160351F766550 pkg YYSPUR last 19.06.2010
18BB6E0D04961434 pkg YYTIZOD last 20.06.2010
18B81FC307656EE8 pkg YYTRACE last 16.06.2010
18B6E4AB0F3B9750 pkg YYTRPA2 last 19.06.2010
18A707E812852F5C pkg YYTRTRD last 20.06.2010
1834A1150CFA880E pkg YYTTCOE last 20.06.2010
18B80A7D01082A2F pkg YYUSWHH last 20.06.2010
186EE97902882EB6 pkg YYUSWHT last 20.06.2010
188B802108B80AB7 pkg YYUWI last 19.06.2010
18ACFA1B1E4715F4 pkg YYVALKF last 18.06.2010
18A433F817F18AA6 pkg YYVALKG last 20.06.2010
18B4D72410023B46 pkg YYVPSVF last 18.06.2010
1867344E175BE056 pkg YYVP03I last 20.06.2010
18997F841234BDA7 pkg YYWBVF last 20.06.2010
18B87CA60ED73848 pkg YYWBVOL last 20.06.2010
18B820CC1338F39E pkg YYWB101 last 20.06.2010
18B8200602734468 pkg YYWCSTB last 19.06.2010
18A664B007C350E4 pkg YYWIMAS last 18.06.2010
18B829810FF0D744 pkg YYWIMSU last 18.06.2010
18B828FC19B1250C pkg YYWIVER last 18.06.2010
18B64EDE1C21CB06 pkg YYWMPLE last 11.06.2010
18C288850C803EB6 pkg YYWMPLE last 18.06.2010
18BA87A3067E9016 pkg YYWM01E last 20.06.2010
18B6461D01183770 pkg YYWM04E last 20.06.2010
18BAD27D1AE060B2 pkg YYWM05E last 20.06.2010
18BAD288194CFF44 pkg YYWM51E last 20.06.2010
186E492017D626AD pkg YYWVVOR last 18.06.2010
188A6FB717511021 pkg YZVESRT last 20.06.2010
182887830D7C7DE2 pkg YZVKORC last 19.06.2010
188E80300E46BBD5 pkg YZVLEVE last 20.06.2010
186DD0371D9666CD pkg YZVZEDR last 20.06.2010
186DD039077E7956 pkg YZVZEDU last 18.06.2010
183471510A1F435A pkg YZV0400 last 18.06.2010
1834715319733847 pkg YZV0401 last 18.06.2010
189A77E1163A1858 pkg YZV521L last 18.06.2010
18B991D50F9277EF pkg YZV522L last 18.06.2010
18C148990C6EE086 pkg ZCSICHE last 20.06.2010
18661AA7025FD535 pkg ZCSICHE last 12.06.2010
4D4146664E554B59 pkg ZU90CSGD last 04.06.2010
6742697749544B57 pkg ZU94CSGC last 04.06.2010
188C792016CA9A57 pkg ZV0350 last 18.06.2010
1889503916E66EE8 pkg ZV0420 last 07.06.2010
188950391A97A51F pkg ZV0430 last 07.06.2010
1889503708B94B64 pkg ZV0450 last 07.06.2010
189A69B004ED274D pkg ZV0670 last 18.06.2010
187DFEF5040B4D30 pkg ZV5360 last 19.06.2010
187DFEF61D21E78C pkg ZV5380 last 19.06.2010
188C795F147E3F3D pkg ZV5530 last 18.06.2010
1888191E1DD9911A pkg ZV5900 last 18.06.2010
18B617AC17074272 pkg ZV5950 last 17.06.2010
1879EBA41894823F pkg ZV8500 last 18.06.2010
$#out 20100621 14:14:08
}¢--- A540769.WK.REXX(DREI) cre=2009-05-07 mod=2009-05-07-17.02.53 F540769 -----
drei 3.1
drei 3.2
drei 3.3
}¢--- A540769.WK.REXX(DREP) cre=2013-01-22 mod=2015-09-01-12.55.20 A540769 -----
/* rexx ***************************************************************
dRep: distribute rc Query user defined reports
synopsis: dRep fun dbSy
fun : function
a: delete all and load the KIDI63 standart reports
d: delete all
i: Insert the kidi63 reports. Only the new ones
o: overwrite existing and nonExisting ones with kidi63 standards
n: no update and don't ask again
u: update kidi63 standart reports, if a new release
?: this help
dbSy: list of db2Systems (group Name, e.g. DBAF) or * for all
history
1. 9.15 Walter: automatischer update ohne nachfragen
*******************/ /* end of help ***********************************
18. 6.13 Walter: sqlDisconnect vor return wenn kein update3
19. 4.13 Walter: Fragen angepasst, Errorhandling ohne FATAL
16. 4.13 Walter: Funktion D aktiviert
. 2.13 Walter: neu
**********************************************************************/
parse upper arg fun allDb
if fun == '' then
if sysVar('sysISPF') = 'ACTIVE' then
if adrEdit('macro (mArg) PROCESS', '*') == 0 then
parse upper var mArg fun allDb
if pos('?', fun allDb) > 0 then
return help()
if length(fun) <> 1 | pos(fun, 'ADINOU') < 1 then
call errHelp 'bad fun' fun 'in dRep' fun allDb
if allDb == '*' then do
call rzInfo
rz = sysVar(sysnode)
allDb = m.rzInfo.rz.dbSys
end
if allDb = '' then
call err 'i}no db2System in dRep' fun allDb
cr = userid()
call debug 'dRep fun='fun 'user='cr 'dbSys='allDb
m.tb = "PTI.PTRCQ_SAVED_RPTS"
do dx=1 to words(allDB)
dbSy = word(allDb, dx)
if length(dbSY) <> 4 then
call err 'i}bad db2System' dbSy 'in dRep' fun allDb
call sqlConnect dbSy
if fun = 'U' then do
fun = needUpdate(fun, cr)
if fun == '' then do
call sqlDisconnect
return
end
end
say dbSy 'replacing saved reports'
call dRep fun, cr
call sqlCommit
call sqlDisconnect
end
exit
needUpdate: procedure expose m.
parse arg fun, cr
sq1 = "select colname from" m.tb ,
"where type = '??' and sub_type = '??'"
m.kVers = sql2One(sq1 "and userid = 'KIDI63'", , '-')
if m.kVers == '-' then
call err 'no report KIDI63.??.?? please install first'
m.cVers = sql2One(sq1 "and userid = '"cr"'", , '-')
if m.cVers == m.kVers then do
call debug 'already current version' m.cVers
return ''
end
return 'A' /* do not ask anymore .........*/
address tso 'clear'
say 'DBA Team recommends Credit Suisse user defined reports:'
say 'o = overwrite all reports with CS standards (recommended)'
say 'a = delete all and load the CS standard reports'
say 'i = Insert the CS reports. Only the new ones'
say 'u = update CS standard reports, if a new release'
say 'd = delete all'
say 'n = no update and don''t ask again'
say '- = end without change'
parse upper pull ant
a1 = left(strip(ant), 1)
if pos(a1, 'ADINO') > 0 then
return a1
say 'keine Mutationen, manuelle Mutation mit tso dRep'
return ''
endProcedure needUpdate
dRep: procedure expose m.
parse arg fun, cr
if fun = 'O' then do
call sqlUpdate 3, "delete from" m.tb "c" ,
"where userid = '"cr"' and exists (",
"select 1 from" m.tb "k" ,
"where userid = 'KIDI63'",
"and c.type = k.type and c.sub_type = k.sub_type",
")", 100
say 'deleted' m.sql.3.updateCount
end
if fun == 'A' | fun == 'D' then do
call sqlUpdate 3, "delete from" m.tb "c" ,
"where userid = '"cr"'" , 100
say 'deleted' m.sql.3.updateCount
end
if fun == 'A' | fun == 'O' then do
call sqlUpdate 3, "insert into" m.tb ,
"select '"cr"', type, sub_type, version, col_order" ,
", rpt_info, colName from" m.tb ,
"where userid = '"KIDI63"'", 100
say 'inserted' m.sql.3.updateCount
end
if fun == 'I' | fun == 'N' then do
call sqlUpdate 3, "delete from" m.tb ,
"where userid = '"cr"' and type = '??'", 100
say 'deleted' m.sql.3.updateCount
wOnly = copies("and type = '??'", fun == 'N')
call sqlUpdate 3, "insert into" m.tb ,
"select '"cr"', type, sub_type, version, col_order" ,
", rpt_info, colName from" m.tb "k" ,
"where userid = '"KIDI63"'" wOnly "and not exists (",
"select 1 from" m.tb "c" ,
"where userid = '"cr"'",
"and c.type = k.type and c.sub_type = k.sub_type",
")", 100
say 'inserted' m.sql.3.updateCount
end
return 1
endProcedure dRep
rzInfo: procedure expose m.
m.rzInfo.rz = 'RZ0T RZ1 RZ2 RZX RZY RZZ RR2 RQ2'
m.rzInfo.rz0T.dbSys = 'DBIA DBTV'
m.rzInfo.rz1.dbSys = 'DBAF DBTF DBOC DVTB'
m.rzInfo.rz2.dbSys = 'DBOF DP2G DVBP'
m.rzInfo.rr2.dbSys = 'DBOF DP2G DVBP'
m.rzInfo.rQ2.dbSys = 'DBOF DP2G DVBP'
m.rzInfo.rz4.dbSys = 'DBOL DP4G'
m.rzInfo.rzx.dbSys = 'DE0G DEVG DPXG DX0G'
m.rzInfo.rzy.dbSys = 'DE0G DEVG DPYG'
m.rzInfo.rzz.dbSys = 'DE0G DEVG DPZG'
return
endProcedure rzInfo
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql.defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql.ini = 1
m.sql.conType = ''
m.sql.conDbSys = ''
m.sql.conhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
/* else if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
*/ else
call err 'no default subsys for' sysvar(sysnode)
m.sql.conDbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conDbSys = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' sqlFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = m.sql.defCurs
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlClose cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = m.sql.defCurs
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlClose cx
return res
endProcedure sql2One
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
return
endProcedue sqlReset
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, retOk, descOut
src = inp2str(src, '%qn%s ')
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlReset cx
return sqlExec('prepare s'cx s 'from :src', retOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx us
if us == '' then do
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlExePreSt: procedure expose m.
parse arg cx retOk
if arg() <= 1 then
return sqlExec('execute s'cx, retOk)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
endProcedure sqlExePreSt
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = f'.FLDS'
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
m.sql.cx.col2kx.cn = kx
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlFetchVars cx
if symbol('M.SQL.CX.COL2KX.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col2kx.nm
if m.sql.cx.col.kx == nm then
return kx
drop m.sql.cx.col.kx
return ''
endProcedure sqlCol2kx
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('sqlVarName.sNa') == 'VAR' then
sNa = 'COL'kx
sqlVarName.sNa = 1
return sNa
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql.sqlHaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if sqlCode == -204 & wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & verb=='DROP' ,
& wordPos('rod', retok) > 1 then do
hahi = m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql.sqlHaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' m.sql.conDbSys ,
|| ', host =' m.sql.conHost', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.mAlfRex1) < 1 then
iterate
ex = verify(src, m.mAlfRexR, 'n', cx)
if ex - cx > 100 then
iterate
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut.alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = ''
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
if m.err.eCat <> '' then do
parse source . . ggS3 . /* current rexx */
pTxt = ',error,fatal error,input error,syntax error,warning,'
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
msg = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1) ,
'in' ggS3':' msg
end
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut.ini == 1 then
return
m.ut.ini = 1
m.ut.digits = '0123456789'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
m.ut.alfNum = m.ut.alfa || m.ut.digits
m.ut.alfDot = m.ut.alfNum || '.'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut.alfLc, m.ut.alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut.digits) > 0 then
return 1
else
return verify(src, m.mId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(DREPWSH) cre=2013-01-22 mod=2013-01-22-12.53.58 A540769 ---
$#@
call sqlConnect dbaf
$=tb=PTI.PTRCQ_SAVED_RPTS
if 1 then
call sqlUpdate , "insert INTO" $tb ,
"select userid, '??', '??', version, 0, ''" ,
", char(current timestamp) ",
"from" $tb "where userid = 'KIDI63' order by version desc" ,
"fetch first row only"
call sqlDisconnect
$#out 20130122 12:53:55
$#out 20130122 12:53:29
*** run error ***
SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGHT
BE LEGAL ARE: AT MICROSECONDS MICROSECOND SECONDS SECOND MINUTES
MINUTE HOURS
src insert INTO
+ PTI.PTRCQ_SAVED_RPTS select userid, '??, '??', version, 0, '' , c...
> >>>pos 55 of 193>>>
stmt = insert INTO PTI.PTRCQ_SAVED_RPTS select userid, '??, '??', version, 0, ''
$#out 20130122 12:52:58
*** run error ***
SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGHT
BE LEGAL ARE: AT MICROSECONDS MICROSECOND SECONDS SECOND MINUTES
MINUTE HOURS
src insert INTO
+ PTI.PTRCQ_SAVED_RPTS select userid, '??, '??, version, 0, '' , ch...
> >>>pos 55 of 192>>>
stmt = insert INTO PTI.PTRCQ_SAVED_RPTS select userid, '??, '??, version, 0, ''
$#out 20130122 12:52:14
*** run error ***
no class found for object insert INTO PTI.PTRCQ_SAVED_RPTS select userid, '??, '
$#out 20130122 12:52:10
*** run error ***
no class found for object insert INTO PTI.PTRCQ_SAVED_RPTS select userid, '??, '
$#out
INSERT NSERT
INTO PTI.PTRCQ_SAVED_R INTO PTI.PTRCQ_SAVED_RPTS
( SELECT 'KIDI63', ( SELECT 'KIDI63',TYPE,SUB_TYPE,VERSI
COL_ORDER,RPT_IN COL_ORDER,RPT_INFO,COLNAME
FROM PTI.PTRCQ_S FROM PTI.PTRCQ_SAVED_RPTS
WHERE USERID = 'A390880') --SOURCE USER
;
}¢--- A540769.WK.REXX(DSNCOPY) cre=2016-06-09 mod=2016-06-12-08.46.58 A540769 ---
$#@
$=d1=DSN.DBX.DDK(DUMMY)
call dsnCopy $d1, 'RZX/'$d1
call dsnCopy $d1, 'RZY/'$d1
call dsnCopy $d1, 'RZZ/'$d1
call dsnCopy $d1, 'RQ2/'$d1
call dsnCopy $d1, 'RR2/'$d1
call dsnCopy $d1, 'RZ2/'$d1
}¢--- A540769.WK.REXX(DSNEX) cre=2014-10-16 mod=2014-10-16-16.48.30 A540769 ----
tstDsnEx: procedure expose m.
trace ?r
say dsnExists('A540769.wk.rexx')
say dsnExists('A540769.wk.rexxYY')
say dsnExists('A540769.wk.rexx(wsh3)')
say dsnExists('A540769.wk.rexx(wshNoNo)')
say dsnExists('RZ2/A540769.wk.rexx(wsh3)')
say dsnExists('RZ2/A540769.wk.rexx(wshNoNo)')
say dsnExists('RZ2/A540769.wk.rexxYY(wsh)')
return
endProceudre tstDsnEx
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
call adrCsm "mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short"
do ix=1 to mbr_mem#
say = mbr_name.ix
end
if mbr_mem# = 0 | mbr_mem# = 1 then
return mbr_mem#
call err 'csmExists mbr_mem#='mbr_mem# 'for dsn='aDsn
end
call writeDD inDD, 'I.', mbr_mem#
endProcedure dsnExists
}¢--- A540769.WK.REXX(DSNLIST) cre=2016-09-09 mod=2016-09-09-07.55.46 A540769 ---
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
}¢--- A540769.WK.REXX(DSNRLI) cre=2010-06-16 mod=2010-06-16-13.24.14 A540769 ---
/* rexx */
say 'calling'
call dsnRli 'abc'
say rc
}¢--- A540769.WK.REXX(EDITDIA) cre=2014-10-31 mod=2014-10-31-12.41.39 A540769 ---
$#@
$=lib =- dsn2jcl('~tmp.lctl')
$=oLb =- dsn2jcl('~tmp.lct2')
call mbrList mm, $lib
$do mx=1 to m.mm.0 $@¢
mbr = m.mm.mx
say mbr
call readDsn $lib'('mbr')', i.
ox=0
dia = 0
$do ix=1 to i.0 $@¢
ox = ox + 1
if pos('EXEC SQL', space(i.ix, 1)) > 0 then $@¢
o.ox = 'DIAGNOSE ALLDUMPS'
ox = ox + 1
dia = 1
$!
if dia &(word(i.ix, 1) = 'LISTDEF' ,
| pos('COPY LIST', space(i.ix, 1)) > 0) then $@¢
o.ox = 'DIAGNOSE END'
ox = ox + 1
dia = 0
$!
o.ox = i.ix
$!
if dia then $@¢
ox = ox + 1
o.ox = 'DIAGNOSE END'
$!
call writeDsn $oLb'('mbr') ::f', o., ox
$!
$#out 20141031 12:39:45
}¢--- A540769.WK.REXX(EDITMAC1) cre=2011-04-14 mod=2011-04-14-13.58.45 A540769 ---
parVar = 'wie gehts parmVar?'
rc = adrIsp('edit dataset(tmp.rexx(eins))' ,
'macro(editMac2) parm(parVar)' , '*')
say 'edit rc' rc
exit
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
if arg() > 0 then
say ' ' arg(1)
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EDITMAC2) cre=2011-04-14 mod=2011-04-14-13.57.57 A540769 ---
/* rexx */
call adrEdit 'macro (mainArgs)'
say 'macro args <'mainArgs'>'
exit
parVar = 'wie gehts parmVar?'
call adrIsp 'edit dataset(tmp.rexx(eins))' ,
'macro(editMac2) parm(parVar)'
exit
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
if arg() > 0 then
say ' ' arg(1)
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EJES) cre=2014-10-08 mod=2014-10-08-10.33.34 A540769 -----
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
}¢--- A540769.WK.REXX(ELA$C) cre=2012-04-06 mod=2012-04-06-20.24.13 A540769 ----
$#@ 00010001
CALL SQLCONNECT DBTF 00020000
$; 00030000
$<=¢ 00040000
SELECT STORNAME, DBNAME, NAME 00050002
FROM SYSIBM.SYSTABLESPACE 00060002
FETCH FIRST 10 ROWS ONLY 00070000
$! CALL SQLSEL 00080000
$#OUT 20120406 20:22:53 00090002
*** RUN ERROR *** 00100002
SQLCODE = -206: STORNAME IS NOT VALID IN THE CONTEXT WHERE 00110002
IT IS USED 00120002
STMT = PREPARE S10 INTO :M.SQL.10.D FROM :SRC 00130002
WITH INTO :M.SQL.10.D = M.SQL.10.D 00140002
FROM :SRC = SELECT STORNAME, DBNAME, NAME 00150002
$#OUT 20120406 20:22:27 00160001
}¢--- A540769.WK.REXX(ELARCHG) cre=2014-12-12 mod=2015-01-06-11.26.45 A540769 ---
/* rexx elar ddl cleaner
alle member aus lib lesen
DML statements (Meta Daten Update) entfernen
Member ohne DDL NICHT generieren
DB auf m.newDB ändern
stoGroup auf GSMS ändern
auf out schreiben
*/
call wshIni
lib = 'DSN.ELAR.DDLPROD.D1222'
out = 'DSN.ELAR.GENPROD'
m.bi = jBuf()
m.newDb = 'QTXELAR'
do mx=1 to mbrList(mm, lib)
call elarC lib'('m.mm.mx')', out'('m.mm.mx')'
end
exit
elarC: procedure expose m.
parse arg dIn, dOu
in = m.bi
call readDsn dIn, 'M.'in'.BUF.'
call scanOpen scanSqlReset(s, in)
cDDL = 0
dbs = ''
m.op.0 = 0
do forever
call scanSkip s
pA = scanPos(s)
if \ scanSqlId(s) then
if scanEnd(s) then
leave
else
call scanErr s, 'id expected'
v = m.s.val
f = ''
if wordPos(v, 'INSERT UPDATE DELETE' ) > 0 then
f = 'd'
else if v == 'CREATE' then do
cDDL = cDDL + 1
if \ scanSqlId(scanSkip(s)) then
call scanErr s, 'obj type expected'
ty = m.s.val
if ty = 'TABLESPACE' then do
if \ scanSqlId(scanSkip(s)) then
call scanErr s, 'ts expected'
ts = m.s.val
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'IN' then
call scanErr s, 'IN expected'
call scanSkip s
call mAdd op, 'u' scanPos(s)
if \ scanSqlId(s) then
call scanErr s, 'db expected'
if wordPos(m.s.val, dbs) < 1 then
dbs = dbs m.s.val
/* say 'cr ts' ts 'in' m.s.val 'dbs' dbs */
end
else if ty = 'TABLE' then do
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'tb expected'
tb = m.s.val
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected'
call scanSqlSkipBrackets s, 1
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'IN' then
call scanErr s, 'IN expected'
call scanSkip s
call mAdd op, 'u' scanPos(s)
if \ scanSqlQuId(s) then
call scanErr s, 'db.ts expected'
if wordPos(m.s.val.1, dbs) < 1 then
dbs = dbs m.s.val.1
/*say 'cr tb' tb 'in' m.s.val 'in db' m.s.val.1 'dbs' dbs*/
end
else if wordPos(ty, 'INDEX UNIQUE') < 1 then do
call scanErr s, 'bad create' ty
end
end
else if wordPos(v, 'ALTER DROP' ) > 0 then do
call scanErr s, 'bad ddl'
end
call scanSkip s
if scanLook(s, 1) \== ';' then
call scanSqlStmt s
pE = scanPos(s)
if f <> '' then
call mAdd op, f pA pE
do while scanLit(scanSkip(s), ';')
end
end
call scanClose s
/* say 'mbr' cDDl 'ddls,' m.op.0 'ops,' words(dbs) 'dbs' dbs */
if m.op.0 > 0 & cDDL > 0 then
call elarMod dOu, in'.BUF', op, dbs
else if m.op.0 > 0 & cDDL > 0 then
call err 'mbr' cDDl 'ddls,' m.op.0 'ops,' words(dbs) 'dbs' dbs
return
endProcedure elarC
elarMod: procedure expose m.
parse arg dOu, ii, op, dbs
/* say 'elarMod' m.op.0 'ops,' dbs 'dbs, to' dOu */
m.o.0 = 0
ix = 1
call scanSqlReset q, , 0
do ox=1 to m.op.0
parse var m.op.ox fu fLi fCo tLi tCo
if ix > fLi then
call err 'ix='ix 'but fLi='fLi 'for' m.op.ox
/* say ox fu fLi'#'fCo '-' tLi'#'tCo strip(m.ii.fLi) */
call mAddSt o, ii, ix, fLi-1
l0 = strip(left(m.ii.fLi, 72), 't')
if fu == 'u' then do
call scanSrc q, l0
m.q.pos = max(fCo-1, 1)
call scanSkip q
if m.q.pos <> fCo then
call scanErr q, 'db should start at fCo'
if \ scanSqlId(q) | wordPos(m.q.val, dbs) < 1 then
call scanErr q, 'no dbName at fLi'#'fCo'
call mAdd o, insert(m.newDb ,
, delStr(l0, fCo, length(m.q.val)), fCo-1)
ix = fLi+1
end
else if fu == 'd' then do
l1 = left(l0, fCo-1)
if l1 <> '' then
call mAdd o, l1
l2 = overlay('', left(m.ii.tLi, 72), 1, tCo)
if l2 <> '' then
call mAdd o, l2
ix = tLi + 1
end
else
call err 'bad fu' fu
end
call mAddSt o, ii, ix
stoG = GSMS1 GSMS2 GSMS3 GSMS4
do ox=1 to m.o.0
li = left(m.o.ox, 72)
if pos('GSMS', li) > 0 then do
call scanSrc q, li
call scanSkip q, li
pr = ''
py = m.q.pos
do while scanSqlClass(q)
if m.q.sqlClass \== 'i' then iterate
if wordPos(m.q.val, stoG) > 0 then do
if pr <> 'STOGROUP' then
call scanErr q, 'bad GSMS'
if substr(li, py, 5) \== m.q.val then
call scanErr q, 'GSMS mistmatch' py
m.o.ox = overlay(' ', m.o.ox, py+4)
end
pr = m.q.val
py = m.q.pos
end
end
end
cw = dbs stoG
do ox=1 to m.o.0
li = m.o.ox
do dx=1 to words(cw) until fnd
fnd = pos(word(cw, dx), li) > 0
end
if fnd then do
call scanSrc q, li
do while scanSqlClass(q)
if pos(m.q.sqlClass, 'qdi') > 0 then do
do vx=1 to m.q.val.0
if wordPos(m.q.val.vx, cw) > 0 then
call scanErr q, 'db/gsms in out'
end
end
end
end
end
call writeDsn dOu '::f', 'M.'o'.', , 1
return
endProcedure elarMod
/* rexx **********end;**************************************************
wsh: walter's rexx shell version 2.2
interfaces: 17. 6.14
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
|||achtung $@.sqlRdr() funktioniert nicht nur $@..¢sqlRdr() $!
||| sqlSel schreib !$#out |||||
||| einheitliches sql select/rdr syntax in wsh (mit ftab oder ohne|)
|||sql select aus rz2 muss wie csmExRx erfolgen (via WSH) ||||
--- history ------------------------------------------------------------
17.11.25 f: iirz2p ==> plex Buchstaben
*********/ /*** end of help ********************************************
17.06.14 f: %tS %tT und %tN mit MicroSekunden
16.06.14 csmCopy auch für LoadModule usw.
30.05.14 fix sql4obj fuer rcm profex
14.04.14 class vor obj, mit lazy
19.03.14 ii = installation Info
9.01.14 walter: redesign formatting (fmt eliminiert), csm.div.p0.exec
3.12.13 walter: db2 interface radikal geputzt
3.10.13 walter: uCount fuer TSO <-> unitCount fuer Csm
23. 9.13 walter: ws2 syntax
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class_O
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
parse arg spec
isEdit = 0
if spec = '' & m.err.ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & abbrev(m.editDsn, 'A540769.WK.REXX(WS') then
spec = 't'
end
end
if spec = '?' then
return help()
if translate(word(spec, 1)) == 'T' then
return wshTst(subword(spec, 2))
f1 = spec
rest = ''
inp = ''
out = ''
call wshIni
if m.err.os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = file('dd(out)')
end
end
else if m.err.os == 'LINUX' then do
inp = file('&in')
out = file('&out')
end
else
call err 'implement wsh for os' m.err.os
m.wshInfo = 'compile'
m.wsh_exitCC = 0
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit m.wsh_exitCC
/*--- test hook ----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg cmp
trace ?r
rest = strip(scanLook(m.cmp.scan))
call jClose m.cmp.scan
return wshTst(rest)
endProcedure wshHook_t
wshTst: procedure expose m.
parse arg rest
m.tst_csm = 1
if rest = '' then do /* default */
say funits(3e7, 'd')
call err tstEnd
call csmcopy 'CMN.DIV.P0.DB2J.#000197.LLB' ,
, 'RZ1/A540769.TST.LXB'
return 0
call csmcopy 'RZ1/A540769.TST.PS' ,
, 'RZ4/A540769.TST.PO3(EINS)'
return 0
call csmcopy 'RZ1/A540769.TST.LCTL(BBB)',
, 'RZ4/A540769.TST.PS'
return 0
call csmcopy 'A540769.WK.LLB' ,
, 'RZ1/A540769.TST.LLB'
call csmCopL 'RZ4/A540769.WK.JCL(QZ*)',
, 'RZ1/A540769.TST.yCL'
return 0
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect DBAF
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
exit 0
endProcedure wshTst
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg cmp
inp = strip(scanLook(m.cmp.scan))
call scanClose m.cmp.scan
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- sql hook -----------------------------------------------------*/
wshHook_S: procedure expose m.
parse arg cmp
s = m.cmp.scan
ki = '='
call scanVerify s, m.comp.chSpa
if scanVerify(s, m.comp.chKind) then
ki = left(m.s.tok, 1)
call scanChar s
rest = m.s.tok
call scanNl s
dbSy = word(rest, 1)
if abbrev(dbSy, '-') | \ (length(dbSy) = 4 ,
| (length(dbsy) = 8 & substr(dbSy,4,1) == '/')) then
dbSy = ''
else
rest = subWord(rest, 2)
res = compAST(cmp, 'P', ' f', '',
, compAstAddOp(cmp, compUnit(cmp, ki, '$#'), '@'))
call mAdd res, compAst(cmp, 'c', "call sqlConnect '"dbSy"'",
"; if \ sqlStmts( , 'rb ret', '"rest"') then m.wsh_exitCC=8" ,
"; call sqlDisConnect;" )
return res
endProcedure wshHook_s
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errCleanup
call errReset 'h'
call splitNl err, errMsg(' }'ggTxt)
call mMove err, 1, 2
isScan = 0
if wordPos("pos", m.err.4) > 0 ,
& pos(" in line ", m.err.4) > 0 then do
parse var m.err.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.err.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.err.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.err.0
call out m.err.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', err)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.err.0
call jWrite m.wsh.editOut, m.err.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, err
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.err.0
say m.err.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.ut_alfLC)
c1 = substr(m.ut_alfLC, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jReadVar(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl)
nm = substr(m.fl, lastPos('/', m.fl)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
say 'tstAll ws2 25.2.13...............'
call tstBase
call tstComp
call tstDiv
if m.err.os = 'TSO' then do
call tstZos
call tstTut0
end
return 0
endProcedure tstAll
/****** tstZos ********************************************************/
tstZOs:
call tstTime
call tstII
call sqlIni
call tstSqlRx
call tstSql
if m.tst_csm \== 0 then
call tstSqlCsm
call scanIni
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqls1
call tstSqlO
call tstSqlFTab
call tstSqlFTab2
call tstSqlFTab3
call tstSqlFTab4
call tstsql4obj
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
rt = adrTso("listcat volume entry('"dsn"')", 4)
/* say 'listct rc =' rt 'lines' m.tso_trap.0 */
cl = ''
vo = ''
if word(m.tso_trap.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
else if pos('NOT FOUND', m.tso_trap.1) > 0 then
return 'notFound'
else if word(m.tso_trap.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
do tx=2 to m.tso_trap.0 while vo = '' ,
& left(m.tso_trap.tx, 1) = ' '
/* say m.tso_trap.tx */
p = pos('MANAGEMENTCLASS-', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+16), 1), 'l', '-')
p = pos('VOLSER--', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', m.tso_trap.tx)
dt = strip(word(substr(m.tso_trap.tx, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/****** tstDiv ********************************************************/
tstDiv:
call tstSort
call tstMat
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
sortWords(also als a 05 4 1e2, cmp) a als also 05 1e2 4
sortWords(also als a 05 4, cmp) a als also 05 4
sortWords(also als a 05, cmp) a als also 05
sortWords(also als a, cmp) a als also
sortWords(also als, cmp) als also
sortWords(also, cmp) also
sortWords(, cmp) .
sortWords(also als a 05 4 1e2, <) a als also 4 05 1e2
sortWords(also als a 05 4 1e2, >) 1e2 05 4 also als a
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err.os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
wi = 'also als a 05 4 1e2'
do l=words(wi) by -1 to 0
call tstOut t, 'sortWords('subWord(wi, 1, l)', cmp)' ,
sortWords(subWord(wi, 1, l), cmp)
end
call tstOut t, 'sortWords('wi', <)' sortWords(wi, '<')
call tstOut t, 'sortWords('wi', >)' sortWords(wi, '>')
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9 trans(E?N*) .
match(einss, e?n *) 0 0 -9 trans(E?N *) .
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9 trans() .
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
match(abcdef, *abcdef*) 1 1 2,, trans(*ABCDEF*) ABCDEF
match(abcdef, **abcdef***) 1 1 5,,,,, trans(**ABCDEF***) ABCDEF
match(abcdef, *cd*) 1 1 2,ab,ef trans(*CD*) abCDef
match(abcdef, *abc*def*) 1 1 3,,, trans(*ABC*DEF*) ABCDEF
match(abcdef, *bc*e*) 1 1 3,a,d,f trans(*BC*E*) aBCdEf
match(abcdef, **bc**ef**) 1 1 6,a,,d,,, trans(**BC**EF**) aBCdEF
$/tstMatch/
*/
call tst t, "tstMatch"
call scanIni
call tstOut t, tstMatch1('eins', 'e?n*' )
call tstOut t, tstMatch1('eins', 'eins' )
call tstOut t, tstMatch1('e1nss', 'e?n*', '?*' )
call tstOut t, tstMatch1('eiinss', 'e?n*' )
call tstOut t, tstMatch1('einss', 'e?n *' )
call tstOut t, tstMatch1('ein s', 'e?n *' )
call tstOut t, tstMatch1('ein abss ', '?i*b*' )
call tstOut t, tstMatch1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, tstMatch1('ies000', '*000' )
call tstOut t, tstMatch1('xx0x0000', '*000' )
call tstOut t, tstMatch1('000x00000xx', '000*' )
call tstOut t, tstMatch1('000xx', '*0*', 'ab*cd*ef' )
call tstOut t, tstMatch1('abcdef', '*abcdef*' )
call tstOut t, tstMatch1('abcdef', '**abcdef***' )
call tstOut t, tstMatch1('abcdef', '*cd*' )
call tstOut t, tstMatch1('abcdef', '*abc*def*' )
call tstOut t, tstMatch1('abcdef', '*bc*e*' )
call tstOut t, tstMatch1('abcdef', '**bc**ef**' )
call tstEnd t
return
tstMatch1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) matchVars(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
r = r 'trans('m2')' matchRep(w, m, m2)
return r
endProcedure tstMatch1
tstIntRdr: procedure expose m.
i.1 = "//A540769J JOB (CP00,KE50),'DB2 REO',"
i.2 = "// MSGCLASS=T,TIME=1440,"
i.3 = "// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2"
i.4 = "//*MAIN CLASS=LOG"
i.5 = "//S1 EXEC PGM=IEFBR14"
call writeDsn 'RR2/intRdr', i., 5, 1
return
endProcedure tstIntRdr
tstII: procedure expose m.
/*
$=/tstII/
### start tst tstII ###############################################
iiRz2C(RZ2) 2
*** err: no rz=R?Y in ii II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no dbSys=D??? in ii II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZX RZY RZZ RQ2 RR2 RZ2 RZ4
ii_rz2db.rzx DE0G DEVG DX0G DPXG
rr2/dvbp RR2 R p=R d=RZ2, db DVBP P 1
iiixVPut 1: RZ2 2 p=B d=RZ2, db DBOF F 0
iiixVPut 1: RZ2 2 p=B d=RZ2, db DVBP P 1
iiixVPut 1: RZ2 2 p=B d=RZ2, db DP2G Q 0
$/tstII/
*/
call tst t, 'tstII'
call tstOut t, 'iiRz2C(RZ2) ' iiRz2C(RZ2)
call tstOut t, 'iiRz2C(R?Y) ' iiRz2C(R?Y)
call tstOut t, 'iiRz2C(RZY) ' iiRz2C(RZY)
call tstOut t, 'iiDbSys2C(de0G) ' iiDbSys2C('de0G')
call tstOut t, 'iiDbSys2C(d???) ' iiDbSys2C('d???')
call tstOut t, 'iiDbSys2C(DBOF) ' iiDbSys2C('DBOF')
call tstOut t, 'iiSys2RZ(S27) ' iiSys2RZ(S27)
call tstOut t, 'iiMbr2DbSys(DBP5)' iiMbr2DbSys(DBP5)
call tstOut t, 'ii_rz ' m.ii_rz
call tstOut t, 'ii_rz2db.rzx ' m.ii_rz2db.rzx
call pipeIni
call iiVPut 'rr2/ DvBp '
call tstOut t, 'rr2/dvbp ' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
w1 = wordPos('RZ2/DBOF', m.ii_rzDb)
do wx=w1 to w1+2
call tstOut t, 'iiixVPut' iiIxVPut(wx)':' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
end
call tstEnd t
return
endProcedure tstII
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
Lrsn2Lzt(C5E963363741) 2010-05-01-11.34.55.789008
Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs
timeZone 3600.00000 leapSecs 25.0000000
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2Gmt(C5E963363741) 2010-05-01-10.35.20.789008
Lrsn2Lzt(C5E963363741) 2010-05-01-11.34.55.789008
gmt2Lrsn(2011-03-31-14.35.01.234567) C78D87B86E38
lzt2Lrsn(2011-03-31-14.35.01.234567) C78D7A670B7C
Lrsn2Gmt(gmt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
gmt2Lrsn(Lrsn2Gmt(C5E963363741) C5E963363741
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
LZt2Stc(Lrsn2LZt(C5E963363741) C5E963363741
Lrsn2uniq(C5E963363741) CTNR6S7T back C5E963363740
$/tstTime/
*/
call jIni
call tst t, 'tstTime'
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out ,
'Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs'
call out 'timeZone' m.time_Zone * m.time_StckUnit ,
'leapSecs' m.time_Leap * m.time_StckUnit
call timeReadCvt 1
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
call out 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')' timeLZt2Lrsn(timeLrsn2LZt(s1))
call out 'Lrsn2uniq('s1')' timeLrsn2Uniq(s1) ,
'back' timeUniq2Lrsn(timeLrsn2Uniq(s1))
call tstEnd t
return
endProcedure tstTime
tstMat: procedure expose m.
/*
$=/tstMat/
### start tst tstMat ##############################################
. 0 sqrt 0 isPrime 0 nxPrime 3 permut 1 > 1 2 3 4 5
. 1 sqrt 1 isPrime 0 nxPrime 3 permut 2 > 2 1 3 4 5
. 2 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 1 3 2 4 5
. 3 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 2 3 1 4 5
. 4 sqrt 2 isPrime 0 nxPrime 5 permut 3 > 3 2 1 4 5
. 5 sqrt 2 isPrime 1 nxPrime 5 permut 3 > 3 1 2 4 5
. 6 sqrt 2 isPrime 0 nxPrime 7 permut 4 > 1 2 4 3 5
. 7 sqrt 2 isPrime 1 nxPrime 7 permut 4 > 2 1 4 3 5
. 8 sqrt 2 isPrime 0 nxPrime 11 permut 4 > 1 3 4 2 5
. 9 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 2 3 4 1 5
. 10 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 3 2 4 1 5
. 11 sqrt 3 isPrime 1 nxPrime 11 permut 4 > 3 1 4 2 5
. 12 sqrt 3 isPrime 0 nxPrime 13 permut 4 > 1 4 3 2 5
. 13 sqrt 3 isPrime 1 nxPrime 13 permut 4 > 2 4 3 1 5
. 14 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 1 4 2 3 5
. 15 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 2 4 1 3 5
. 16 sqrt 4 isPrime 0 nxPrime 17 permut 4 > 3 4 1 2 5
. 17 sqrt 4 isPrime 1 nxPrime 17 permut 4 > 3 4 2 1 5
. 18 sqrt 4 isPrime 0 nxPrime 19 permut 4 > 4 2 3 1 5
$/tstMat/
$/tstMat/
*/
call tst t, 'tstMat'
q = 'tst_Mat'
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
call tstOut t, right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
call tstEnd t
return
endProcedure tstMat
/****** tstSql ********************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 'select max(pri) MX from' tb, cc
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlCommit
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSqlRx: procedure expose m.
/*
$=/tstSqlRx/
### start tst tstSqlRx ############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSqlRx/ */
call jIni
call tst t, "tstSqlRx"
call sqlRxConnect
cx = 7
call sqlRxQuery cx, 'select * from sysdummy'
call sqlRxQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlRxFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlRxClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlRxQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlRxFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlRxClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlRxQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlRxFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlRxClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlRxFetch(cx) m.nm
call out 'fetchBT' sqlRxFetch(cx) m.nm
call sqlRxClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlRxFetch(cx) m.nm
call out 'fetchBi' sqlRxFetch(cx) m.nm
call tstEnd t
call sqlRxDisconnect
return
endProcedure tstSqlRx
tstSql: procedure expose m.
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
sql2St 1 st.0=1
sql2St:1 a=a b=2 c=--- d=d
sql2One a
sql2One a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSql/ */
call jIni
call tst t, "tstSql"
call sqlConnect
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
tstSqlCsm: procedure expose m.
/*
$=/tstSqlCsm/
### start tst tstSqlCsm ###########################################
*** err: SQLCODE = -204: S100447.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: subsys = DE0G, host = RZZ
*** err: implement sqlCmsQuery fetchVars ? or : :m.dst.ab, :m.dst.ef
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchB 1 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchB 0 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
$/tstSqlCsm/ */
call pipeIni
call tst t, "tstSqlCsm"
call sqlConnect 'RZZ/DE0G'
cx = 7
call sqlCsmQuery cx, 'select * from sysdummy'
call sqlCsmQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlCsmFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlCsmQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlCsmFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlCsmQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlCsmFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call tstEnd t
call sqlDisconnect
return
endProcedure tstsqlCsm
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call csvIni
call scanReadIni
call sqlConnect
call tst t, "tstSqlCSV"
r = csvWrt(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlCsv
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call pipeIni
call tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx, in2Str(,' ')
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlB
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-EXTENT-LOADRLAST+
TIME--------------REORGLASTTIME--------------REORGINSERT-REORGDELET+
E-REORGUPDATE-REORGUNCLUS-REORGDISORG-REORGMASSDE-REORGNEARIN-REORG+
FARIND-STATSLASTTIME--------------STATSINSERT-STATSDELETE-STATSUPDA+
TE-STATSMASSDE-COPYLASTTIME---------------COPYUPDATED-COPYCHANGES-C+
OPYUP-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN---SP+
ACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-REORG+
SC-REORGHA-HASHLASTUS-DRI-L-STATS01---
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUP-COPYUPDATETIME-------------I-+
--DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REORG+
HA-HASHLASTUS-DRI-L-STATS01---
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUP-COPYUPDATETIME-------------I-+
--DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REORG+
HA-HASHLASTUS-DRI-L-STATS01---
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REORGSC+
ANACCESS DRIVETYPE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASIZE +
. REORGHASHACCESS LPFACILITY
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTERSEN+
S HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call pipeIni
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 1, ,'-'), 17, 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabOthers abc
call sqlfTab abc
call sqlClose 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 2 1, 1 3 'c', '-'), 17, 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabAdd abc, DBNAME, '%-8C', 'db', 'allg vorher' ,
, 'allg nachher'
call sqlFTabAdd abc, NAME , '%-8C', 'ts'
call sqlFTabAdd abc, PARTITION , , 'part'
call sqlFTabAdd abc, INSTANCE , , 'inst'
ox = m.abc.0 + 1
call sqlFTabOthers abc
call fTabAddTit abc, ox, 2, 'others vorher'
call fTabAddTit abc, ox, 3, 'others nachher'
call sqlFTab abc
call sqlClose 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab
tstSqlFTab2: procedure expose m.
/*
$=/tstSqlFTab2/
### start tst tstSqlFTab2 #########################################
Und Eins Oder
. zw aber
Und Eins---------------zw aber---
. und eins 22223
. und eins 22224
Und Eins---------------zw aber---
Und Eins Oder
. zw aber
a-------------b---
aaa 222
a-------------b---
--- row 1 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2223000e04 22223
--- row 2 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2224000e04 22224
--- end of 2 rows -------------------------------------------------+
-------------
$/tstSqlFTab2/
*/
call pipeIni
call tst t, 'tstSqlFTab2'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', 22222 + row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 17, sq1
call sqlFTab sqlFTabOthers(sqlfTabReset(tstSqlFtab2, 17))
call sqlClose 17
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
call sqlFTab sqlFTabOthers(sqlfTabReset(tstSqlFtab2, 17))
call sqlClose 17
call sqlQuery 15, sq1
call sqlFTabCol sqlFTabOthers(sqlfTabReset(tstSqlFtab5, 15))
call sqlClose 15
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab2
tstSqlFTab3: procedure expose m.
/*
$=/tstSqlFTab3/
### start tst tstSqlFTab3 #########################################
Und Eins Oder
. zw aber
Und Eins--z---
. und eins 1
. und eins 2
Und Eins--z---
Und Eins Oder
. zw aber
a-----b---
aaa 222
a-----b---
$/tstSqlFTab3/
*/
call pipeIni
call tst t, 'tstSqlFTab3'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
r = jOpen(sqlRdr(sq1), '<')
f = sqlRdrfTabReset(r, 'tstSqFTab3')
b = in2Buf(r)
call sqlFTabDetect f, b'.BUF'
call fTab f, b
call jClose r
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
f = sqlfTabReset('tstSqFTab3t', 17)
st = 'tstSqFTab3st'
call sqlFetch2St 17, st
s2 = 'tstSqFTab3s2'
do sx=1 to m.st.0
m.s2.sx = st'.'sx
end
m.s2.0 = m.st.0
call sqlFTabDetect f, s2
call fTabBegin f
do sx=1 to m.st.0
call out f(m.f.fmt, st'.'sx)
end
call fTabEnd f
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab3
tstSqlFTab4: procedure expose m.
/*
$=/tstSqlFTab4/
### start tst tstSqlFTab4 #########################################
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
*** err: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: , FROM INTO
. e 2: src select x frm y
. e 3: > <<<pos 14 of 14<<<
. e 4: sql = select x frm y
. e 5: stmt = prepare s10 into :M.SQL.10.D from :src
. e 6: with into :M.SQL.10.D = M.SQL.10.D
sqlCode -104: select x frm y
a
3
1 rows fetched: select 3 "a" from sysibm.sysDummy1
dy => 1
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGHT
. BE LEGAL ARE: , FROM INTO
src select x frm y
. > <<<pos 14 of 14<<<
sql = select x frm y
stmt = prepare s10 into :M.SQL.10.D from :src
with into :M.SQL.10.D = M.SQL.10.D
sqlCode 0: rollback
ret => 0
$/tstSqlFTab4/
*/
call pipeIni
call tst t, 'tstSqlFTab4'
call sqlConnect
b = jBuf('select 1 "a" from sysibm.sysDummy1;' ,
, 'drop table gibt.EsNicht;' ,
, 'select 2 "a" from sysibm.sysDummy1;',
, ' select x frm y;',
, 'select 3 "a" from sysibm.sysDummy1;')
call tstout t, 'dy =>' sqlsOut(scanSqlStmtRdr(b, 0))
call tstout t, 'ret =>' sqlsOut(scanSqlStmtRdr(b, 0), 'rb ret')
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab4
tstSql4Obj: procedure expose m.
/*
$=/tstSql4Obj/
### start tst tstSql4Obj ##########################################
tstR: @tstWriteoV2 isA :tstClass-1 = -11
tstR: .a2i = -11
tstR: .b3b = b3
tstR: .D4 = D4-11+D4++++.
tstR: .fl5 = -111.1
tstR: .ex6 = -.111e-11
insert into cr.insTb -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', 'D4-11+D4++++', -111.1, -.111e-11
. ) ; .
insert into cr.insTbHex -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', x'C40760F1F14EC4F44E4E4E4E', -111.1, -.111e-1+
1
. ) ; .
tstR: @tstWriteoV4 isA :tstClass-2
tstR: .c = c83
tstR: .a2i = 83
tstR: .b3b = b3b8
tstR: .D4 = D483+D4++++++++++++++++++++++++++++++++++++++++++++++++
.++++++++++++++++++++++++++++++.
tstR: .fl5 = .183
tstR: .ex6 = .11183e-8
insert into cr.insTb -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , 'D483+D4++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
. || '++++++++++++++++++++++++'
. , .183, .11183e-8
. ) ; .
insert into cr.insTbHex -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , x'C407F8F34EC4F44E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. || '++++++++++++++++++++++++++++++++'
. || x'314E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. , .183, .11183e-8
. ) ; .
$/tstSql4Obj/
*/
call pipeIni
call tst t, 'tstSql4Obj'
call pipe '+N'
call tstDataClassOut '. c3 a2i i b3b c5 D4 c23 fl5 f8n2 ex6 e9n3',
, -11, -11
call tstDataClassOut 'c c3 a2i i b3b c5 D4 c93 fl5 f8n2 ex6 e9n3',
, 83, 83
call pipe 'P|'
do cx=1 while inO()
i = m.in
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call outO i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
call sqlIni
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s9 into :M.SQL.9.D from :src
. e 7: with into :M.SQL.9.D = M.SQL.9.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s9 into :M.SQL.9.D from :src
. e 3: with into :M.SQL.9.D = M.SQL.9.D
sys ==> server CHSKA000DP4G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: subsys = DE0G, host = RZZ
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: subsys = DE0G, host = RZZ
sys RZZ/DE0G ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCCsm/ */
sql1 = "select 1 i1, 'eins' c2 from sysibm.sysDummy1" ,
"union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1"
do tx=1 to 1 + (m.tst_Csm \== 0)
if tx = 1 then do
call tst t, "tstSqlCRx"
sys = ''
end
else do
call tst t, "tstSqlCCsm"
sys = 'RZZ/DE0G'
end
call sqlConnect sys
cx = 9
call sqlQuery cx, 'select * from sysibm?sysDummy1'
call sqlQuery cx, 'select * from nonono.sysDummy1'
call sqlQuery cx, "select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"
do while sqlFetch(cx, dst)
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call fTabAuto , sqlRdr(sql1)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call salUpdatePrepare 5, "insert into session.dgtt" ,
"values (?, ?, ?)"
call sqlUpdExecute 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdExecute 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call salUpdatePrepare 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdExecute 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrepare cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad' ,
'from session.dgtt d'
call sqlQueryExecute cx, 1, 1
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQueryPrepare cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryExecute cx, "u"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpdPre
tstsqlRxUpd: procedure expose m.
/*
$=/tstsqlRxUpd/
### start tst tstsqlRxUpd #########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstsqlRxUpd/ */
call tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlRxConnect
call sqlRxUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlRxUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlRxQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlRxFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlRxClose cx
call sqlRxQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlRxFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlRxClose cx
call sqlRxDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
sqlCode 0: set current schema = A540769
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sqlCode -204: select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect
call scanWinIni
call tst t, "tstSqlO"
call sqlStmts 'set current schema = A540769';
call sqlStmts 'select * from sysdummy';
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while jReadO(r)
o = m.r
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
C
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect
call sqlsOut "declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows"
call sqlsOut "insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only"
call sqlsOut "select count(*) cnt from session.dgtt"
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call sqlsOut "select count(*) cnt from session.dgtt"
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call sqlConnect
call tst t, "tstSqlO1"
qr = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen qr, m.j.cRead
call mAdd t.trans, className(m.qr.type) '<tstSqlO1Type>'
do while jReadO(qr)
abc = m.qr
if m.qr.rowCount = 1 then do
cx = m.qr.cursor
end
call outO abc
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlConnect
call pipeIni
call tst t, "tstSqlO2"
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlIni
call tst t, "tstSqlS1"
call sqlConnect
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
$/tstSqlStmt/
*/
call sqlConnect
call tst t, "tstSqlStmt"
cn = className(classNew('n* Sql u f%v C'))
call mAdd t.trans, cn '<sql?sc>'
call sqlStmts "set current schema = 'sysibm'"
call sqlsOut " set current schema = sysibm "
call sqlsOut " select current schema c from sysDummy1", , 'o'
call sqlsOut " (select current schema c from sysDummy1)", , 'o'
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
#jIn eof 3#
sqlCode 0: set current schema = s100447
$/tstSqlStmts/ */
call jIni
call sqlConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
tstCatTb: /* ???????????????????? tkr kopieren und testen */
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call tstEnd t
return
endProcedure tstCatTb
tstSqlDisDb: procedure expose m.
call sqlDsn di, 'DP4G', '-dis db(*) sp(*)' ,
'restrict advisory limit(*)', 12
m.oo.0 = 0
call sqlDisDb oo, di
say 'di.0' m.di.0 '==> oo.0' m.oo.0
trace ?r
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE, 3)
say 'DB2PDB6.RR2HHAGE.3 ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE,22)
say 'DB2PDB6.RR2HHAGE.22 ==>' ix m.oo.ix.sta
return
endProcedure tstSqlDisDb
/****** tstComp ********************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompTable
call tstCompSyntax
if m.err.os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.err.count = oldErr
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-¢2*3$! efg$-¢2*3$!hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-¢ 3 * 5 $! =" $-¢ 3 * 5 $!' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-¢4*5$! $-¢efg$-¢6*7$!"',
'abc$-¢4*5$! $-¢efg$-¢6*7$!$!',
, 'brackets $"$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!"',
'$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.vv)="o2String($.vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.vv= !vvDat
$.-¢"abc"$!=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.vv=" $.vv',
, '$"$.-¢""abc""$!="$.-¢"abc"$!'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.vv)="o2string($.vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call compIni
call vPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call vRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@=¢ zwoelf dreiZ $! ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@oRun'
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@prCa" $@prCa',
, '$$ run 6 vor call $"$@prCa"',
, '$@prCa',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) =7 to 8 $$ y=$y ti$-¢ti$! z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
/*
$=/tstCompStmtWith/
### start tst tstCompStmtWith #####################################
compile @, 3 lines: $@with $.vA $$ fEins=$FEINS fZwei=$FZWEI va&fEi+
ns=${vA&FEINS}
run without input
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=2Eins fZwei=2Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
$/tstCompStmtWith/
*/
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
v1 = onew(cl)
m.v1.feins = '1Eins'
m.v1.fzwei = '1Zwei'
v2 = oNew(cl)
m.v2.feins ='2Eins'
m.v2.fzwei ='2Zwei'
call vPutO 'vA', v1
call vPutO 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@¢' stmt ,
, '$@with $vB ' stmt stmt '$!'
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
*** err: no method oRun in class String
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $. {
. e 2: pos 3 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $- ¢
. e 2: pos 3 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@.<$*( co1 $*) $$abc
. e 2: pos 1 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition eins $$ = x
. e 2: pos 9 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@
. e 2: pos 1 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@=
. e 2: pos 1 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@: und
*** err: scanErr bad kind : in compExpr
. e 1: last token scanPosition und
. e 2: pos 5 in line 1: $@: und
*** err: no method oRun in class Null
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr var or namedBlock expected after proc
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% ¢roc p1$!
*** err: scanErr bad kind % in compExpr
. e 1: last token scanPosition ¢roc p1$!
. e 2: pos 5 in line 1: $@% ¢roc p1$!
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $!
. e 2: pos 12 in line 1: $@% ¢roc p1$!
*** err: no method oRun in class String
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@% ¢roc p1$!'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@%¢call roc p1 !
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition .
. e 2: pos 18 in line 1: $@%¢call roc p1 !
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@%¢call roc p1 !'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@^¢call( $** roc
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition .
. e 2: pos 18 in line 1: $@^¢call( $** roc
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@^¢call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$."string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
. m.tstComp.3 .
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!',
, '$$ out .$"$.-{o2}" $$.-¢ m.tstComp.2 $!',
, '$$ out .$"$.={o3}" $$.=¢ m.tstComp.3 $!',
, '$$ out .$"$.@{out o4}" $$.@@¢ call outO m.tstComp.4 $!',
, '$$ out .$"$.@¢$$abc $$efg$!" $$. $.@@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$. $.@@¢ $$. m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$<.¢ m.tstComp.2 $!',
, '$$ out .$"$.<{o3}" $$<=¢ m.tstComp.3 $!',
, '$$ out .$"$.<@{out o4}" $$<@¢ call outO m.tstComp.4 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith witx $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call vPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%¢oRun$!' ,
, ' $@%¢oRun $"-{1 arg only}" oder?$!' ,
, ' $@%-¢oRun $.".{1 obj only}" ''oder?''$! $=v2=zwei' ,
, ' $@%-¢oRun $"{2 args}", "und" $v2"?"$!' ,
, ' $@%-¢oRun $"{3 args}", $v2, "und drei?"$!'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=¢$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call vPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<-=¢$dsn $*+',
, tstFB('::f', 0) '$!',
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<'extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$. tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$- y $!
@@@file from 3 line @ block
$@<@¢ $$. tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty ¢ block
$@<¢ $!
{{{ empty ¢ block with comment
$@<¢ $*+ abc
$!
{{{ one line ¢ block
$@<¢ the only $"¢...$!" line $*+.
$vv $!
{{{ one line -¢ block
$@<-¢ the only $"-¢...$!" "line" $vv $!
{{{ empty #¢ block
$@<#¢
$!
{{{ one line #¢ block
$@<#¢ the only $"-¢...$!" "line" $vv $¢vv${x}$!
$!
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 72 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty ¢ block
{{{ empty ¢ block with comment
{{{ one line ¢ block
. the only ¢...$! line value-of-vv .
{{{ one line -¢ block
THE ONLY -¢...$! line value-of-vv
{{{ empty #¢ block
{{{ one line #¢ block
. the only $"-¢...$!" "line" $vv $¢vv${x}$!
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=. $.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@fE
---file with 2 lines $"$@<$f2"
$@.<.f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@.<.f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@.<.dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompPip2: procedure expose m.
/*
$=/tstCompPip21/
### start tst tstCompPip21 ########################################
compile @, 3 lines: $<¢ zeile eins .
run without input
(1 zeile eins 1)
(1 zeile zwei 1)
run with 3 inputs
(1 zeile eins 1)
(1 zeile zwei 1)
$/tstCompPip21/ */
call tstComp1 '@ tstCompPip21 3',
, ' $<¢ zeile eins ' ,
, ' zeile zwei $!' ,
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPip22/
### start tst tstCompPip22 ########################################
compile @, 3 lines: if ${>i1} then $@¢
run without input
#jIn eof 1#
nachher
run with 3 inputs
#jIn 1# eins zwei drei
<zeile 1: eins zwei drei>
<zwei>
nachher
$/tstCompPip22/ */
call tstComp1 '@ tstCompPip22 3',
, 'if ${>i1} then $@¢' ,
, ' $$ zeile 1: $i1 $$ zwei $| call pipePreSuf "<",">" $!',
, ' $$ nachher '
return
endProcedure tstCompPip2
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $=eins=<@¢ $@for vv $$ <$vv> $! .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
say 'dsn' $dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@¢ $@for vv $$ <$vv> $! ',
, ' $$ output eins $-=¢$eins$! $; ',
, ' $@for ww $$b${ww}y ' ,
, ' $>$-¢ $dsn $! 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.eins' ,
, ' $; $$ output piped zwei $-=¢$@<$dsn$!'
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^¢compile =$! +
$<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^¢compile =$! $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-¢
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $!
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '=/vD/valueVonD',
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@¢ $$ vF=$vF$!' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:¢ix=- $ix+1' ,
, ' $$ for $ix -> $v' ,
, '! | @¢call pipePreSuf "<<",">>"',
, '$! @%¢p1 total $ix im argumentchen$!',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:¢tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '! $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompTable: procedure expose m.
/*
$=/tstCompTable1/
### start tst tstCompTable1 #######################################
compile :, 6 lines: table $*( sdf $*) .
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = v1
tstR: .fZwei = valueZwei
tstR: .fDrei = undDrei
zweite
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = w1
tstR: .fZwei = wZwei
tstR: .fDrei = wwwDrei
$/tstCompTable1/
*/
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
call tstComp1 ': tstCompTable1',
, 'table $*( sdf $*) ' ,
, 'fEins fZwei $*(....$*) fDrei ' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"$!',
, ' v1 valueZwei undDrei ' ,
, '$$ zweite',
, ' w1 wZwei wwwDrei '
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew nn $*( sdf $*) $@:¢ .
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEinsB
tstR: .fZwei = withNewValue fZweiB
tstR: .fDrei = withNewValue fDreiB
tstR: @tstWriteoV4 isA :<TstCT1Class>
tstR: .fEins = withValue fEinsC
tstR: .fZwei = .
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call tstComp1 ': tstCompWithNew',
, 'withNew nn $*( sdf $*) $@:¢ ' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢ fDrei = withNewValuel drei $! $!! $$ $.nn' ,
, 'withNew out $*( sdf $*) $@:¢ ' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, '! with out =. oNew('cl') $@:¢',
, 'fEins = withValue fEinsC' ,
, 'fDrei = withValue fDreiC $!'
return
endProcedure tstCompTable
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
$=/tstCompSqlFTabSrc/
$$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh from sysibm.sysDummy1
$| $@. vPutO('lc', sqlRdr(scanSqlIn2Stmt()))
$| call fTab sqlFTabOthers(sqlRdrFTabReset($.lc, tstCompSql1))
$<>
$$ select 'aOh' ahaOhne, 'buuVar' buhVar from sysibm.sysDummy1
$| call sqlSel
$| t2 = fTabReset(sqlRdrFTabReset( , tstCompS2), '2 1', '2 c', '-')
ox = m.t2.0 + 1
call sqlFTabOthers t2
call fTab fTabAddTit(t2, ox, 2, '-----')
$<>
$$ select 'aOh' aDrei, 'buuDre' buhDrei from sysibm.sysDummy1
$| call sql2Tab
$/tstCompSqlFTabSrc/
$=/tstCompSqlFTab/
### start tst tstCompSqlFTab ######################################
compile @, 13 lines: $$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh fr+
om sysibm.sysDummy1
run without input
AHACOL--BUHHHH---
ahaaaax buuuuh
AHACOL--BUHHHH---
-----
AHA-BUHVAR---
aOh buuVar
-----
AHAOHNE
. BUHVAR
ADREI
. BUHDREI
ADR-BUHDRE---
aOh buuDre
ADR-BUHDRE---
ADREI
. BUHDREI
$/tstCompSqlFTab/
### start tst tstCompSql ##########################################
*/
call sqlConnect
call tstComp2 'tstCompSql', '@'
call tstComp2 'tstCompSqlFTab', '@'
call sqlDisConnect
return
endProcedure tstCompSql
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-¢sysvar(sysnode) date() time()?!ts=$ts 10*len=$-¢length($ts)*10$!
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-¢sysvar(sysnode) date() time()?!ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$@:¢table
db ts
DGDB9998 A976
DA540769 A977
$!
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:¢withNew out :¢
db = DGDB9998
ts =<:¢table
ts
A976
A977
$!
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:¢table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err.os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase ********************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstClass3
call tstClass4
call scanIni
call tstO
call oIni
call tstF
call tstFWords
call tstFtst
call tstMCat
call tstOEins
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstfUnits
call tstCsv
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMCat: procedure expose m.
/*
$=/tstMCat/
### start tst tstMCat #############################################
mCat(0, ) =;
mCat(0, 1) =;
mCat(0, 112222) =;
mCat(0, 3%#a1%c2) =;
mCat(0, 4%#a1%c2@%c333) =;
mCat(0, 5%#a1%c2@%c3@%c4) =;
mCat(1, ) =eins;
mCat(1, 1) =eins;
mCat(1, 112222) =eins;
mCat(1, 3%#a1%c2) =1eins2;
mCat(1, 4%#a1%c2@%c333) =1eins2eins333;
mCat(1, 5%#a1%c2@%c3@%c4) =1eins2eins3eins4;
mCat(2, ) =einszwei;
mCat(2, 1) =eins1zwei;
mCat(2, 112222) =eins112222zwei;
mCat(2, 3%#a1%c2) =1eins231zwei2;
mCat(2, 4%#a1%c2@%c333) =1eins2eins33341zwei2zwei333;
mCat(2, 5%#a1%c2@%c3@%c4) =1eins2eins3eins451zwei2zwei3zwei4;
mCat(3, ) =einszweidrei;
mCat(3, 1) =eins1zwei1drei;
mCat(3, 112222) =eins112222zwei112222drei;
mCat(3, 3%#a1%c2) =1eins231zwei231drei2;
mCat(3, 4%#a1%c2@%c333) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
mCat(3, 5%#a1%c2@%c3@%c4) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstMCat/ */
call pipeIni
call scanIni
call tst t, "tstMCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstMCat1 qx
call tstMCat1 qx, '1'
call tstMCat1 qx, '112222'
call tstMCat1 qx, '3%#a1%c2'
call tstMCat1 qx, '4%#a1%c2@%c333'
call tstMCat1 qx, '5%#a1%c2@%c3@%c4'
end
call tstEnd t
return
endProcedure tstMCat
tstMCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("mCat("m.qq.0"," fmt")", 30)"="mCat(qq, fmt)";"
return
endProcedure tstMCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate in mapAdd(m, eins, 1)
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate in mapAdd(m, zwei, 2ADDDUP)
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.10 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.4 :class = u
. choice u union
. .NAME = v
. stem 3
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = oCopy
. .MET = return oCopyV(m, t)
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. stem 0
. .3 refTo @CLASS.3 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.13 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.12 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.11 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.14 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.12 done :class @CLASS.12
. .4 refTo @CLASS.16 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.15 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.17 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.12 done :class @CLASS.12
. .6 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.15 done :class @CLASS.15
. .7 refTo @CLASS.21 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.20 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.11 done :class @CLASS.11
. .2 refTo @CLASS.19 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.4 done :class @CLASS.4
. .8 refTo @CLASS.23 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.22 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
$/tstClass2/
$=/tstClass2oo/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.108 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2oo/ */
call classIni
call tst t, 'tstClass2'
call classOut m.class_C, m.class_C
call tstEnd t
return
endProcedure tstClass2
tstClass3: procedure expose m.
/*
$=/tstClass3/
### start tst tstClass3 ###########################################
met v#o2String return m.m
met w#o2String return substr(m, 2)
met w#o2String return substr(m, 2)
*** err: no method nonono in class w
met w#nonono 0
met class#oCopy return classCopy('<class class>', m, t)
t1 4 flds FV, FR
clear q1 FV= FR= FW=! FO=
orig R1 FV=valFV FR=refFR FW=!valFW FO=obj.FO
copy <s1> FV=valFV FR=refFR FW=!valFW FO=obj.FO
t2 2 flds , EINS.ZWEI
clear q2 EINS.ZWEI= val=
orig R2 EINS.ZWEI=valR2.eins.zwei val=valR2Self
copy <s2> EINS.ZWEI=valR2.eins.zwei val=valR2Self
t3 0 flds M.<class tst...Tf33>.FLDS.1, M.<class tst...Tf33>.FLDS.2
clear q3 s1.0=0
orig R3 s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1.1+
..s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
copy <s3> s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1+
..1.s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
$/tstClass3/ */
call oIni
call tst t, 'tstClass3'
call mAdd t.trans, m.class_C '<class class>'
call tstOut t, 'met v#o2String' classMet(m.class_V, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#nonono' classMet(m.class_W, 'nonono')
call tstOut t, 'met class#oCopy' classMet(m.class_C, 'oCopy')
all = classNew('n? tstClassTf31 u f FV v, f FR r, f FW w, f FO o'),
classNew('n? tstClassTf32 u f EINS f ZWEI v, v') ,
classNew('n? tstClassTf33 u f S1' classNew('s u v, f F1 v,',
'f S2 s f F2 v'))
call mAdd t.trans, word(all, 3) '<class tst...Tf33>'
m.r1.fv = 'valFV'
m.r1.fr = 'refFR'
m.r1.fw = '!valFW'
m.r1.fo = 'obj.FO'
m.r2 = 'valR2Self'
m.r2.eins.zwei = 'valR2.eins.zwei'
m.r3.s1.0 = 1
m.r3.s1.1.s2.0 = 2
o.1 = "q 'FV='m.q.FV 'FR='m.q.fr 'FW='m.q.fw 'FO='m.q.fo"
o.2 = "q 'EINS.ZWEI='m.q.EINS.zwei 'val='m.q"
o.3 = "q 's1.0='m.q.s1.0"
p.1 = o.1
p.2 = o.2
p.3 = "q 's1.0='m.q.s1.0 's1.1='m.q.s1.1 's1.1.f1='m.q.s1.1.f1" ,
"'s1.1.s2.0='m.q.s1.1.s2.0 's1.1.s2.1.f2='m.q.s1.1.s2.1.f2",
"'s1.1.s2.2.f2='m.q.s1.1.s2.2.f2"
do tx=1 to words(all)
t1 = word(all, tx)
u1 = classFlds(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'flds' m.u1.1',' m.u1.2
call utInter("m='"q"';" classMet(t1, 'oClear'))
interpret "call tstOut t, 'clear'" o.tx
q = 'R'tx
interpret "call tstOut t, 'orig'" p.tx
q = utInter("m='"q"';t='';" classMet(t1, 'oCopy'))
call mAdd t.trans, q '<s'tx'>'
interpret "call tstOut t, 'copy'" p.tx
end
call tstEnd t
return
endProcedure tstClass3
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: missing key in mapGet(CLASS_N2C, 0)
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.8
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.8
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: missing key in mapGet(CLASS_N2C, 0)'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class_V m.class_W m.class_O) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'if(m.t.0==0,'',m.t.1))
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.1, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.1, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.1, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstClass4: procedure expose m.
parse arg
/*
$=/tstClass4/
### start tst tstClass4 ###########################################
f 1 eins
f 2 zwei
f 3 drei
f 4 vier
f 5 acht
s 1 fuenf
s 2 sechs
s 3 sie
$/tstClass4/
*/
call classIni
call tst t, 'tstClass4'
x = classNew('n* TstClass4a u f eins v, f%v zwei drei, f vier v',
', f%s-v fuenf sechs sie, f acht v')
ff = classFlds(x)
do fx=1 to m.ff.0
call tstOut t, 'f' fx m.ff.fx
end
st = classMet(x, 'stms')
do sx=1 to m.st.0
call tstOut t, 's' sx m.st.sx
end
call tstEnd t
return
endProcedure tstClass4
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class ---
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new return classClear('<class T..1>', oMutate(mNew('<class T..1>+
'), '<class T..1>'))
$/tstO/
*/
call mIni
call tst t, 'tstO'
call oIni
c1 = classNew('n? TstOCla1 u', 'm', 'met1 metEins', 'met2 metZwei')
call mAdd t.trans, c1 '<class T..1>'
o1 = 'tst_o1'
call tstOut t, 'o1.class' objClass(o1, '---')
o1 = oMutate('o1', c1)
call tstOut t, 'o1.class' objClass(o1, '---')
call tstOut t, 'o1#met1' objMet(o1, 'met1')
call tstOut t, 'o1#met2' objMet(o1, 'met2')
call tstOut t, 'o1#new' objMet(o1, 'new')
call tstEnd t
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
flds of <obj e of TstOEins> FEINS, FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins
*** err: no method nein in class String
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class O>
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call scanIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>' ,
, m.class_o '<class O>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'flds of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'flds of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay.jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx valueBefore
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jReadVar(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jReadVar(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in() 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' inVar(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in()
call out lx 'in()' m.in
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while jRead(b)
call out 'line' m.b
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call jIni
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while jReadO(b)
res = m.b
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while jReadO(c)
ccc = m.c
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'catRead' lx m.i
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'appRead' lx m.i
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Af', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 's',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
v1=value eins o=TST.ADR1
v3=v3WieGehts? o=!v3WieGehts?
v4=v4WieGehts? o=!v4WieGehts?
o o0=<o0>
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
s o0=0
o o0=<o0>
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
s o0=0
o0&fSt0=rexx o0.fSt0 o=!rexx o0.fSt0
o0&fRe0=rexx o0.fRe0 o=!rexx o0.fRe0
o0&=rexx o0-value o=!rexx o0-value
o o0=<o0>
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
s o0=0
o0&fSt0=put o0.fSt0 o=!put o0.fSt0
o0&fRe0=putO o0.fRe0 o=!putO o0.fRe0
o0&=put o0-value o=!put o0-value
$/tstEnvVars/
$=/tstEnvVars1/
### start tst tstEnvVars1 #########################################
m.o1=put-o1-value m.o1.fStr=put-o1.fStr m.o1.fRef=<o0>
*** err: no method o2String in class TstEnvVars1
*** err: o2String did not return
o o1=<o1> s o1=0
o1&fStr=put-o1.fStr o=!put-o1.fStr
o1&=put-o1-value o=!put-o1-value
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
o1&fRef=0 o=<o0>
o1&fRef&fSt0=put o0.fSt0 o=!put o0.fSt0
o1&fRef&fRe0=putO o0.fRe0 o=!putO o0.fRe0
m.o1&fNest.fSt0= put-o1.fNest.fSt0 m.o1&fNest.fRe0= !put-o1&fNest.f+
Re0
o1&fNest.fSt0=put-o1.fNest.fSt0 o=!put-o1.fNest.fSt0
o1&fNest&fRe0=put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars1/
$=/tstEnvVars2/
### start tst tstEnvVars2 #########################################
o2=<o2> getO(o2)=<o2> getO(o2&fRef)=<o1>
o2&fRef&fStr=put-o1.fStr o=!put-o1.fStr
o2&fRef&=put-o1-value o=!put-o1-value
*** err: no method o2String in class TstEnvVars0
*** err: o2String did not return
o2&fRef&fRef=0 o=<o0>
o2&fRef&fRef&fSt0=put o0.fSt0 o=!put o0.fSt0
o2&fRef&fRef&fRe0=putO o0.fRe0 o=!putO o0.fRe0
o2&fRef&fNest.fSt0=put-o1.fNest.fSt0 o=!put-o1.fNest.fSt0
o2&fRef&fNest&fRe0=put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars2/
$=/tstEnvVarsS/
### start tst tstEnvVarsS #########################################
oS=<oS> oS&fStS=<put oS.fStS>
oS&fStV.0=1 oS&fStV.1=<put oS.fStV.1>
m.oS.fStR.0=2 .2=!<put oS.fStR.2>
oS&fStR.0=2 .1=<put oS.fStR.1> .2=<put oS.fStR.2>
m.oS.0=9876 .1234=<put oS.1234>
oS&0=9876 .12=M.<oS>.12 .1234=<put oS.1234>
$/tstEnvVarsS/
*/
c0 = classNew('n? TstEnvVars0 u f fSt0 v, f = v, f fRe0 r')
c1 = classNew('n? TstEnvVars1 u f fStr v,f fRef r' ,
', f fNest TstEnvVars0, f = v')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPutO('v1', oMutate(tst'.'adr1, m.class_V))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' vHasKey('v1') 'get' vGet('v1')
call tstOut t, 'v2 hasKey' vHasKey('v2')
if 0 then
call tstOut t, 'v2 get' vGet('v2')
call vPutO 'theBuf', jBuf()
call pipe '+F' , vGetO('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGetO('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGetO('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGetO('v3')
call vPutO 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGetO('v4')
call vPutO 'o0', o0
call tstOut t, 'o o0='vGetO('o0')
call tstOut t, 's o0='vGet('o0')
fSt0 = 'fSt0'
fRe0 = 'fRe0'
m.o0 = 'rexx o0-value'
m.o0.fSt0 = 'rexx o0.fSt0'
m.o0.fRe0 = s2o('rexx o0.fRe0')
call tstOut t, 'o o0='vGetO('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGetO('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGetO('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&') 'o='vGetO('o0&')
call vPut 'o0&', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPutO 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGetO('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGetO('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGetO('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&') 'o='vGetO('o0&')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPutO 'o1', o1
call vPut 'o1&', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPutO 'o1&fRef', vGetO('o0')
call tstOut t, 'm.o1='m.o1 'm.o1.fStr='mGet(o1'.fStr'),
'm.o1.fRef='mGet(o1'.fRef')
call tstOut t, 'o o1='vGetO('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGetO('o1&fStr')
call tstOut t, 'o1&='vGet('o1&') 'o='vGetO('o1&')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGetO('o1&fRef')
call tstOut t, 'o1&fRef&fSt0='vGet('o1&fRef&fSt0') ,
'o='vGetO('o1&fRef&fSt0')
call tstOut t, 'o1&fRef&fRe0='vGet('o1&fRef&fRe0'),
'o='vGetO('o1&fRef&fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPutO 'o1&fNest.fRe0', s2o('put-o1&fNest.fRe0')
call tstOut t, 'm.o1&fNest.fSt0=' mGet(o1'.fNest.fSt0') ,
'm.o1&fNest.fRe0=' mGet(o1'.fNest.fRe0')
call tstOut t, 'o1&fNest.fSt0='vGet('o1&fNest.fSt0'),
'o='vGetO('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGetO('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPutO 'o2', o2
call vPutO 'o2&fRef', vGetO('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGetO('o2'),
'getO(o2&fRef)='vGetO('o2&fRef')
call tstOut t, 'o2&fRef&fStr='vGet('o2&fRef&fStr'),
'o='vGetO('o2&fRef&fStr')
call tstOut t, 'o2&fRef&='vGet('o2&fRef&'),
'o='vGetO('o2&fRef&')
call tstOut t, 'o2&fRef&fRef='vGet('o2&fRef&fRef') ,
'o='vGetO('o2&fRef&fRef')
call tstOut t, 'o2&fRef&fRef&fSt0='vGet('o2&fRef&fRef&fSt0') ,
'o='vGetO('o2&fRef&fRef&fSt0')
call tstOut t, 'o2&fRef&fRef&fRe0='vGet('o2&fRef&fRef&fRe0'),
'o='vGetO('o2&fRef&fRef&fRe0')
call tstOut t, 'o2&fRef&fNest.fSt0='vGet('o2&fRef&fNest.fSt0'),
'o='vGetO('o2&fRef&fNest.fSt0')
call tstOut t, 'o2&fRef&fNest&fRe0='vGet('o2&fRef&fNest.fRe0'),
'o='vGetO('o1&fNest.fRe0')
call tstEnd t
cS = classNew('n? TstEnvVarsS u f fStS v,f fStV s v, f fStR s r',
', f fNeS s TstEnvVars0, f = s v')
oS = oNew(cS)
call vPutO 'oS', oS
oT = oNew(cS)
call tst t, "tstEnvVarsS"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>',
, oS '<oS>', oT '<oT>'
call mPut oS'.fStS', '<put oS.fStS>'
call tstOut t, 'oS='vGetO('oS') 'oS&fStS='vGet('oS&fStS')
call mPut oS'.fStV.1', '<put oS.fStV.1>'
call mPut oS'.fStV.0', 1
call tstOut t, 'oS&fStV.0='vGet('oS&fStV.0'),
'oS&fStV.1='vGet('oS&fStV.1')
call mPut oS'.fStR.1', s2o('<put oS.fStR.1>')
call mPut oS'.fStR.2', s2o('<put oS.fStR.2>')
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.fStR.0='mGet(oS'.fStR.0'),
'.2='mGet(oS'.fStR.2')
call tstOut t, 'oS&fStR.0='vGet('oS&fStR.0'),
'.1='vGet('oS&fStR.1') '.2='vGet('oS&fStR.2')
call mPut oS'.1234', '<put oS.1234>'
call mPut oS'.0', 9876
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.0='mGet(oS'.0'),
'.1234='mGet(oS'.1234')
call tstOut t, 'oS&0='vGet('oS&0'),
'.12='vGet('oS&12') '.1234='vGet('oS&1234')
call tstEnd t
return
endProcedure tstEnvVars
tstvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1 TSTEW1
tstK1& get1 w
tstK1&f1 get1.f1 v
tstK1&f2 get1.f2 w
tstK1&F3 get1.f3 v
ttstK1&F3.FEINS get1.f3.fEins v
tstK1&F3.FZWEI get1.f3.fZwei w
tstK1&F3.FDREI o !get1.f3.fDrei w
tstK1&F3.FDREI get1.f3.fDrei w
tstK1&F3.1 get1.f3.1 w
tstK1&F3.2 TSTEW1
tstK1&F3.2&F1 get1.f1 v
tstK1&F3.2&F3.2&F2 get1.f2 w
*** err: missing key in mapGet(V, F1)
*** err: no method o2String in class String
*** err: o2String did not return
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3.FDREI o !get1.f3.fDrei w
F3.1 get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: missing key in mapGet(V, F1)
*** err: no method o2String in class String
*** err: o2String did not return
po-1 F1 0
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
call classMet c0, 'oFlds' /* new would do it, but we donot use it */
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call classMet cl, 'oFlds' /* new would do it, but we donot use it */
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call vPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGetO('tstK1')
call tstOut t, 'tstK1& ' vGet('tstK1&')
call tstOut t, 'tstK1&f1 ' vGet('tstK1&F1')
call tstOut t, 'tstK1&f2 ' vGet('tstK1&F2')
call tstOut t, 'tstK1&F3 ' vGet('tstK1&F3')
call tstOut t, 'ttstK1&F3.FEINS ' vGet('tstK1&F3.FEINS')
call tstOut t, 'tstK1&F3.FZWEI ' vGet('tstK1&F3.FZWEI')
call tstOut t, 'tstK1&F3.FDREI o ' vGetO('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.FDREI ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.1 ' vGet('tstK1&F3.1')
call tstOut t, 'tstK1&F3.2 ' vGetO('tstK1&F3.2')
call tstOut t, 'tstK1&F3.2&F1 ' vGet('tstK1&F3.2&F1')
call tstOut t, 'tstK1&F3.2&F3.2&F2' ,
vGet('tstK1&F3.2&F3.2&F2')
call tstOut t, 'F1 ' vGet('F1')
call vWith '+', tstEW1
call tstOut t, 'F1 ' vGet('F1')
call tstOut t, 'f2 ' vGet('F2')
call tstOut t, 'F3 ' vGet('F3')
call tstOut t, 'F3.FEINS ' vGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' vGet('F3.FZWEI')
call tstOut t, 'F3.FDREI o ' vGetO('F3.FDREI')
call tstOut t, 'F3.1 ' vGet('F3.1')
call tstOut t, 'pu1 F1 ' vGet('F1')
call vWith '+', tstEW2
call tstOut t, 'pu2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-1 F1 ' vGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3&F1 = v(c3&f1)
*** err: vAdrObj undef v(c3&f1) in name .F1&FEINS
*** err: vGet flag 0
. s c3&F1&FEINS = 0
*** err: vAdrObj null at .F3& in name .F3&FEINS
*** err: vGet flag 0
. s c3&F3&FEINS = 0
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: vAdrStem no stem cl TstEW, o <c3>, f .FEINS
*** err: vAdrStem not a stem cl=TstEW st= o=<c3>
*** err: vGet flag 0
. s c3&FEINS = 0
getO c3&
aft Put s c3&&FEINS = v&&fEins
Push c3 s F3.FEINS = val(c3&F3.FEINS)
aftPut= s F3.FEINS = pushPut(F3.FEINS)
push c4 s F1 = v(c4&f1)
put f2 s F2 = put(f2)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3&f1)
*** err: missing key in mapGet(V, F1)
*** err: no method o2String in class String
*** err: o2String did not return
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPutO 'c3', c3
call tstEnvSG , 'c3&F1'
call tstEnvSG , 'c3&F1&FEINS'
call tstEnvSG , 'c3&F3&FEINS'
call vPut 'c3&F3.FEINS', 'val(c3&F3.FEINS)'
call tstEnvSG , 'c3&F3.FEINS'
call tstEnvSG , 'c3&FEINS'
call tstOut t, 'getO c3&', vGetO('c3&')
call vPutO 'c3&', oNew('TstEW0')
call vPut 'c3&&FEINS', 'v&&fEins'
call tstEnvSG 'aft Put', 'c3&&FEINS'
call vWith '+', c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call vPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG 'aftPut=', 'F3.FEINS'
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4&f1)'
call vPut f222, 'f222 no stop'
call vWith '+', c4
call tstEnvSG 'push c4', f1
call vPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call vPut f222, 'f222 stopped', 1
call vPut 'F3.FEINS', 'put(f3.fEins)'
call tstEnvSG 'put .. ', 'F3.FEINS'
call vWith '-'
call tstEnvSG 'popW c4', f1
call vWith '-'
call vPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
return
endProcedure tstvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' vGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then do
ty = classNew('n TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
end
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr";' ,
'mr = m.m.rdr; if \ jRead(mr) then return 0;',
"m.m = m.mr; return 1",
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstDsnEx: procedure expose m.
/*
$=/tstDsnEx/
### start tst tstDsnEx ############################################
dsnExists(A540769.WK.rexx) 1
dsnExists(rzZ/A540769.WK.rexx) 1
dsnExists(A540769.WK.wk.rexxYY) 0
dsnExists(rzZ/A540769.WK.wk.rexxYY) 0
dsnExists(A540769.WK.rexx(wsh)) 1
dsnExists(rzZ/A540769.WK.rexx(wsh)) 1
dsnExists(A540769.WK.rexx(nonono)) 0
dsnExists(rzZ/A540769.WK.rexx(nonono)) 0
dsnExists(A540769.WK.rxxYY(nonon)) 0
dsnExists(rzZ/A540769.WK.rxxYY(nonon)) 0
*** err: error in csm mbrList ?ZZ/A540769.WK.RXXYY(NONON) .
. e 1: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 2: CSMSI77E?????SYSTEM=?ZZ +
. +
. ???????+
??????????
dsnExists(qzZ/A540769.WK.rxxYY(nonon)) 0
$/tstDsnEx/
*/
call tst t, 'tstDsnEx'
lst = 'rexx wk.rexxYY rexx(wsh) rexx(nonono) rxxYY(nonon)'
do lx =1 to words(lst)
d1 = 'A540769.WK.'word(lst,lx)
call tstOut t, 'dsnExists('d1')' dsnExists(d1)
call tstOut t, 'dsnExists(rzZ/'d1')' dsnExists('RZZ/'d1)
end
call mAdd t'.TRANS', '00'x '?', '0A'x '?'
call tstOut t, 'dsnExists(qzZ/'d1')' dsnExists('?ZZ/'d1)
call tstEnd t
return
endProceudre tstDsnEx
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+f', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err.os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err.os = 'TSO' then
return pds'('mbr') ::F'
if m.err.os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err.os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.io = 'vor anfang'
do x = 1 to num
if \ jRead(io) then
call err x 'not jRead'
else if m.io <> le x ri then
call err x 'read mismatch' m.io
end
if jRead(io) then
call err x 'jRead but should be eof 1'
if jRead(io) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.io) strip(m.io,'t')
return
endProcedure tstFileWr
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err.os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstMail: procedure expose m.
do i=1 to 3
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mAdd xy, 'und hier kommt der text' ,
, 'und zeile zwei timestamp' i':' date('s') time() ,
, left('und eine lange Zeile 159', 156, '+')159 ,
, left('und eine lange Zeile 160', 157, '+')160 ,
, left('und eine lange Zeile 161', 158, '+')161 ,
, left('und eine lange Zeile ', 200, '+')203 'y ',
, 'und kurz' ,
, 'und Schluss'
call mailSend xy
call sleep 60
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
tstF2 _ %-9C @%kt @%kd @%kb -----
_ 0 0s00 0 0 .
_ -1.2 -1s20 -1 -1 .
_ 2.34 2s34 2340m 2 .
_ -34.8765 -0m35 -35 -35 .
_ 567.91234 9m28 568 568 .
_ -8901 -2h28 -9k -9k
_ 23456 6h31 23k 23k
_ -789012 -9d03 -789k -771k
_ 34e6 394d 34M 32M
_ -56e7 -++++ -560M -534M
_ 89e8 +++++ 8900M 8488M
_ txtli txtli txtli txtli
_ undEinLan Text? Text? Text?
_ 8.76e-07 0s00 876n 0 .
_ 5.43e-11 0s00 54p 0 .
_ -8.76e-07 -0s00 -876n -0 .
_ -5.43e-11 -0s00 -54p -0 .
$/tstF/ */
call scanIni
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstF2 '_ %-9C @%kt @%kd @%kb', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call out "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call out 'tstF2' fmt '-----'
do vx=1 to words(vals)
call out f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFWords: procedure expose m.
/*
$=/tstFWords/
### start tst tstFWords ###########################################
??empty?? .
1space .
, %#e-- --
%#a%9c .
*%#a%-7c .
??empty?? eins
1space eins
, %#e-- eins
%#a%9c eins
*%#a%-7c eins .
??empty?? einszwei
1space eins zwei
, %#e-- eins, zwei
%#a%9c eins zwei
*%#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, %#e-- eins, zwei, drei
%#a%9c eins zwei drei
*%#a%-7c eins *zwei *drei .
$/tstFWords/
*/
call scanIni
ws = ' eins zwei drei '
call tst t, 'tstFWords'
do l=0 to 3
call tstOut t, '??empty?? ' fWords( ,subword(ws,1,l))
call tstOut t, '1space ' fWords(' ' ,subword(ws,1,l))
call tstOut t, ', %#e-- ' fWords(', %#e--' ,subword(ws,1,l))
call tstOut t, '%#a%9c ' fWords('%#a%9c' ,subword(ws,1,l))
call tstOut t, '*%#a%-7c ' fWords('*%#a%-7c' ,subword(ws,1,l))
end
call tstEnd t
return
endProcedure tstFWords
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SY => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sY => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
$/tstFTsts/
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DY => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
$/tstFTstD/
0----+----1----+----2----+----3
abcdefghijklmnopqrstuvwxyz
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dY => CH24|
120724 dM => H2400000|
120724 dH => A00000|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EY => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.2467 eS => 2024-05-31-00.00.00.000000|
31.05.2467 es => 2024-05-31-00.00.00|
31.05.2467 e => 2024-05-31-00.00.00|
31.05.2467 eD => 20240531|
31.05.2467 ed => 240531|
31.05.2467 eE => 31.05.2024|
31.05.2467 ee => 31.05.2467|
31.05.2467 et => 00.00.00|
31.05.2467 eT => 00:00:00.000000|
31.05.2467 eY => OF31|
31.05.2467 eM => F3100000|
31.05.2467 eH => A00000|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0000-01-01-12.34.56.000000|
12.34.56 ts => 0000-01-01-12.34.56|
12.34.56 t => 0000-01-01-12.34.56|
12.34.56 tD => 00000101|
12.34.56 td => 000101|
12.34.56 tE => 01.01.0000|
12.34.56 te => 01.01.00|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tY => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0000-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0000-01-01-23.45.06|
23.45.06.784019 T => 0000-01-01-23.45.06|
23.45.06.784019 TD => 00000101|
23.45.06.784019 Td => 000101|
23.45.06.784019 TE => 01.01.0000|
23.45.06.784019 Te => 01.01.00|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TY => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
$/tstFTstT/
$=/tstFTstY/
### start tst tstFTstY ############################################
FE25 YS => 2015-04-25-00.00.00.000000|
FE25 Ys => 2015-04-25-00.00.00|
FE25 Y => 2015-04-25-00.00.00|
FE25 YD => 20150425|
FE25 Yd => 150425|
FE25 YE => 25.04.2015|
FE25 Ye => 25.04.15|
FE25 Yt => 00.00.00|
FE25 YT => 00:00:00.000000|
FE25 YY => FE25|
FE25 YM => E2500000|
FE25 YH => A00000|
$/tstFTstY/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0000-08-23-17.49.50.000000|
I2317495 Ms => 0000-08-23-17.49.50|
I2317495 M => 0000-08-23-17.49.50|
I2317495 MD => 00000823|
I2317495 Md => 000823|
I2317495 ME => 23.08.0000|
I2317495 Me => 23.08.00|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MY => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0000-01-01-12.34.56.000000|
B23456 Hs => 0000-01-01-12.34.56|
B23456 H => 0000-01-01-12.34.56|
B23456 HD => 00000101|
B23456 Hd => 000101|
B23456 HE => 01.01.0000|
B23456 He => 01.01.00|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HY => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nY => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32102130 10:21:32.456789 NS => 3210-21-30-10.21.32.456789|
32102130 10:21:32.456789 Ns => 3210-21-30-10.21.32|
32102130 10:21:32.456789 N => 3210-21-30-10.21.32|
32102130 10:21:32.456789 ND => 32102130|
32102130 10:21:32.456789 Nd => 102130|
32102130 10:21:32.456789 NE => 30.21.3210|
32102130 10:21:32.456789 Ne => 30.21.10|
32102130 10:21:32.456789 Nt => 10.21.32|
32102130 10:21:32.456789 NT => 10:21:32.456789|
32102130 10:21:32.456789 NY => AV30|
32102130 10:21:32.456789 NM => V3010213|
32102130 10:21:32.456789 NH => B02132|
$/tstFTstN/
*/
call scanIni
say "f('%t ')" f('%t ')
allOut = 'Ss DdEetTYMH'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.2467' ,
't12.34.56' ,
'T23.45.06.784019' ,
'YFE25' ,
'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32102130*10:21:32.456789'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
call tstEnd t
end
return
endProcedure tstFTst
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
call fTabAddDetect abc, , st , , 'c3L'
call fTabAdd abc, 'a2i', '% 8E'
call fTabAddDetect abc, 'b3b', st , ,'drei'
call fTabAdd abc, 'd4', '%-7C'
call fTabAddDetect abc, 'fl5', st
call fTabAddDetect abc, 'ex6', st
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
call pipeIni
call scanIni
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-----ex6---
-11 -11 b3 -11+d4++++ -111.100 -1e-012
-1 -10 b 4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.000 -1e-010
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3
11+ 11 b3 11+d4+++++ 0.111 1.0e-12
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 1.1e-12
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-----ex6---
testData end
$/tstFTab/ */
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3, '-'
call fTabAddRCT ft, '=' , '%-6C', '.', , 'testData begin',
, 'testData end'
call fTabAddRCT ft, 'a2i' , '%6i'
call fTabAddRCT ft, 'b3b' , '%-12C'
call fTabAddRCT ft, 'd4' , '%10C'
call fTabAddRCT ft, 'fl5' , '%8.3I'
call fTabAddRCT ft, 'ex6' , '%7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstCSV: procedure
/*
$=/tstCSV/
### start tst tstCSV ##############################################
value,value eins,value zwei
value,"value, , eins",value zwei
value,"","value ""zwei"" oder?"
value,,"value ""zwei"" oder?"
$/tstCSV/ */
m.tstCsv.c.1 = ''
m.tstCsv.c.2 = eins
m.tstCsv.c.3 = zwei
m.tstCsv.c.0 = 3
call tst t, "tstCSV"
m.tstCsv.o = 'value'
m.tstCsv.o.eins = 'value eins'
m.tstCsv.o.zwei = 'value zwei'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstfUnits: procedure
/*
$=/tstfUnits/
### start tst tstfUnits ###########################################
. 1 ==> 1 =-> -1 =+> +1 =b> 1 .
. 5 ==> 5 =-> -5 =+> +5 =b> 5 .
. 13 ==> 13 =-> -13 =+> +13 =b> 13 .
. 144 ==> 144 =-> -144 =+> +144 =b> 144 .
. 1234 ==> 1234 =-> -1k =+> +1234 =b> 1234 .
. 7890 ==> 7890 =-> -8k =+> +7890 =b> 7890 .
. 0 ==> 0 =-> 0 =+> +0 =b> 0 .
. 234E3 ==> 234k =-> -234k =+> +234k =b> 229k
. 89E6 ==> 89M =-> -89M =+> +89M =b> 85M
. 123E9 ==> 123G =-> -123G =+> +123G =b> 115G
. 4567891E9 ==> 4568T =-> -5P =+> +4568T =b> 4154T
. 0.123 ==> 123m =-> -123m =+> +123m =b> 0 .
. 0.0000456789 ==> 46u =-> -46u =+> +46u =b> 0 .
. 345.567E-12 ==> 346p =-> -346p =+> +346p =b> 0 .
. 123.4567E-15 ==> 123f =-> -123f =+> +123f =b> 0 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> JKLMN =-> JKLMN =+> IJKLMN =b> JKLMN
. 1E77 ==> +++++ =-> -++++ =+> ++++++ =b> +++++.
. 1E-77 ==> 0f =-> -0f =+> +0f =b> 0 .
. 18.543E18 ==> 19E =-> -19E =+> +19E =b> 16E
. 20.987E20 ==> 2099E =-> -++++ =+> +2099E =b> 1820E
. 1 ==> 1.000 =-> -1.000 =+> +1.000 =b> 1.000 .
. 5 ==> 5.000 =-> -5.000 =+> +5.000 =b> 5.000 .
. 13 ==> 13.000 =-> -0.013k =+> +0.013k =b> 13.000 .
. 144 ==> 0.144k =-> -0.144k =+> +0.144k =b> 0.141k
. 1234 ==> 1.234k =-> -1.234k =+> +1.234k =b> 1.205k
. 7890 ==> 7.890k =-> -7.890k =+> +7.890k =b> 7.705k
. 0 ==> 0.000 =-> 0.000 =+> +0.000 =b> 0.000 .
. 234E3 ==> 0.234M =-> -0.234M =+> +0.234M =b> 0.223M
. 89E6 ==> 89.000M =-> -0.089G =+> +0.089G =b> 84.877M
. 123E9 ==> 0.123T =-> -0.123T =+> +0.123T =b> 0.112T
. 4567891E9 ==> 4.568P =-> -4.568P =+> +4.568P =b> 4.057P
. 0.123 ==> 0.123 =-> -0.123 =+> +0.123 =b> 0.123 .
. 0.0000456789 ==> 45.679u =-> -0.046m =+> +0.046m =b> 0.000 .
. 345.567E-12 ==> 0.346n =-> -0.346n =+> +0.346n =b> 0.000 .
. 123.4567E-15 ==> 0.123p =-> -0.123p =+> +0.123p =b> 0.000 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> HIJKLMN =-> HIJKLMN =+> HIJKLMN =b> HIJKLMN
. 1E77 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
. 1E-77 ==> 0.000f =-> -0.000f =+> +0.000f =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -19E =+> +19E =b> 16.083E
. 20.987E20 ==> 2099E =-> -2099E =+> +2099E =b> 1820E
$/tstfUnits/
$=/tstfUnitst/
### start tst tstfUnitst ##########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -0m59 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -0m59 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -0h10 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -1h00 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -0d23 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -1d00 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> -++++ --> -9999d
. 863965440 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
. 8.6400E+9 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstfUnitst/ */
call jIni
call tst t, "tstfUnits"
d = 86400
lst = 1 5 13 144 1234 7890 0 234e3 89e6 123e9,
4567891e9 0.123 0.0000456789 345.567e-12 123.4567e-15 ,
abc abcdefghijklmn 1e77 1e-77 18.543e18 20.987e20
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd') ,
'=->' fUnits( '-'word(lst, wx), 'd') ,
'=+>' fUnits( word(lst, wx), 'd', , , '+'),
'=b>' fUnits( word(lst, wx), 'b')
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd', 7, 3) ,
'=->' fUnits( '-'word(lst, wx), 'd', 7, 3) ,
'=+>' fUnits( word(lst, wx), 'd', 7, 3, '+'),
'=b>' fUnits( word(lst, wx), 'b', 7, 3)
end
call tstEnd t
call tst t, "tstfUnitst"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 't' ) ,
'++>' fUnits( word(lst, wx), 't', , , ' '),
'-+>' fUnits('-'word(lst, wx), 't' ),
'-->' fUnits('-'word(lst, wx), 't', , , ' ')
end
call tstEnd t
return
endProcedure tstfUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 .
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 cd) ) gh) .
string : 1 'eins?''' v=eins?'
space : 1 >
string : 1 "zwei""" v=zwei"
string ? : 1 ?drei??? v=drei?
*** err: scanErr ending Apostroph(") missing
. e 1: last token scanPosition "noEnd
. e 2: pos 27 in string 'eins?''' "zwei"""?drei???"noEnd
string : 0 v=drei?
$/tstSb/ */
call pipeIni
call scanIni
call tst t, 'tstSb'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanSBEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanSBEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanSBEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call scanSrc s, "'eins?'''" '"zwei"""?drei???"noEnd'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'space :' scanWhile(s, ' ') m.s.tok'>'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'string ? :' scanString(s, '?') m.s.tok 'v='m.s.val
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 .
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 cd) ) gh) .
$/tstSb2/ */
call tst t, 'tstSb2'
call scanIni
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call scanIni
call tst t, 'tstScan.1'
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 1: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 1: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(jReset0(scanRead(b)), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanReadOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanReadClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(jReset0(scanRead(jClose(b))), '<')
do x=1 while jReadO(s)
v = m.s
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(jReset0(scanUtilOpt(ScanRead(b))), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(jReset0(scanWin(b, '15@2')), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanName(s) then call tstOut t, 'name' m.s.tok
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
name Sechs
spaceNL
name com
info 15: last token com scanPosition sieben comAcht com com +
. com\npos 2 in line 7: m sieben com
spaceNL
name sieben
spaceNL
name Acht
spaceNL
info 20: last token scanPosition ueberElfundNochWeit com elfundim+
13\npos 1 in line 11: ueberElfundNoch
name ueberElfundNochWeit
spaceNL
name im13
spaceNL
name Punkt
info 25: last token Punkt scanPosition \natEnd after line 13: im13 +
. Punkt
infoE 26: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = jReset0(scanWin(b, '15@2'))
call scanOpt s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
cmd8 .
$/tstScanSqlStmt/ */
call pipeIni
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ' ,
, ';terminator test; ','terminator|; und-- ', 'so| | |',
, 'term: --#SET TERMINATOR : oder', 'ist: ',
, 'term> /*--#SET TERMINATOR > oder', ' */ in com nein >:')
call scanWinOpen scanSqlStmtOpt(scanWinReset(tstJcat, b, 30), ';')
call scanSqlOpt tstJcat
do sx=1 until nx = ''
nx = scanSqlStmt(tstJCat)
call tstOut t, 'cmd'sx nx
end
call scanReadCLose tstJCat
call tstEnd t
/*
$=/tstScanSqlStmtRdr/
### start tst tstScanSqlStmtRdr ###################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
$/tstScanSqlStmtRdr/ */
call tst t, 'tstScanSqlStmtRdr'
r = jOpen(ScanSqlStmtRdr(b, 30), '<')
do sx=1 while jRead(r)
call tstOut t, 'cmd'sx m.r
end
call jClose r
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg classs, ln
call tstOut t, 'scan src' ln
call scanSbReset scanOpt(s), ln
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/****** tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
call scanIni
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
ff = oFlds(fo)
do fx=1 to m.ff.0
f = fo || left('.', m.ff.fx \== '') || m.ff.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
ff = oFlds(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || left('.', m.ff.fx \== '') || m.ff.fx
m.f = tstData(m.f, m.ff.fx, '+'m.ff.fx'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/****** tst **********************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
tstUtc2d: procedure expose m.
/*
$=/tstUtc2d/
### start tst tstUtc2d ############################################
. ff 255
. ffff 65535
. 10000 65536 65536 = 1 * 16 ** 4
. 10001 65537
. ffffff 16777215
. 1000000 16777216 16777216 = 1 * 16 ** 6
. 1000001 16777217
. 20000FF 33554687
. 100000000 4294967296 4294967296 = 1 * 16 ** 8
. 300000000 12884901888 12884901888 = 3 * 16 ** 8
. 3020000EF 12918456559
$/tstUtc2d/
*/
numeric digits 33
call tst t, 'tstUtc2d'
all = 'ff ffff 10000 10001 ffffff 1000000 1000001 20000FF' ,
'100000000 300000000 3020000EF'
do ax = 1 to words(all)
a = word(all, ax)
if substr(a, 2) = 0 then
b = right(left(a, 1) * 16 ** (length(a)-1), 15) ,
'=' left(a, 1) '* 16 **' (length(a)-1)
else
b = ''
call tstout t, right(a, 15)right(utc2d(x2c(a)), 15)b
end
call tstEnd t
return
endProcedure tstUtc2d
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.err.count = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
m.tst_m = m
/* call err implement outDest 'i', 'call tstOut' quote(m)', msg'
*/ end
else do
drop m.tst_m
call oMutatName m, 'Tst'
call oMutatName m'.IN', 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
m.m.in.jReading = 1
m.m.in.jWriting = 1
m.m.in.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
cl = objClass(var, '')
if cl == '' then do
if var == '' then
call tstOut t, 'tstR: @ obj null'
else
call tstOut t, 'no class for' var 'in tstWriteO|'
end
else if abbrev(var, m.o_escW) then do
call tstOut t, o2String(var)
end
else if cl == m.class_V then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg mP
if right(mP, 3) == '.IN' then
m = left(mP, length(mP)-3)
else
call err 'tstReadO bad m' mP
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
m.mP = s2o(m.m.in.ix)
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstReadO
tstFilename: procedure expose m.
parse arg suf, opt
if m.err.os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if m.err.os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err.os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call splitNl err, errMsg(' }'ggTxt)
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copy tstAll end **************************************************/
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call sqlIni
call scanWinIni
return
endProcedure wshIni
/* copy wshCopy end ************************************************/
/* copy db2Util begin ************************************************/
tstDb2Ut: procedure expose m.
/*
$=/tstDb2Ut/
$/tstDb2Ut/
*/
call pipeIni
call scanIni
call tst t, 'tstDb2Ut'
call mAdd mCut(t'.IN', 0), ' template old ,' ,
, 'LOAD DATA INDDN oldDD ' ,
, '( cols )'
call db2UtilPunch 'rep iDsn=DSN.INPUT.UNL'
call tstEnd t
return
endProcedure tstDb2Ut
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' ix':' m.i.ix
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call mAdd o, ' SORTDEVT DISK '
do ix=ix+1 to m.i.0
if pos('CHAR(', m.i.ix) > 0 then
call mAdd o, strip(m.i.ix, 't') 'TRUNCATE'
else if word(m.i.ix, 1) word(m.i.ix, 3) == 'PART INDDN' then
call mAdd o, m.i.ix,
, ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
, ' DISCARDDN TDISC '
else
call mAdd o, m.i.ix
end
call writeDsn oDsn ':~'iDsn, 'M.O.', , 1
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* copy time begin ****************************************************
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.time_UQZero = x2d(timeGmt2Lrsn('2004-12-31-00.00.22.000000')) ,
% 64 * 64 /* 0 out last 6 bits */
if debug == 1 then do
say 'stckUnit =' m.time_StckUnit
say 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
say 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.time_UQZero
say 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
end
m.time_ReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.time_ReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.time_Zone + m.time_Leap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.time_ReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.time_Zone-m.time_Leap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose uniqZero uniqDigits debug
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
if m.time_ReadCvt \== 1 then
call timeReadCvt
lrsn = left(lrsn, 12, 0)
numeric digits 15
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
if m.time_ReadCvt \== 1 then
call timeReadCvt
numeric digits 15
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = right(d2x(u1 + m.time_UQZero), 12, 0)
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.chOp = '.-<@|?%^'
m.comp.chKind = '.-=#@:'
m.comp.chKiNO = '=#:'
m.comp.chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
call mPut 'COMP.INFO..', "object"
call mPut 'COMP.INFO.-', "string"
call mPut 'COMP.INFO.=', "skeleton"
call mPut 'COMP.INFO.#', "text"
call mPut 'COMP.INFO.@', "rexxShell"
call mPut 'COMP.INFO.:', "pureShell"
m.comp.chDol = '$'
m.comp.chSpa = ' 'x2c('09')
call mPut 'COMP.EXTYPE.b', m.comp.chDol'{}' /* braces */
call mPut 'COMP.EXTYPE.d', m.comp.chDol /* data */
call mPut 'COMP.EXTYPE.s', m.comp.chDol /* strip */
call mPut 'COMP.EXTYPE.w', m.comp.chDol||m.comp.chSpa /* word */
m.comp.idChars = m.ut_alfNum'@_'
m.comp.wCatC = 'compile'
m.comp.wCatO = 'out'
m.comp.wCatS = 'do withNew with for forWith ct proc table'
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = m'.scan'
return m
endProcedure compReset
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipe '+F', ouO
call oRun r
if ouO \== '' then
call pipe '-'
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
s = m.m.scan
if spec = '' then
spec = '@'
else
spec = strip(spec, 'l')
if m.m.cmpRdr == '' then do
call scanSbReset scanOpt(scanSbReset(s, spec), , '0123456789')
end
else do
call scanReadOpen scanReadReset(s, m.m.cmpRdr, , '0123456789'),
, 1, spec
end
m.m.out = ''
m.m.end = ''
res = compAst(m, '¢')
eOld = m.err.count
do forever
one = ''
if pos(scanLook(s, 1), m.comp.chKind'*') > 0 then do
call scanChar s, 1
ki = m.s.tok
one = compileOne(m, ki)
end
else if \ scanName(s) then do
call scanErr s, 'kind or hook expected after $#'
end
else if m.s.tok == 'out' then do
m.m.out = scanPos(s)
leave
end
else if m.s.tok == 'end' then do
if m.m.end = '' then
m.m.end = scanPos(s)
one = compileOne(m)
end
else if m.s.tok == 'version' then do
call scanSpace s
if \ scanWord(s) | m.s.tok \== '2.0' then
call scanErr s, 'only version 2.0 is supported'
call scanNl s, 1
end
else do
one = compileOne(m, , m.s.tok)
end
if one \== '' then
call mAdd res, one
if scanEnd(s) then
leave
if \ scanLit(s, '$#') then
return scanErr(s, m.comp.info.ki "expected: compile",
ki "stopped before end of input")
end
if m.m.cmpRdr \== '' then
call scanReadClose s
if m.err.count <> eOld then
return ''
return oRunner(compAst2Rx(m, ';', res))
endProcedure compile
/*--- compile or use hook for one part from spec or input -----------*/
compileOne: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
call compSpComment m
if ki == '*' | m.m.end \== '' then do
do until scanLook(s, 2) == '$#' | scanEnd(s)
call scanNl s, 1
end
return ''
end
if ki \== '' then do
call scanNl s
return compUnit(m, ki, '$#')
end
say 'interpreting hook' hook':' strip(scanLook(s))
interpret return 'wshHook_'hook'(m)'
endProcedure compileOne
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp.chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if pos(ki, '.-=@:') > 0 then do
a = compAst(m, '¢')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '$<>') then
return a
end
end
else if ki == '#' then do
res = compAST(m, '¢')
call scanChar s
if verify(m.s.tok, m.comp.chSpa) > 0 then
call mAdd res, compAstAddOp(m,
, compAst(m, '=', strip(m.s.tok, 't')), '$')
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAstAddOp(m,
, compAst(m, '=', strip(m.s.src, 't')), '$')
end
return res
end
call err 'bad kind' ki 'in compUnit'
endProcedure compUnit
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
if symbol('m.comp.exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
s = m.m.scan
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-', '='))
astKi = translate(ki, 'os=c', '.-=@')
laPrim = 0
gotTxt = 0
m.res.containsC = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if scanVerify(s, m.comp.exType.type, 'm') then do
one = compAST(m, astKi, m.s.tok)
if verify(m.s.tok, m.comp.chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp.chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compOPBE(m, '', 1, 0)
else
one = compPrimary(m, substr('-.', 1+(ki == '.'), 1))
if one = '' then do
call scanSetPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, 'c')
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m,'&',m.r.var, r), ops)
do while pos(right(ops, 1) ,'.@') > 0
ops = left(ops, length(ops)-1)
end
if right(ops, 1) \== '^' then
call scanErr s, 'compile can only be used by ^'
return compASTAddOp(m, compAst(m,'M'), left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression) ---------------------*/
compOPBE: procedure expose m.
parse arg m, ki, env, withEx
s = m.m.scan
old = scanPos(s)
call scanVerify s, m.comp.chOp || m.comp.chKiNO
op = m.s.tok
kx = verify(op, m.comp.chKiNO, 'm')
if kx = length(op) & op \== '' then
nop
else if kx \== 0 then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
else if pos(right(op, 1), m.comp.chKind'^%') > 0 then
nop
else if ki == '<' | right(op, 1) == '<' then
op = op'='
else if ki \== '' then
op = op || ki
else
call scanErr s, 'no kind after ops' op
if pos(scanLook(s, 1), '/¢') > 0 then do
o2 = op
if env == '<' & \ abbrev(op, '<') then
o2 = '<'op
else if env == 1 then
if op == '.' then
o2 = '|.'
else if wordPos(op, '- @ <') > 0 then
o2 = op || op
return compBlock(m, o2)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp.chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1))
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanSetPos s, old
return ''
endProcedure compOPBE
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp.chDol, scanLit(s, m.comp.chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, 'o', ', ')
call mAdd m.res.2, compOPBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOPBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAst(m, '¢')
nlLe = 0 /* sophisticated logic using left and right NLs*/
tb = ''
do forever
if tb \== '' then do
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
if e1 \== '' then do
aa = compAst(m, '¢')
fx = 0
do until e1 == ''
do fx=fx+1 to m.tb.0 until px < m.ff.end
ff = m.tb.fx
end
if fx > m.tb.0 then
call scanErr s, 'right of all table fields'
if m.s.pos <= m.ff.pos then
call scanErr s, 'before table field' m.ff.name
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
end
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, 'o', "oNew('"m.tb.class"')"),
, aa, compAst(m, '*', '$.'))
end
nlRi = scanNL(s)
end
else if ki == ':' then do
call compSpNlComment m, '*'
nlRi = 0
end
else if ki == '@' then do
call compSpNlComment m
one = compExpr(m, 's', ki)
if one == '' then
nlRi = 0
else if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
else do
do forever /* scan all continued rexx lines */
nlRi = 1
la = m.one.0
la = m.one.la
if m.la.kind \== 'c' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
call mAdd res, one
end
end
else do
do cc=0 while compComment(m)
end
one = compExpr(m, 'd', ki)
nlRi = scanNL(s)
if one == '' then do
if nlLe & nlRi & cc < 1 then
call mAdd res,compAstAddOp(m,compAst(m,'='),'$')
end
else if m.one.containsD | (nlLe & nlRi,
& \ (cc > 0 | m.one.containsC)) then do
call mAdd res, compAstAddOp(m, one, '$')
end
else do
call mFree one
end
end
nlLe = nlRi
if \ nlRi then do
one = compStmt(m)
if one = '' then
return compAstFree0(res)
if m.one.kind == 'T' then
tb = one
else
call mAdd res, one
end
end
endProcedure compExprStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
res = compAss(m, '=')
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp.chDol'$',m.comp.chDol'@',m.comp.chDol,'@') then
pre = m.s.tok
if pre == m.comp.chDol'$' then
return compAstAddOp(m, compCheckNN(m, compOPBE(m,'=', 1),
, 'block or expression expected after $$'), '$')
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then do
if wCat == 'v' then
return compAstAddOp(m, compAst(m, '=', fu), '%.&')
if compSpNlComment(m) then
return compAstAddOp(m,
, compCheckNE(m, compExpr(m, 's','@'),
, 'block/primary/expr after $@'), ';')
one = compOPBE(m, '@', '@')
if one \== '' then
return one
call scanSetPos s, old
return ''
end
if wordPos(fu, 'for forWith with withNew') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m, left('o', fu == 'withNew'))
end
else do
b = compAss(m, '.', 'o')
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compStmt(m), "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b == '' then
call scanErr s, "variable or named block after" fu
b = compAst(m, '=', b)
end
call mAdd res, b, st
if fu == 'withNew' then do
vars = substr(compAstAssignedVars(m.res.2), 3)
m.res.class = classNew('n* CompTable u' vars)
m.res.1 = compAst(m, 'A', ,m.res.1, compAst(m, 'o',
, "oNew('"m.res.class"')"))
end
if abbrev(fu, 'with') then do
r1 = m.res.1
if m.r1.kind == 'A' then do
a1 = m.r1.1
if m.a1.var == 'o' then do
call mAdd res, compAstAddOp(m, m.r1.2, '$.')
m.res.1 = m.r1.2
call mFree a1
end
end
end
return res
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== 'c' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compStmt(m), 'stmt after do')
return res
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compStmt(m),
, 'ct statement'));
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compStmt(m), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
if fu == 'table' then do
call compSpComment m
if scanNl(s) then
call compSpComment m
res = compAst(m, 'T', 'c')
flds = ''
do while compName(m, 'v') == 'v'
f1 = compAst(m, 'T')
m.f1.end = m.s.pos
m.f1.pos = m.s.pos - length(m.s.tok)
m.f1.name = m.s.tok
m.f1.text = 'f' m.f1.name m.f1.pos m.f1.end
call mAdd res, f1
flds = flds', f' m.s.tok 'v'
call compSpComment m
end
if \ scanNl(s) then
call scanErr s, 'name or nl after table expected'
if m.res.0 < 1 then
call scanErr s, 'no names in table'
m.res.class = classNew('n* CompTable u' substr(flds, 3))
m.res.text = 'c' cl
return res
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '¢' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '¢' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, ki, vk
s = m.m.scan
call scanLit s, m.comp.chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then
call scanErr s, '= expected in assignment after' pr 'var'
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOPBE(m, ki, 1),
, 'block or expression in assignment after' pr)
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanErr s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
else
v = compAst(m, '=', v)
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '¢', '/') then
return ''
start = m.s.tok
if pos(right(ops, 1), '%^') > 0 then
ops = ops'='
if ops == '' | pos(right(ops, 1), m.comp.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
kc = right(ops, 1)
if pos(kc, '%^') > 0 then
ops = left(ops, length(ops)-1)
else
kc = ''
starter = start
if start == '¢' then
stopper = m.comp.chDol'!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp.chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
if kc == '' then do
res = compUnit(m, ki, stopper)
end
else do
call compSpComment m
res = compOPBE(m, kc'.', '1', 0)
if m.res.kind \== 'M' then do
r1 = m.res.1
if m.res.kind \== '*' then
res = compAst(m, kc, , res)
else
res = compAst(m, kc, , r1)
end
args = compExpr(m, 's', ki)
if args \== '' then
call mAdd res, args
end
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp.chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp.chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp.chDol'*(') then do
do forever
if scanVerify(s, m.comp.chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp.chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp.chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp.chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp.wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp.wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if wordPos(m.s.tok, m.comp.wCatO) > 0 then do
if pos('o', cats) > 0 then
return 'o'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a
if a == '' then
return 1
do while a \== '' & m.a.kind == '*'
a = m.a.1
end
return a == '' | (m.a.kind \== '¢' & m.a.0 < 1)
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ****************************************
------- atoms, no children
= string constant
----------- rexx fragments
c rexxStatement
s string
o object
r run
f file
------- containers
¢ block ==> * c-.
@ code = 1 stmt ==> *
- string
. object
* operand chain ==> 1
------- molecules
& variable access==> 1 =-
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
I?? Input ==> * .
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
call err 'compAST bad kind' ki / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '¢@-.*&ABCDFPTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=csorf') > 0 then do
m.n.0 = 'kind'ki
end
else do
call err "compAst kind '"ki"' not supported"
1/0
end
return n
endProcedure compAST
/*--- free AST if empty ----------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
do while right(ops, 1) == m.a.kind
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
ops = translate(ops, '-', '=')
if m.a.kind \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstAssignedVars: procedure expose m.
parse arg a
res = ''
if m.a.kind == 'F' then
return ''
if m.a.kind == 'A' then do
a1 = m.a.1
if m.a1.kind == '=' & m.a1.var == 'v' then do
if words(m.a1.text) \= 1 then
call astErr a1 'bad var'
a2 = m.a.2
say m.a2.kind m.a2.text
if pos(m.a2.kind, '-=s') > 0 ,
| (m.a2.kind == '*' & abbrev(m.a2.text, '-')) then
res = ', f' m.a1.text 'v'
else if pos(m.a2.kind, '.<@o') > 0 ,
| (m.a2.kind == '*' & abbrev(m.a2.text, '.<@')) then
res = ', f' m.a1.text 'r'
else
call astErr a2, 'string or object????'
end
end
if datatype(m.a.0, 'n') then
do ax=1 to m.a.0
res = res || compAstAssignedVars(m.a.ax)
end
return res
endProcedure compAstAssignedVars
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
compAstOnlyOut: procedure expose m.
parse arg a, rec
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind == '*' then
if abbrev(m.a1.text, '$') then
iterate
if m.a1.kind = '¢' & rec \== 0 then
if compAstOnlyOut(a1) then
iterate
return 0
end
return 1
endProcedure compAstOnlyOut
/*--- return the code for an AST with operand chain trg --------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ';') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if pos(o1, '$') > 0 tOnlyOut then
return compCode2rx(m, oR, 'call out' f';')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if o2 \== '.' & o2 \== '<' then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGetO('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == '$' then
return compCode2rx(m, oR, 'call outO' f';')
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ';%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if o1 == ';' | o1 == '%' then /*??? immer % verwenden ???*/
return compCode2Rx(m, oR, 'call oRun' f';')
return compObj2rx(m, ops, f)
endProcedure compObj2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
if ki == 'c' then
return compCode2Rx(m, ops, m.a.text)
if ki == 's' then
return compString2rx(m, ops, m.a.text)
if ki == 'o' then
return compObj2Rx(m, ops, m.a.text)
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
if m.a.0 = 1 then
return compAst2rx(m, ops, m.a.1)
else
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '@' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || ')';')
if ki == '¢' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '¢' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
if \ compAstOnlyOut(a) then
return compAst2Rx(m, ops';', a)
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind == '*' & abbrev(m.a1.text, '$') then
b = compAst2rx(m, overlay('-',m.a1.text,1), m.a1.1)
else if m.a1.kind == '¢' then
b = compAst2rx(m, '-', a1)
else
call compAstErr a, 'onlyOut but' ax'='a1 ,
'kind='m.a1.kind 'text='m.a1.text
res = compCatRexx(res, b, ' ')
end
/* ???? only necessary if part of expression ????*/
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '<' then
return compAst2Rx(m, ops'@', a)
if o1 == '.' then
return compAst2Rx(m, oR'|', a)
if o1 == '|' | o1 == '?' then
if m.a.0 = 1 & compAstOnlyOut(a, 0) then do
a1 = m.a.1
if m.a1.kind \== '*' | \ abbrev(m.a1.text, '$') then
call compAstErr a, 'onlyOut but',
'1='a1 'kind='m.a1.kind 'text='m.a1.text
return compAst2Rx(m, oR'.'substr(m.a1.text, 2), m.a1.1)
end
else
return compFile2Rx(m, ops, compAst2rx(m, '<;', a))
if pos(o1, '@;') > 0 then do
if m.a.0 = 1 then /*???pipe und code können multi stmts */
return compCode2Rx(m, ops, 'do;' ,
compAst2rx(m,';',m.a.1) 'end;')
res = ''
do ax=1 to m.a.0
res = res compAst2rx(m, ';', m.a.ax)
end
if res = '' then
return compCode2Rx(m, ops, 'nop;')
return compCode2Rx(m, ops, 'do;'res 'end;')
end
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vReadO('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 = 1 then
return compRun2Rx(m, ops, c1)
args = compAst2Rx(m, '', m.a.2)
if ki == '%' then
return compCode2Rx(m, ops, 'call oRun' c1',' args';')
call err 'implement'
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl)';')
else
return compCode2Rx(m, ops,
, 'call vPutO' nm',' compAst2Rx(m, '.', vl)';')
end
if ki == 'B' then do /* proc */
call vPutO utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,';', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, ';', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)';'
if m.a.text \== '' then
res = res "call vPut '"m.a.text"'," m.a.text";"
return compCode2Rx(m, ops, res compAst2Rx(m, ';', m.a.2),
"end;")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, ';', m.a.2)
if abbrev(m.a.text, 'with') then do
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPutO ') | right(v, 1) \==';' then
call scanErr s, 'bad vPutO' v
v = 'vPutO('substr(v, 12, length(v)-12)')'
end
if m.a.0 <= 2 then
return 'call vWith "+",' v';' st 'call vWith "-";'
a3 = m.a.3
if m.a3.kind == '*' then
return 'call vWith "+",' v';' st,
compObj2Rx(m, m.a3.text, "vWith('-')")
end
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'forWith' then
st = 'call vWith "=", vGetO('v');' st
if abbrev(m.a.text, 'for') then
st = 'do while vReadO('v');' st 'end;'
if m.a.text == 'forWith' then
st = 'call vWith "+";' st 'call vWith "-";'
return compCode2Rx(m, ops, st)
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res "call pipe '"t1"'," a1";" ,
compAst2Rx(m, ';', m.a.ax)
end
return compCode2Rx(m, ops, res "call pipe '-';")
end
if ki == 'R' then do /* Run with args */
res = 'call oRun' compAst2Rx(m, , m.a.1)
if m.a.0 > 1 then
res = res',' compAst2Rx(m, , m.a.2)
return compRun2rx(m, ops, res';')
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = ',' compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'compile(comp(in2Buf())' args')')
end
call compAstErr a, 'comAst2rx bad ops' ops 'kind' ki
endProcedure compAst2rx
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end ******************************************************/
/* copy scanSB begin ***************************************************
Achtung: inc generiert SB aus scanSB, Aenderungen nur in scanSB|
ScanSB: basic scan
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
variable interface
scanSrc(m, source) starts scanning a single line
scanEnd(m) : returns whether we reached end of input
scanErr(m, txt): error with current scan location
m is an address, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
/*--- return the next len characters until end of src ----------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src ---------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset ------------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset ------------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End -------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
px = m.m.pos
do forever
px = pos(sep, m.m.src, px)
if px = 0 then do
m.m.tok = ''
return 0
end
px = px + length(sep)
if \ abbrev(substr(m.m.src, px), sep) then do
m.m.tok = substr(m.m.src, m.m.pos, px-m.m.pos)
m.m.pos = px
return 1
end
px = px + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
t1 = m.m.tok
qu = right(t1, 1)
if \ scanStrEnd(m, qu) then do
m.m.pos = m.m.pos - length(t1)
return scanErr(m, 'ending Apostroph('qu') missing')
end
m.m.val = repAll(left(m.m.tok, length(m.m.tok)-1), qu||qu, qu)
m.m.tok = t1 || m.m.tok
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = ' '
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.val)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return next word --------------------------------*/
scanSkWord: procedure expose m.
parse arg m, stopper, ucWord, eMsg
if scanWord(scanSkip(m), stopper, ucWord) then
return m.m.val
else if eMsg == '' then
return ''
else
call scanErr m, eMsg 'expected'
endProcedure scanSkWord
/*--- go back the current token --------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value')
m.m.pos = cx
return
endProcedure scanBack
/*--- set new src - allow scanning without open ----------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanSBStart(m)
endProcedure scanSrc
/*--- start scanning -------------------------------------------------*/
scanSBStart: procedure expose m.
parse arg m
m.m.pos = 1
m.m.tok = ''
return m
endProcedure scanSBStart
scanSBSpace: procedure expose m.
parse arg m
nx = verify(m.m.src, ' ', , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
res = nx <> m.m.pos
m.m.tok = left(' ', res)
m.m.pos = nx
return res
endProcedure scanSBSpace
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
scanErr: procedure expose m.
parse arg m, txt
if arg() < 3 then
return err('s}'txt'\n'scanInfo(m))
else
return err('scanErr' txt'\n'arg(3))
endProcedure scanErr
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
endProcedure scanSBInfo
/*--- return position in simple format -------------------------------*/
scanSBPos: procedure expose m.
parse arg m
return 'singleSrc' m.m.pos
return if(m.m.pos > length(m.m.src), 'E', 'singleSrc' m.m.pos)
/*--- set position to position in arg to------------------------------*/
scanSetPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
/*--- return true if at end of src -----------------------------------*/
scanSBEnd: procedure expose m.
parse arg m
return m.m.pos > length(m.m.src)
/*--- return true if at comment --------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.scr, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/* copy scanSB end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input: with multiple lines
==> all of scanSB
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an address, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call mAdd m.class_s ,
, classNew('m scanEnd return 1'),
, classNew('m scanInfo return scanSBInfo(m)') ,
, classNew('m scanPos return scanSBPos(m)')
call classNew 'n ScanSB u', 'm',
, 'scanEnd return 1',
, 'scanNL m.m.tok = ""; return 0',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanSBInfo(m)' ,
, 'scanPos return scanSBPos(m)',
, 'jOpen return scanSBStart(m)',
, 'jClose m.m.pos = "-- closed --"; return m',
, 'isWindow 0',
, "jReadO if scanType(m) == '' then return 0;" ,
" m.m = oClaCopy('"ts"', m, ''); return 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2, arg3",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r==''then return 0" ,
"; m.m = r; return 1"
return
endProcedure scanIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanOpen
scanSB: procedure expose m.
parse arg n1, np, co
return oNew('ScanSB')
endProcedure scanSB
/*--- start scanning with a new single src ---------------------------*/
scanSBReset: procedure expose m.
parse arg m, m.m.src
return scanSbStart(oMutatName(m, 'ScanSB'))
endProcedure scanSBReset
scanInfo: procedure expose m.
parse arg m
interpret objMet(m, 'scanInfo')
/*--- return true if at end of src -----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
interpret objMet(m, 'scanEnd')
/*--- scan over white space, nl, comments ...-------------------------*/
scanSpace: procedure expose m.
parse arg m
fnd = 0
do while scanSBSpace(m) | scanCom(m) | scanNl(m)
fnd = 1
end
m.m.tok = left(' ', fnd)
return fnd
endProcedure scanSpace
/*--- scan next line -------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scan one comment -----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = 0
return m
endProcedure scanOpt
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr m, 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
/* ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v') */
call classNew 'n ScanRead u ScanSB', 'm',
, 'scanEnd return m.m.atEnd' ,
, 'scanNL return scanReadNL(m, unCond)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg()>=3, arg(3)" ,
, "jClose call scanReadClose m"
call classNew "n EditRead u JRW", "m" ,
, "jRead return editRead(m)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanReadReset(oNew('ScanRead'), rdr, n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr, n1, np, co
return oMutatName(scanOpt(m, n1, np, co), 'ScanRead')
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, hasLine0, line0
call scanReadO0 m
if hasLine0 == 1 then
m.m.src = line0
else
call scanNL m, 1
return m
endProcedure scanReadOpen
scanReadO0: procedure expose m.
parse arg m
call scanSrc m
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
call jOpen m.m.rdr, '<'
return m
endProcedure scanReadO0
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
m.m.src = m.r
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if m.m.scanComment \= '' then
untC = untC || left(m.m.scanComment, 1)
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
m.m.tok = res
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then
return 1
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here --------------------*/
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.m = ll
return 1
endProcedure editRead
/*--- search loop in edit macro --------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanSB', 'm',
, "jOpen call scanWinOpen m",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1',
, 'jReadO' classMet(class4Name('ScanSB'), 'jReadO')
return
endProcedure scanWinIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return scanWinReset(scanSqlOpt(oNew('ScanWin')), rdr, wOpts)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, cuLe wiFo wiBa
call oMutatName m, 'ScanWin'
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + 3 * cuLe
m.m.winTot = m.m.posLim + cuLe * (1 + word(wiFo 5, 1))
m.m.cutLen = cuLe /* fix recLen */
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanReadO0 oMutatName(m, 'ScanWin')
call scanWinRead m
m.m.lineX = word(lx 1, 1)
return m
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - ((m.m.pos-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0', 'dlt m.m.cutLen'
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment ---------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then do
m.m.pos = np + m.m.cutLen
return 1
end
if np >= m.m.pos + cl then do
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl --------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanEnd(m) then
return 'E'
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSbReset(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
call scanOpt m, , '0123456789_' , '--'
m.m.scanNestCom = 1
return m
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpace(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement noSp, use scanNum instead'
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpace m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStmt: procedure expose m.
parse arg m
loop = 0
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, '''"' ,fuCo)
else
scTx = scanTextCom(m, '''"'left(m.m.stop,1), m.m.stop fuCo)
if scTx then do
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
tx = scanLook(m)
ok = word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1
if ok then
ok = scanCom(m)
if ok then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else if scanChar(m, 1) then
res = res || m.m.tok
else
call scanErr m, 'no char, now what?'
iterate
end
if m.m.stop \== '' then
if \ scanLit(m, m.m.stop) then
iterate
end
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
else if res \== '' | \ scTx then
return res
end
call scanErr m, 'loop in scanSqlStmt'
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg rdr, s, wOpt, sOpt
interpret objMet(rdr, 'scanSqlIn2Scan')
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutatName(m, 'ScanSqlStmtRdr')
endProcedure scanSqlStmtRdrReset
scanSqlStmtX: procedure expose m.
parse arg m
return err('deimplement???????') + deimplement
res = ''
cNest = 0
unt0 = '"''-/'
untS = unt0 || left(m.m.stop, m.m.stop \== '')
unt = untS
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
do forever
nlCheck = 0
if scanUntil(m, unt) then
res = res || m.m.tok
if scanNl(m, 0) then do
nlCheck = 1
end
else if m.m.stop \== '' & scanLit(m, m.m.stop) then do
if cNest \== 0 then do
res = res || m.m.tok
end
else if res = '' then do
end
else do
res = strip(res)
if translate(left(res, 10)) \== 'TERMINATOR' then
return res
m.m.stop = strip(substr(s1, 11))
untS = unt0 || left(m.m.stop, m.m.stop \== '')
unt = untS
end
end
else if scanLit(m, '--') then do
if \ scanNl(m, 1) then
leave
nlCheck = 2
end
else if scanLit(m, '/*') then do
unt = untS'*'
res0 = res
cNest = cNest + 1
res = ''
end
else if scanLit(m, '*/') then do
if cNest <= 0 then
call scanErr m, '*/ but not in /* comment'
cNest = cNest - 1
if cNest = 0 then do
unt = untS
res = res0
nlCheck = 2
end
end
else if scanLit(m, "'", '"') then do
qu = m.m.tok
res = res || qu
do while \ scanStrEnd(m, qu)
res = res || substr(m.m.src, m.m.pos)
if \ scanNl(m, 1) then
call scanErr m, 'missing ending quote' qu
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
end
res = res || m.m.tok
end
else if scanEnd(m) then do
leave
end
else if scanChar(m, 1) then do
res = res || m.m.tok
end
else do
call scanErr m, 'bad pos'
end
if nlCheck == 2 | nlCheck == 1 & m.m.fLen == '' then
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
if m.m.fLen \== '' & nlCheck > 0 then
m.m.src = left(m.m.src, m.m.fLen)
end
if cNest \== 0 then
call scanErr m, 'eof in' cNest 'nested comment'
return strip(res)
endProcedure scanSqlStmtX
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets --------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO, aI
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if pos(oc, 's|fp') > 0 then do
call jClose m.pipe.ax.in
if oc == 'p' then
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
else if oc == '|' then
m.pipe.ax.in = jOpen(oOut, '<')
else if oc == 'f' then do
if arg() <= 3 then
m.pipe.ax.in = jOpen(o2file(aI), '<')
else do
ct = jOpen(Cat(), '>')
do lx = 3 to arg()
call jWriteAll ct, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(ct), '<')
end
end
else if arg() <= 3 then
m.pipe.ax.in = jOpen(jBuf(aI), '<')
else do
bu = jOpen(jBuf(), '>')
do lx = 3 to arg()
call jWrite bu, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(bu), '<')
end
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then
call err 'implement' substr(opts, ox) 'in pipe' opts
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== mapAdr(v, na, 1, 1)
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
tos = m.v_with.0
if fun == '=' then do
if o == '' & m.v_with.tos.obj == '' then
return
if o \== '' & m.v_with.tos.obj \== '' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
return
end
par = tos - 1
end
else if fun == '+' then do
par = tos
tos = tos + 1
m.v_with.0 = tos
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vGet: procedure expose m.
parse arg na
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
return o2string(mapGet(v, adr))
else if flag == 's' then
return m.adr
else if flag == 'o' then
return o2String(m.adr)
return err('vGet flag' flag)
endProcedure vGet
vGetO: procedure expose m.
parse arg na
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
return mapGet(v, adr)
else if flag == 's' then
return s2o(m.adr)
else if flag == 'o' then
return m.adr
return err('vGetO flag' flag)
endProcedure vGetO
vPut: procedure expose m.
parse arg na, val
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
call mapPut v, adr, s2o(val)
else if flag == 's' then
m.adr = val
else if flag == 'o' then
m.adr = s2o(val)
else
return err('vPut flag' flag)
return val
endProcedure vPut
vPutO: procedure expose m.
parse arg na, val
parse value vAdr(na) with flag 2 adr
if flag == 'm' then
call mapPut v, adr, val
else if flag == 's' then
m.adr = o2String(val)
else if flag == 'o' then
m.adr = val
else
return err('vPutO flag' flag)
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdr: procedure expose m.
parse arg na
cx = pos('&', na)
if cx = 1 | na = '' then
return err('vAdr bad name' na)
if m.v_withMap \== '' then do
mp = m.v_withMap
cy = verify(na, '.&', 'm')
if cy < 1 then
w2 = na
else
w2 = left(na, cy - 1)
if symbol('m.mp.w2') == 'VAR' then do
wx = m.mp.w2
return vAdrObj(m.v_with.wx.obj, '.'na)
end
end
if cx < 1 then
oNm = na
else
oNm = left(na, cx-1)
if cx < 1 then
return 'm'na
return vAdrObj(mapGet(v, oNm), '.'substr(na, cx + 1))
endProcedure vAdr
/*--- vAdr for object and field --------------------------------------*/
vAdrObj: procedure expose m.
parse arg o, f
if left(f, 1) == '.' then
cx = 2
else if left(f, 1) == '&' then
cx = 1
else
return err('vAdrObj bad f='f)
do forever
if o = '' then
return err('vAdrObj null at' left(f, cx-1) 'in name' f)
cy = pos('&', f, cx)
if cy < cx then
leave
if cy == cx then
a = o
else
a = o'.'substr(f, cx, cy-cx)
if symbol('m.a') \== 'VAR' then
return err('vAdrObj undef' a 'at' left(f, cy-1) 'in name' f)
o = m.a
cx = cy+1
end
cl = objClass(o, '')
if cl == '' then
return err('vAdrObj undef' o 'in name' f)
return vAdrClass(cl, o, '.'substr(f, cx))
endProcedure vAdrObj
/*--- vAdr for class, object and field -------------------------------*/
vAdrClass: procedure expose m.
parse arg cl, o, f
if pos('&', f) > 0 then
return vAdrObj(o, f)
else if left(f, 1) == '.' then
f2 = substr(f, 2)
else
return err('vAdrClass bad f='f)
f2c = classMet(cl, 'f2c')
if symbol('m.f2c.f2') \== 'VAR' then
return vAdrStem(cl, o, f)
if f2 \== '' then
o = o'.'f2
if m.f2c.f2 == m.class_V then
return 's'o
else
return 'o'o
endProcedure vAdrClass
/*--- vAdr for stems of class, object and field ---------------------*/
vAdrStem: procedure expose m.
parse arg cl, o, f
if left(f, 1) \== '.' & left(f, 1) \== '&' then
return err('vAdrStem bad f='f)
cy = 1
do until cy < 1
cx = cy+1
cy = pos('.', f, cx)
if cy == 0 then do
if verify(f, '0123456789', 'n', cx) >= cx then
call err 'vAdrStem no stem cl' className(cl),
|| ', o' o', f' f
cz = length(f) + 1
end
else do
if verify(f, '0123456789', 'n', cx) \== cy then
iterate
cz = cy
end
end
st = substr(f, 2, max(0, cx-3))
sd = left('.', st \== '')st
sx = substr(f, cx, cz-cx)
if symbol('m.cl.s2c.st') \== 'VAR' then
return err('vAdrStem not a stem cl='className(cl) 'st='st 'o='o)
if sx \== 0 then
return vAdrClass(m.cl.s2c.st, o || sd'.'sx, '.'substr(f, cz))
if cy == 0 then
return 's'o || f
else
return err('vAdrStem.0 not at end cl='cl 'f='f 'o='o)
endProcedure vAdrStem
vRead: procedure expose m.
parse arg na
return inVar("V."na)
vReadO: procedure expose m.
parse arg na
if \ inO() then
return 0
call vPutO na, m.in
return 1
endProcedure vReadO
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
cr = m.m.catRd
if jReadO(cr) then do
m.m = m.cr
return 1
end
call catNextRdr m
end
return 0
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err.os == 'TSO' then
call fileTsoIni
else if m.err.os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' m.err.os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'SUBJECT ' subj
m.m.2 = 'RECPLIST ' rec
m.m.3 = 'SENDERID ' if(snd=='', userid(), snd)
m.m.4 = 'SENDERIDCC N'
m.m.5 = 'DOCTEXT'
m.m.0 = 5
return m
endProcedure mailHead
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m, 'DOCTEXTEND'
if dsn == '' then
call dsnAlloc 'dd(iemapi) new ::v255'
else
call dsnAlloc 'dd(iemapi) shr' dsn
call writeDD iemapi, 'M.'m'.'
call tsoClose iemapi
call dsnAlloc 'dd(iemlog) sysout(*)'
call adrTso "call *(os3550)", '*'
if rc \== 0 then
say 'error os3550 rc='rc 'mail not sent|||||'
call tsoFree iemlog iemapi
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_V
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class_V
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.m.defDD = 'CAT*'
m.fileTso.buf = m.fileTso.buf + 1
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
aDD = word(aa, 1)
aDsn = m.tso_dsn.aDD
if aDsn <> '' then
if pos('(', aDsn) > 0 & pos('/', aDsn) < 1 then
if sysDsn("'"m.tso_dsn.aDD"'") <> 'OK' then
call err 'cannot read' m.tso_dsn.aDD':',
sysDsn("'"m.tso_dsn.aDD"'")
call tsoOpen word(aa, 1), 'R'
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
parse var aa m.m.dd m.m.free
m.m.dsn = mGet('TSO_DSN.'m.m.dd)
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' & m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call tsoClose m.m.dd
call tsoFree m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.buf.ix
/* call oMutate var, m.class_V ?????????? */
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class_V) == m.class_V then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = oNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, m)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy mat begin *****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end *****************************************************/
/* copy sqlDiv begin **************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, c, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), c, maxCh, maxBlo, maxDe)
sqlFTabOpts: procedure expose m.
parse arg ff, cx, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.flds = ''
m.ff.sqlX = cx
m.ff.sqlOthers = 0
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff ---------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
sqlFTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
if word(m.m.set.sx, 1) == c1 & sx <= m.m.set.0 then do
parse var m.m.set.sx c1 aDone
f1 = m.m.set.sx.fmt
l1 = m.m.set.sx.labelTi
end
end
cx = m.m.sqlX
f2x = classMet(sqlFetchClass(cx), 'f2x')
if symbol('m.f2x.c1') \== 'VAR' then
call err 'colName not found' c1
kx = m.f2x.c1
t1 = m.sql.cx.d.kx.sqlName
if l1 == '' then
l1 = t1
if f1 == '' then do
ty = m.sql.cx.d.kx.sqlType
le = m.sql.cx.d.kx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
trace ?r
pr = le % 256
de = le // 256
f1 = '%'pr'.'de'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
end
call fTabAddRCT m, c1 aDone, f1, t1, l1
ox = m.m.0
m.m.ox.tit.0 = max(arg()-3, 1)
do tx=2 to m.m.ox.tit.0
m.m.ox.tit.tx = arg(tx+3)
end
return m
endProcedure sqlFTabAdd
sqlFTabOthers: procedure expose m.
parse arg m, doNot
cx = m.m.sqlX
ff = m.sql.cx.fetchFlds
m.m.sqlOthers = 1
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
wx = wordPos(c1, m.m.cols)
if (wx < 1 | m.m.wx.done \== 1) & wordPos(c1, doNot) < 1 then
call sqlFTabAdd m, c1
end
return m
endProcedure sqlFTabOthers
sqlFTab: procedure expose m.
parse arg m
call fTabBegin m
do while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out f(m.m.fmt, 'sqlFTab')
end
return fTabEnd(m)
endProcedure sqlFTab
sqlFTabCol: procedure expose m.
parse arg m
if pos('c', m.m.generated) < 1 then
call fTabColGen m
do rx=1 while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out left('--- row' rx '', 80, '-')
call fTabCol m, 'sqlFTab'
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
return
endProcedure sqlFTabCol
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabOpts FTabReset(ft, 'c 1', '1 c', '-'),
,cx , 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , '%-12H'
call FTabSet ft, 'RBA1' , '%-12H'
call FTabSet ft, 'RBA2' , '%-12H'
call FTabSet ft, 'START_RBA' ,'%-12H'
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlQuery cx, sq
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
if sep == '' then
sep = sqlCatTbVLsep()
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAddRCT ft, substr(tt,length(sep)+1) ,
, substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql_dbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
stops = '(select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
call out int || substr(sq, cx, nx-cx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIXStats
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
', timestamp(rba1 || x''0000'') rba1Tst' ,
', timestamp(rba2 || x''0000'') rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-24C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , '%-12H'
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , '%-12H'
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTables
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , '%-12H', 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTSStats
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFlds(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut m.ff.fx
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || left('.', m.ff.fx \== '')m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState ---------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/* say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ----------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ----------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end **************************************************/
/* copy db2Cat begin **************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'", ,'')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq, colName, ordering" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql, '?sq col ord'
res = ''
drop d
do kx=1 while sqlFetch(1, d)
if m.d.sq \= kx then
call err 'expected' kx 'but got colSeq' m.d.sq ,
'in index' cr'.'ix'.'m.d.col
res = res || strip(m.d.col) || translate(m.d.ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlQuery 1, sql, 'na ty nu de nn'
pr = ' '
do kx=1 while sqlFetch(1)
/* say kx m..na m..ty m..nu m..de 'nn' m..nn */
if pos('CHAR', m..ty) > 0 then
dv = "''"
else if pos('INT' ,m..ty) > 0 ,
| wordPos(m..ty, 'REAL FLOAT') > 0 then
dv = 0
else if m..ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', m..ty) > 0 then
dv = m..ty"('')"
else
dv = '???'
if m..nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if m..ty = 'ROWID' then do
r = '--'
end
else if m..nn == 'new' then do
if m..de = 'Y' then
r = '--'
else if m..nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if m..nu = 'Y' | (m..nu = m..nn) then
r = ''
else
r = 'coalesce('m..na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' m..ty 'in' tCr'.'tTb'.'m..na
call out r m..na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end **************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call sqlRxIni
call jIni
call fTabIni
call scanWinIni
m.sqlO.cursors = left('', 200)
m.sql_rdrClass = classNew('n SqlRdr u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jReadO return sqlRdrReadO(m)")
call classNew 'n SqlResRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jReadO return sqlRdrReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
/* call classNew 'n SqlExecuteRdr u JRW', 'm',
, "jReset call sqlExecuteRdrReset(m, arg, arg2)" ,
, "jOpen call sqlExecuteRdrOpen(m)" ,
, "jClose call sqlExecuteRdrClose(m)" ,
, "jRead call sqlExecuteRdrRead(m)" ???????? */
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connClass = class4Name('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connClass = class4Name('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connClass = 'sql not connected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
interpret classMet(m.sql_connClass, 'sqlQuery')
endProcedue sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
interpret classMet(m.sql_connClass, 'sqlFetch')
endProcedue sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
interpret classMet(m.sql_connClass, 'sqlClose')
endProcedue sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*--- execute stmts with options -------------------------------------*/
sqlStmtsOpt: procedure expose m.
parse arg src, opts ?????????????????????
upper opts + deimplement
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fTabAuto
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
return sqlsOut(scanSqlStmtRdr(sqlSrc, opt), retOk, 'a')
return
endProcedure sqlStmts
sqlStmtsOld: procedure expose m. ??????????????
parse arg sqlSrc, retOk, opt
dlm = ';' + deimplement
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
else
fLen = ''
fi = in2File(sqlSrc)
call scanOpen scanSqlReset(sqlStmts, fi, fLen, ';')
do forever
s1 = scanSqlStmt(sqlStmts)
if s1 = '' then
leave
call outNl sqlStmt(s1, retOk, opt)
end
call scanReadClose sqlStmts
return 0
endProcedure sqlStmtsOLD ?????????????????
/*--- execute a single sql statement --------------------------------*/
sqlStmt: procedure expose m. ???????????????????
parse arg src, retOk, opt
cx = sqlGetCursor() + deimplement
r1 = sqlExecute(cx, src, retOK)
res = m.sql_HaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlQuery2Rdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto fTabReset(sql_StmtFmt, 1), rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jReadO(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', scanSqlIn2Stmt(src), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
call sqlQuery m.m.cursor, m.m.src, m.m.type
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
call sqlQuery m.m.cursor, m.m.src, mCat(classFlds(m.m.type),' ')
m.sql.cx.fetchClass = m.m.type
end
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.rowCount = 0
m.sql_lastRdr = m
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrReadO: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
return 0
end
m.m.rowCount = m.m.rowCount + 1
m.m = v
return 1
endProcedure sqlRdrReadO
/*--- return sqlFTab for this (open) rdr -----------------------------*/
sqlRdrFtabReset: procedure expose m.
parse arg m, q, maxChar, blobMax, maxDec
if m == '' then
m = m.sql_lastRdr
if \ dataType(m.m.cursor, 'n') then
call err 'sqlRdrFTabReset('m') but cursor empty'
return sqlFTabReset(q, m.m.cursor, maxChar, blobMax, maxDec)
endProcedure sqlRdrFTabReset
/*--- output sql as table --------------------------------------------*/
sql2tab: procedure expose m.
parse arg tBef, tAft, maxChar, blobMax, maxDec
cx = sqlGetCursor()
call sqlQuery cx, in2str(,' ')
t = sqlFTabReset('SQL.'cx'.fTab', cx,
, tBef, tAft, maxChar, blobMax, maxDec)
call sqlFTab sqlFTabOthers(t)
call sqlClose cx
call sqlFreeCursor cx
return
endProcedure sql2tab
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, oo
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = sqlGetCursor()
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' then do
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
end
else if oo == 'o' then do
call pipeWriteAll sqlQuery2Rdr(cx)
end
else if oo == 'a' | oo == 't' then do
sqR = sqlQuery2Rdr(cx)
ft = sqlfTabOpts(fTabReset('sqls2AutoFT', 'c 1'), cx)
if oo == 't' then do
call sqlFTabOthers(ft)
end
else do
bf = in2Buf(sqR)
if m.sql_errRet then
leave
call sqlFTabDetect ft, bf'.BUF'
call fTab ft, bf
call out sqlMsgLine(m.sqR.rowCount 'rows fetched',
, , m.r)
end
end
else
call err 'bad outputOption' oo
end
call jClose r
if m.sql_errRet then do
/* call out 'sqlsOut terminating because of sql error' */
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
call sqlFreeCursor cx
return \ m.sql_errRet
endProcedure sqlsOut
/*-- execute and put result to m -------------------------------------*/
sqlExecuteRes: procedure expose m.
parse arg m, cx, m.m.sql, retOk ?????
m.m.sqlCode = sqlExecute(cx, m.m.sql, retOk) + deimplement
m.m.sqlMsg = m.sql_HaHi || sqlMsgLine(m.m.sqlCode,
, m.sql.cx.updateCount, m.m.sql)
endProcedure sqlExecuteRes
/*--- execute stmts with options -------------------------------------*/
sqlExecuteRdrReset: procedure expose m.
parse arg rdr, wOpt, m.m.retOk
if abbrev(wOpt, '-sql') then + deimplement ??????????????????
wOpt = substr(wOpt, 5)
call scanSqlReset m'.SCAN', rdr, wOpt, ';'
return m
endProcedure sqlExecuteRdrReset
sqlExecuteRdrOpen: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
m.m.cursor = sqlGetCursor()
return m
endProcedure sqlExecuteRdrOpen
sqlExecuteRdrClose: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
call sqlFreeCursor m.m.cursor
drop m.m.cursor
return m
endProcedure sqlExecuteRdrClose
sqlExecuteRdrRead: procedure expose m.
parse arg m, var
src = scanSqlStmt(m'.SCAN') + deimplement ??????????????????
if src == '' then
return 0
call sqlExecuteRes m, m.m.cursor, src, m.m.retOk
m.var = m.m.cursor
return 1
endProcedure sqlExecuteRdrRead
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
if abbrev(feVa, '?') | abbrev(feVa, ':') then do
return err('implement sqlCmsQuery fetchVars ? or :' feVa)
end
else if feVa <> '' then do
vv = feVa
end
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsAdd(vv, SQLDA_REXXNAME.kx)
end
end
m.sql.cx.fetchFlds = vv
if sqlD <> words(vv) then
return err('sqlCsmQuery sqlD' sqlD '<>' words(vv) 'for' vv)
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = word(vv, kx)
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
m.sql_lastRdr = 'cms' cx
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
ff = m.sql.cx.fetchFlds
do kx = 1 to words(ff)
c = word(ff, kx)
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
salUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure salUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err 'implement rxFetchVars ?' /* ?????????????
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy mbrList begin ************************************************/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value csmSysDsn(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx +1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk ,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
mx = mbr_name.0
end
m.m.0 = mx
return mx
endProcedure mbrList
tstMbrList: procedure expose m.
/*
$=/tstMbrList/
### start tst tstMbrList ##########################################
*** err: adrTso rc= 8 stmt=LISTDS 'A540769.TMP.TST.MBRLIST' MEMBERS+
. .
. e 1: A540769.TMP.TST.MBRLIST
. e 2: IKJ58503I DATA SET 'A540769.TMP.TST.MBRLIST' NOT IN CATAL+
OG
#noPds: 0 mbrs in A540769.TMP.TST.MBRLIST
#1: 1 mbrs in A540769.TMP.TST.MBRLIST
1 EINS
#0: 0 mbrs in A540769.TMP.TST.MBRLIST
#4: 4 mbrs in A540769.TMP.TST.MBRLIST
1 DREI
2 FUENF
3 VIER
4 ZWEI
#*IE*: 3 mbrs in A540769.TMP.TST.MBRLIST( *IE* )
1 IE
2 NNNIE
3 VIER
#*_IE*: 2 mbrs in A540769.TMP.TST.MBRLIST( *?IE* )
1 NNNIE
2 VIER
$/tstMbrList/
*/
call tst t, 'tstMbrList'
/* call tstMbrList1 "RZ2/A540769.WK.REXX(*DA?*)" */
pds = tstFileName('MbrList', 'r')
da.1 = '2ine eins'
call tstMbrList1 pds, '#noPds'
call writeDsn pds'(eins) ::f', da., 1
call tstMbrList1 pds, '#1'
call adrTso "delete '"pds"(eins)'"
call tstMbrList1 pds, '#0'
call writeDsn pds'(zwei) ::f', da., 1
call writeDsn pds'(drei) ::f', da., 1
call writeDsn pds'(vier) ::f', da., 1
call writeDsn pds'(fuenf) ::f', da., 1
call tstMbrList1 pds, '#4'
call writeDsn pds'(ie) ::f', da., 1
call writeDsn pds'(nnnie) ::f', da., 1
call tstMbrList1 pds"( *IE* )", '#*IE*'
call tstMbrList1 pds"( *?IE* )", '#*_IE*'
call adrTso "delete '"pds"'"
call tstEnd t
return
endProcedure tstMbrList
tstMbrList1: procedure expose m.
parse arg pds, txt
call tstOut t, txt':' mbrList(tstMbrList, pds) 'mbrs in' pds
do mx=1 to m.tstMbrList.0
call tstOut t, mx m.tstMbrList.mx
end
return
endProdecure tstMbrList1
/* copy mbrList end ************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse arg rz, dsn
if dsnGetMbr(dsn) == '' then do
call adrCsm "allocate system("rz") dataset('"dsn"')" ,
"disp(del) ddname(del1)"
call adrTso 'free dd(del1)'
end
else do
rr = adrCsm("mDelete system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)")", 8)
if rr <> 0 then
if pos('CSMEX77E Member:', m.tso_trap) < 1 ,
| pos(' not found', m.tso_trap) < 1 then
call err 'rc='rr 'csm mDelete' rz'/'dsn':'m.tso_trap
end
return
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse arg aFr, aTo, retOk
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(aFr)
if frMbr == '*' then
fr = dsnSetMbr(aFr)
else
fr = aFr
call csmAlloc fr frDD 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr)
call csmAlloc to toDD 'shr ::D'frDD
if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end
inDD = tsoDD('csmIn*', 'a')
if frMbr == '' & m.tso_dsOrg.frDD == 'PO' then do
call tsoAlloc '-' inDD 'NEW ::F'
call adrCsm "mbrList ddName("frDD") index(' ') short"
do ix=1 to mbr_mem#
i.ix = ' S M='mbr_name.ix
end
call writeDD inDD, 'I.', mbr_mem#
call tsoCLose inDD
end
else do
call adrTso 'alloc dd('inDD') dummy'
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmCopLOld: procedure expose m.
/* csrxUtil geht nicht mit to(mbr), copy geht nicht fuer Load */
parse arg aFr, aTo, retOk
if \ dsnExists(aTo) then do
/* alloc ourself, because csrxutil forget mgmtclas */
call dsnAlloc 'dd(csmCopy) catalog' aTo ,
dsnLikeAtts(dsnSetMbr(aFr), 0)
call tsoFree csmCopy
end
parse value csmSysDsn(aFr) with fSys '/' fDsn
parse value csmSysDsn(aTo) with tSys '/' tDsn
return adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'" ,
"'COPY" fSys"/''"fDsn"'' TO" tSys"/''"tDsn"'' REPLACE'", retOk)
endProcedure csmCopLOld
csmCopyOld: procedure expose m.
parse arg aFr, aTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
fr = csmSysDsn(aFr)
frMbr = dsnGetMbr(fr)
frDD = tsoDD('csmFr*', 'a')
to = csmSysDsn(aTo)
toMbr = dsnGetMbr(to, '=')
toDD = tsoDD('csmTo*', 'a')
call csmAlloc dsnSetMbr(fr) frDD 'shr'
if frMbr == '' & m.tso_dsorg.frDD == 'PO' then
if toMbr \== '=' then
call err 'csmCopy from' fr'(*) to ps' to
else
frMbr = '*'
if frMbr == '' & (toMbr \== '' & toMbr \== '=') then
psOrLib = 'dsorg(po) dsntype(library)'
else if frMbr \== '' & toMbr == '' then
psOrLib = 'dsorg(ps)'
else
psOrLib = ''
call csmAlloc dsnSetMbr(to) toDD 'shr ::D'frDD psOrLib
c = 'indd('frDD') outDD('toDD')'
if frMbr \== '*' then do
if frMbr \== '' then
c = c 'member('frMbr')'
if toMbr \== '' & toMbr \== '=' then
c = c 'newName('toMbr')'
call adrCsm 'copy' c
end
else do
call adrCsm "mbrList ddName("frDD") index(' ') short"
do mx=1 to mbr_mem#
call adrCsm 'copy' c 'member('mbr_name.mx')'
end
end
call tsoFree frDD toDD
return
endProcedure csmCopyOld
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
upper dd disp
m.tso_dsn.dd = csmSysDsn(dsn)
parse var m.tso_dsn.dd sys '/' dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc m.tso_dsn.dd dd 'CAT' rest ':'nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 11
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
/* now, run tso remote */
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do /* handle csm error */
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do /* copy output to stem */
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_rz = ''
i = /* 'RZ1 1 1 S1 */ ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz m.ii_rz2c.rz m.ii_rz2plex.rz sys i
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db m.ii_db2c.db mbr i
m.ii_mbr2db.mbr = db
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2P: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2plex, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiLazy
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy csv begin *****************************************************/
csvIni: procedure expose m.
if m.csv.ini == 1 then
return
m.csv.ini = 1
call jIni
call classNew "n CsvRdr u JRWO, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvRdrOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvRdr'"
call classNew "n CsvRdrR u CsvRdr", "m",
, "jReadO return csvRdrReadO(m)"
call classNew "n CsvWrt u JRW, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvWrtOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvWrt'"
call classNew "n CsvWrtR u CsvWrt", "m",
, "jRead return csvWrtRead(m)"
return
endProcedure csvIni
/*--- create a new csvRdr --------------------------------------------*/
csvRdr: procedure expose m.
parse arg rdr
return jReset(oNew('CsvRdr'), rdr)
endProcedure csvRdr
/*--- open csvRdr: read first line and create dataClass --------------*/
csvRdrOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
mr = m.m.rdr
if jRead(mr) then do
ff = 'f' repAll(m.mr, ',', ' v, f ') 'v'
m.m.class = classNew("n* CsvF u" ff)
end
call oMutatName m, 'CsvRdrR'
return
endProcedure csvRdrOpen
/*--- read next line and return derived object -----------------------*/
csvRdrReadO: procedure expose m.
parse arg m
mr = m.m.rdr
do until m.mr <> ''
if \ jRead(mr) then
return 0
end
var = oNew(m.m.class)
ff = classMet(m.m.class, 'oFlds')
s = m'.SCAN'
call scanSrc s, m.mr
do fx=1
f1 = m.ff.fx
if scanString(s, '"') then
m.var.f1 = m.s.val
else do
call scanUntil s, ','
m.var.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
if fx <> m.ff.0 then
call scanerr s, 'csv cla' m.ff.0 'fields but' cx 'in line'
m.m = var
return 1
endProcedure csvRdrReadO
/*--- create a new csvRdr --------------------------------------------*/
csvWrt: procedure expose m.
parse arg rdr
return jReset(oNew('CsvWrt'), rdr)
endProcedure csvWrt
/*--- open csvRdr: read first line and create dataClass --------------*/
csvWrtOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
m.m.class = ''
m.m.o1 = ''
call oMutatName m, 'CsvWrtR'
return
endProcedure csvWrtOpen
/*--- read next line and return derived object -----------------------*/
csvWrtRead: procedure expose m.
parse arg m
mr = m.m.rdr
if m.m.o1 \== '' then do
i1 = m.m.o1
m.m.o1 = ''
end
else if jReadO(mr) then
i1 = m.mr
else
return 0
if m.m.class == '' then do
m.m.class = objClass(i1)
m.m.o1 = i1
t = ''
ff = oFlds(i1)
do fx=1 to m.ff.0
t = t','m.ff.fx
end
m.m = substr(t, 2)
return 1
end
else do
m.m = csv4Obj(i1, oFlds(i1), 0)
return 1
end
endProcedure csvWrtRead
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/* copy csv end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m') but not opened r')
endProcedure jRead
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jReadO(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jReadO(rdr)
call jWriteO m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jReset0: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed' / ???????
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new ?r m = jReset0(?new2); ?jReset; return m" ,
, "jRead" am "jRead('m')'" ,
, "jReadO if \ jRead(m) then return 0;",
"m.m = s2o(m.m); return 1" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new ?r return jReset(?new1, arg)",
, "jRead md = m.m.deleg; if \ jRead(md) then return 0;" ,
"m.m = m.md; return 1",
, "jReadO md=m.m.deleg; if \ jReadO(md) then return 0;" ,
"m.m = m.md; return 1",
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead if \ jReadO(m) then return 0;" ,
"m.m = o2string(m.m); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errReadO = "return err('jReadO('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutatName m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jReadO(r)
m.in = m.r
return m.in_ret
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutatName m, 'JBufSR'
else
call oMutatName m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutatName m, 'JBufSW'
else
call oMutatName m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class_V then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class_W then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutatName m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.m = m.m.buf.nx
return 1
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.m = s2o(m.m.buf.nx)
return 1
endProcedure jBufSReadO
jBufORead: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.m = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.m = m.m.buf.nx
return 1
endProcedure jBufRead
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jReadO(m)
two = jReadO(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o_ini == 1 then
return
m.o_ini = 1
call classIni
call classNew 'n= root u', 'm',
, "new ?l" ,
, "new1 ?l" ,
, "new2 ?l" ,
, "oClear ?l" ,
, "oCopy ?l"
return
endProcedure oIni
oMetLazy: procedure expose m.
parse arg cl, met, rest
if met = 'new1' then do
call mNewArea cl, 'O.'substr(cl,7)
return "oMutate(mNew('"cl"'), '"cl"')"
end
call classMet cl, 'oFlds'
if met == 'new' then do
return 'return' classMet(cl, 'new2')
end
else if met == 'new2' then do
call classMet cl, 'oClear'
return "classClear('"cl"'," classMet(cl, 'new1')")"
end
else if met == 'oClear' then do
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
m.cl.flds_null.fx = if(m.cl.f2c.f1==m.class_W,
, m.o_escW, '')
end
m.cl.flds_null.0 = m.cl.flds.0
return "return classClear('"cl"', m)"
end
else if met == 'oCopy' then do
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
s2 = m.cl.s2c.s1
call classMet m.cl.s2c.s1, 'oCopy'
call classMet m.s2.1, 'oCopy'
end
call classMet cl, 'new1'
return "return classCopy('"cl"', m, t)"
end
else
call err 'bad method in oMetLazy('cl',' met')'
endProcedure oMetLazy
oMetRec: procedure expose m.
parse arg cl, met, rest
gen = ''
rx = 1
do forever
ry = pos('?', rest, rx)
if ry == 0 then
return gen || substr(rest, rx)
gen = gen || substr(rest, rx, ry-rx)
rx = verify(rest, m.ut_alfid, 'n', ry+1)
if rx = 0 then
rx = length(rest)+1
rr = classMet(cl, substr(rest, ry+1, rx-ry-1))
if word(rr, 1) = 'return' then
rr = subword(rr,2)
gen = gen || rr
end
endProcedure oMetRec
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
if m.cl.flds_self then
m.m = m.cl.flds_null.1
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.m.f1 = m.cl.flds_null.fx
end
if m.cl.stms_self then
m.m.0 = 0
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
m.m.s1.0 = 0
end
return m
endProcedure classClear
classCopy: procedure expose m.
parse arg cl, m, t
if t == '' then
t = oMutate(mNew(cl), cl)
else
call oMutate t, cl
if m.cl.flds_self then
m.t = m.m
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.t.f1 = m.m.f1
end
if m.cl.stms_self then
call classCopyStem m.cl.stms., m, t
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
call classCopyStem m.cl.s2c.s1, m'.'s1, t'.'s1
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class_V)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class_V then
call out p1 || m.m
else if c == m.class_W then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a, '')
if t = '' then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
interpret classMet(class4name(cl), 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_W
else if arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method me of object m or String or Null
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o_escW) then
ggClass = m.class_w
else if m \== '' then
ggClass = m.class_S
else
ggClass = m.class_N
if symbol('m.ggClass.method.me') == 'VAR' then
return m.ggClass.method.me
else
return classMet(ggClass, me)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class_V then
l = m.m
else if cl == m.class_W then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = m.ff.fx
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "oCopy return oCopyV(m, t)" ,
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_root = classNew('n root u', 'm',
, "f2c ?l" ,
, "f2x ?l" ,
, "oFlds ?l" ,
, "s2c ?l" ,
, "stms ?l" ,
, "in2Str ?r return ?o2String" ,
, "in2File ?r return ?o2File" ,
, "in2Buf ?r return jBufCopy(?o2File)" ,
, "scanSqlIn2Scan ?r" ,
"return scanSqlReset(s, ?in2File, wOpt, sOpt)")
m.class_S = classNew('n String u', 'm',
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
, "scanSqlIn2Scan ?r if wOpt == '' then wOpt = 0;" ,
"return scanSqlReset(s, ?in2File, wOpt, sOpt)")
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if symbol('m.cl.metLazy.met') == 'VAR' then do
parse var m.cl.metLazy.met l1 lRest
m.cl.method.met = "call err 'building lazy method" cl"#"me"'"
if l1 == '?r' then
m.cl.method.met = oMetRec(cl, met, lRest)
else if l1 \== '?l' then
call err 'implement' l1 'for lazy' className(cl)'#'met
else if met = 'oFlds' then do
m.cl.flds.0 = 0
m.cl.flds_self = 0
m.cl.stms.0 = 0
m.cl.stms_self = 0
call classFldAdd cl, cl
m.cl.method.met = cl'.FLDS'
end
else if wordPos(met, 'f2c f2x stms s2c') > 0 then do
call classMet cl, 'oFlds'
if met == 'f2x' then
call mInverse cl'.FLDS', cl'.F2X'
m.cl.method.met = cl'.'translate(met)
end
else
m.cl.method.met = oMetLazy(cl, met, lRest)
return m.cl.method.met
end
if m.cl.methods == 1 then
return err('no method' met 'in class' className(cl))
m.cl.methods = 1
call classMetGen m.class_root, cl
call classMetGen cl, cl
return classMet(cl, met)
endProcedure classMet
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err implement cycle
endProcedure classCycle
classMetGen: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
if m.cl == 'm' then do
mthd = m.cl.name
drop m.trg.method.mthd m.trg.metLazy.mthd
if \ abbrev(m.cl.met, '?') then
m.trg.method.mthd = m.cl.met
else
m.trg.metLazy.mthd = m.cl.met
end
else if m.cl == 'u' then do
do cx=1 to m.cl.0
if wordPos(m.cl.cx,
, m.class_V m.class_W m.class_O m.class_R) < 1 then
call classMetGen m.cl.cx, trg, pa
end
end
else if pos(m.cl, 'fscr') < 1 then
call err 'bad cla' cl m.cl
return
endProcedure classMetGen
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fa, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
if nm == '' then do
call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'_SELF', 1
end
else do
call mAdd fa, nm
end
return 0
endProcedure classFldAdd1
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 0, 0)
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 1, 0)
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 1, 1) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 1, 1)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 1, 1)
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 1, 1)
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
retOld 1 = return oldAdr, 0=return '' if exists
retNew 1 = retrun '' if new, 0=add and return ---------*/
mapAdr: procedure expose m.
parse arg a, ky, retOld, retNew
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, retOld)
else if retNew then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, retOld)
end
end
else do
i = 1
end
if retNew then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if tx < fx then
return f(f2'%##e')
res = f(f2'%##a', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res
endProcedure mCatFT
fGenCat: procedure expose m.
parse arg s, ax
do fx=1 ??????? until \ scanLit(s, '%,')
f.fx = fGen(s)
end
if \ scanLit(s, '%)') then
call scanErr s, 'no %) after @fGenCat%('
if \ scanEnd(s) then
call scanErr s, 'mGenCat not at end'
if fx < 2 | f.2 == "''" then
f.2 = fGen(scanSrc(f_u, '%c'))
if fx < 3 then
f.3 = "''"
if fx < 4 then
f.4 = "''"
adr = m.s.src'%'
if f.1 == "''" then
m.f_gen.adr.1 = 'return' f.2
else
m.f_gen.adr.1 = 'return' f.1 '||' f.2
m.f_gen.adr.2 = 'return' f.4
if f.3 == "''" then
return f.2
else
return f.3 '||' f.2
endProcedure fGenCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.mBase64 = m.ut_alfUC || m.ut_alfLc || m.ut_digits'+-'
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy fTab begin *****************************************************
output Modes: t = tableMode 1 line per object
c = colMode 1 line per column/field of object
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * sqlFTabAdd *
sqlFTabOthers ?
fTabGenerate
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
***********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.0 = 0
m.m.len = 0
m.m.cols = ''
m.m.sqlOthers = 1
m.m.set.0 = 0
return oMutate(m, m.fTab_class)
endProcedure fTabReset
/* add a piece to title tx at current pos */
fTabAddTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if ty < m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabAddTit
/*--- set the infos for one column -----------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, l1
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelCy = l1
m.m.set.sx.labelTi = c1
m.m.set.c1 = sx
return
endProcedure fTabSet
fTabAdd: procedure expose m. /* old interface, new is ...RCT */
parse arg m, c1Done, f1, l1
call fTabAddRCT m, c1Done, f1, , l1
ox = m.m.0
m.m.ox.tit.0 = max(arg()-3, 1)
do tx=2 to m.m.ox.tit.0
m.m.ox.tit.tx = arg(tx+3)
end
return
endProcedure fTabAdd
fTabAddRCT: procedure expose m.
parse arg m, rxNm aDone, f1, cyNm, tiNm
cx = m.m.0 + 1
m.m.generated = ''
m.m.0 = cx
m.m.cx.tit.0 = max(arg()-4, 1)
m.m.cx.tit.1 = ''
do tx=2 to m.m.cx.tit.0
m.m.cx.tit.tx = arg(tx+4)
end
r1 = rxNm
if rxNm == '' then
r1 = '='
else if rxNm == '=' then
rxNm = ''
m.m.cols = m.m.cols r1
if words(m.m.cols) <> cx then
call err 'mismatch of column number' cx 'col' rxNm / 0
if length(aDone) > 1 | wordPos('<'aDone'>', '<> <0> <1>') < 1 then
call err 'bad done' length(aDone) '<'aDone'> after rxNm' rxNm
m.m.cx.col = rxNm
m.m.cx.done = aDone \== 0
if cyNm == '' then
m.m.cx.labelCy = r1
else
m.m.cx.labelCy = cyNm
if tiNm == '' then
m.m.cx.labelTi = m.m.cx.labelCy
else
m.m.cx.labelTi = tiNm
px = pos('%', f1)
ax = pos('@', f1)
if px < 1 | (ax > 0 & ax < px) then
m.m.cx.fmt = f1
else
m.m.cx.fmt = left(f1, px-1)'@.'rxNm || substr(f1, px)
return m
endProcedure fTabAddRCT
fTabGenerate: procedure expose m.
parse arg m, sep
f = ''
tLen = 0
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelTi
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelTi) < 1 then
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelTi, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fCache('%.', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelCy
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelCy
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelCy) ,
= translate(m.m.kx.labelTi)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenerate
fTabColGen: procedure expose m.
parse arg m
do kx=1 to m.m.0
t = m.m.kx.labelTI
l = if(m.m.kx.labelCy == t, , m.m.kx.labelCy)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabColGen
fTab: procedure expose m.
parse arg m, rdr
call fTabBegin m
call fAll m.m.fmt, rdr
return fTabEnd(m)
endProcedure fTab
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenerate m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = fTabReset(f_auto, 1)
i = in2Buf(rdr)
if m.i.buf.0 <= 0 then
return m
call fTabDetect m, i'.BUF', wiTi
return fTab(m, i)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
ff = oFlds(m.b.1)
do fx=1 to m.ff.0
call fTabAddDetect m, m.ff.fx, b
end
return
endProcedure fTabDetect
/*--- generate format for all fields of a stem of objects -----------*/
sqlfTabDetect: procedure expose m.
parse arg m, b
cx = m.m.sqlX
ff = m.sql.cx.fetchFlds
do fx=1 to words(ff)
call fTabAddDetect m, word(ff, fx), b, m.sql.cx.d.fx.sqlName
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabAddDetect: procedure expose m.
parse arg m, c1 aDone, st, cyNm, tiNm
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
suf = left('.', c1 \== '')c1
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
call fTabAddRCT m, c1 aDone, '%'newFo, cyNm, tiNm
/* say c1 '????==> %'newFo */
return newFo
endProcedure fTabAddDetect
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5m43 --------*/
fTime: procedure expose m.
?????????????? use f(%kd) ????????????????
fDec: procedure expose m.
?????????????? use f(%kd) ????????????????
fUnits: procedure expose m.
parse arg v, scale, aLen, aPrec, plus
if \ dataType(v, 'n') then do
f1 = fUnitsF1(v, scale, aLen, length(plus), length(plus), aPrec)
return right(v, m.f1.len)
end
if v >= 0 then
sign = plus
else
sign = '-'
v = abs(v) /* always get rid also of sign of -0 | */
f1 = fUnitsF1(v, scale, aLen, length(plus), length(sign), aPrec)
do forever
w = format(v * m.f1.fact, , m.f1.prec)
if pos('E-', w) > 0 then
w = format(0, , m.f1.prec)
if w < m.f1.lim2 then do
if m.f1.kind == 'r' then
x = sign || w || m.f1.unit
else if m.f1.kind == 'm' then
x = sign || (w % m.f1.mod) || m.f1.unit ,
|| right(w // m.f1.mod, m.f1.len2, 0)
else
call err 'bad kind' m.f1.kind 'in f1' f1
if length(x) <= m.f1.len then
return right(x, m.f1.len)
end
if m.f1.next == '' then
return left(sign, m.f1.len, '+')
f1 = m.f1.next
end
endProcedure fUnits
fUnitsF1: procedure expose m.
parse arg v, scale, len, pLen, sLen, aPrec
slp = 'F_Unit.'scale'.'len'.'pLen'.'sLen'.'aPrec
if symbol('m.slp.0') \== 'VAR' then do
sc = 'F_Unit.'scale
if symbol('m.sc.0') \== 'VAR' then do
call fUnitsF1Ini1
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc
end
if scale = 'd' | scale = 'b' then do
if aPrec == '' then
aPrec = 0
if len = '' then
len = aPrec + (aPrec >= 0) + 4 + pLen
dLen = len - sLen
l2 = '1e' || (dLen - aPrec - (aPrec > 0))
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, l2, len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = aPrec
m.si.next = slp'.' || (x+1)
end
if aPrec > 0 then do
y = x-1
si = fUnitsF1I0(slp, x, m.sc.y.kind, m.sc.y.unit,
, m.sc.y.fact, ('1e' || dLen), len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
end
end
else if scale = 't' then do
if len = '' then
len = 5 + pLen
dLen = len - sLen
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, m.sc.x.lim2, len ,
, m.sc.x.mod, m.sc.x.len2)
if x = m.sc.0 - 1 then
m.si.lim2 = '24e' || (dLen-3)
else if x = m.sc.0 then
m.si.lim2 = '1e' || (dLen-1)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
m.si.next = slp'.' || (x+1)
end
end
else
call err implement
x = m.slp.0
m.slp.x.next = ''
end
if \ datatype(v, 'n') then
return slp'.nn'
do q=11 to m.slp.0-1 while v >= m.slp.q.lim1
end
if q = 11 & v <> trunc(v) then do
do q=10 by -1 to m.slp.min+1 while v < m.slp.q.lim1
end
q = q + 1
end
return slp'.'q
endProcedure fUnitsF1
fUnitsF1Ini1: procedure expose m.
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sc = 'F_Unit.d'
call fUnitsF1i0 sc, 11, 'r', ' ', 1
f = 1
do x=1 to 6
f = f * 1000
call fUnitsF1i0 sc, 11+x, 'r', substr(iso, 11+x, 1), 1/f
call fUnitsF1i0 sc, 11-x, 'r', substr(iso, 11-x, 1), f
end
sc = 'F_Unit.b'
f = 1
do x=11 to 17
call fUnitsF1i0 sc, x, 'r', substr(iso, x, 1), 1/f
f = f * 1024
end
sc = 'F_Unit.t'
call fUnitsF1i0 sc, 11, 'm', 's', 100, 6000, , 100, 2
call fUnitsF1i0 sc, 12, 'm', 'm', 1, 3600, , 60, 2
call fUnitsF1i0 sc, 13, 'm', 'h', 1/60, 1440, , 60, 2
call fUnitsF1i0 sc, 14, 'm', 'd', 1/3600, , , 24, 2
call fUnitsF1i0 sc, 15, 'r', 'd', 1/3600/24
return
endProcedure fUnitsF1Ini0
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, m.si.unit, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
if \ datatype(ix, 'n') then
return si
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
/* copy fTab end ****************************************************/
/* copy f begin *******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fCache ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.ggFmt
endProcedure fImm
/*--- compile format fmt put in the cache with address a ------------*/
fCache: procedure expose m.
parse arg a, fmt
if a == '%.' then do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%.'m.f_gen0
end
else if symbol('M.f_gen.a') == 'VAR' then
return a
cy = -2
nm = ' '
gen = ' '
opt = 0
do forever /* split preprocesser clauses */
cx = cy+3
cy = pos('%#', fmt, cx)
if cy < 1 then
act = substr(fmt, cx)
else
act = substr(fmt, cx, cy-cx)
do ax=1
ay = pos('%&', act)
if ay < 1 then
leave
ct = substr(act, ay+2, 1)
if symbol('f.ct') \== 'VAR' then
call err 'undefined %&'ct 'in format' fmt
act = left(act, ay-1) || f.ct || substr(act, ay+3)
if ax > 100 then
say 'fGen' fmt nm '==>' act 'actPos' substr(fmt, cx)
end
if cy <> 1 & (\ opt | symbol('f.nm') \== 'VAR') then
f.nm = act
if cy < 1 | length(fmt) <= cy+1 then
leave
nm = substr(fmt, cy+2, 1)
opt = nm == '?'
if pos(nm, '?;#') > 0 then do
if nm == '#' then do
if length(fmt) <> cy+3 then
call err 'fCache bad %##'nm 'in' fmt
else if a == fmt then
a = left(a, cy-1)
leave
end
cy = cy+1
nm = substr(fmt, cy+2, 1)
if nm == ';' then do
gen = nm
iterate
end
end
if pos(nm, m.ut_alfa' ') < 1 then
call err 'fCache bad name %#'nm 'in' fmt
if pos(nm, gen) < 1 then
gen = gen || nm
end
if symbol('m.f_s_0') \== 'VAR' | m.f_s_0 == 0 then
m.f_s_0 = 1
else do
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
end
do cx=1 to length(gen)
nm = substr(gen, cx, 1)
act = f.nm
a2 = a
if nm == ' ' then
a2 = a
else
a2 = a'%##'nm
call scanSrc f_s, act
m.f_gen.a2 = fGen(f_s)
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
end
m.f_s_0 = m.f_s_0 - 1
return a
endProcedure fCache
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fCache
%#v before contents of variable v (1 alfa or 1 space),
stored at address%##v
%#?v define variable v if not yet defined
%#; restart of variables to generate
%&v use of previously defined variable v
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg f_s
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
if scanWhile(f_s, '0123456789') then
len = m.f_s.tok
else
len = ''
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," word(prec 0, 1)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," word(prec 0, 1)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnits("aa", '"m.f_s.tok"'," len"," prec pl")"
end
/* else if sp = '(' then do
if af == '' | flags \== '' | len \== 0 | prec \== '' then
call scanErr f_s, "bad call shoud be @sub%("
interpret "cRes = fGen"af"(f_s, ax)"
cd = cd '||' cRes
if \ scanLit(f_s, '%)') then
if \ scanEnd(f_s) then
call scanErr f_s, '%) to end call' af 'expected'
end */
else do
call scanBack f_s, '%'sp
leave
end
end
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGen
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if \ scanLit(f_s, '%%', '%@') then
return res
res = res || substr(m.f_s.tok, 2)
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jReadO(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) -------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal -----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 ---------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ----------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*--- generate timestamp formats: from format c to format d ----------*/
fTstGen: procedure expose m.
parse arg c 2 d, s
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
a = 'F_TSTFO.'
/* Y: A = 2010, M:B=Januar,
H=Stunde A=0 B=10 C=20
jkl = julian day
yyyy-mm-dd-hh.mm.ss.ffffff */
call mPut a'S', 'yz34-56-78-hi.mn.st.abcdef'
call mPut a's', 'yz34-56-78-hi.mn.st'
call mPut a' '
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78'
call mPut a'M', 'M78himns'
call mPut a'A', 'A8himnst'
call mPut a'H', 'Himnst'
call mPut a'n', 'yz345678 hi:mn:st'
call mPut a'N', 'yz345678 hi:mn:st.abcdef'
return fTstGen(cd, s)
end
if pos('(', s) > 0 | length(s) > 20 then
return "fImm('F_GEN."fCache('%t'cd, '%t'cd)"'," s")"
if c == ' ' then do
if pos(d, 'SN') > 0 then
o = "Ndate('S') time('L')"
else if pos(d, 'sMAn ') > 0 then
o = "ndate('S') time()"
else if pos(d, 'DdEeY') > 0 then
o = "Ddate('S')"
else if pos(d, 'tH') > 0 then
o = "ttime()"
else if pos(d, 'T') > 0 then
o = "Ttime('L')"
else
call err 'fTstGen implement d='d
parse var o o1 2 o2
return "fImm('F_GEN."fCache('%t'o1 || d, '%t'o1 || d)"',"o2")"
end
f = m.f_tstFo.c
if d = ' ' then
d = 's'
t = m.f_tstFo.d
if f == t then
return s
r = "translate("quote(t, "'")"," s "," quote(f, "'")")"
if pos('yz34', t) > 0 & pos('yz34', f) < 1 then do
if pos('34', f) > 0 then
r = "overlay('20'," r"," pos('yz', t)")"
else if pos('Y', f) > 0 then
r = fTstGY2Year(r, "substr("s"," pos('Y', f)", 1)", 4,
, pos('yz34', t))
else
r = "overlay('0000'," r"," pos('yz34', t)")"
end
else if pos('34', t) > 0 & pos('34', f) < 1 then do
if pos('Y', f) > 0 then
r = fTstGY2Year(r, "substr("s"," pos('Y', f)", 1)", 2,
, pos('34', t))
else
r = "overlay('00'," r"," pos('34', t)")"
end
if pos('Y', t) > 0 & pos('Y', f) < 1 then do
if pos('yz34', f) > 0 then
r = fTstGYear2Y(r, "substr("s"," pos('yz34', f)", 4)" ,
, pos('Y', t))
else if pos('34', f) > 0 then
r = fTstGYear2Y(r, "substr("s"," pos('34', f)", 2)" ,
, pos('Y', t))
else
r = "overlay('?'," r"," pos('Y', t)")"
end
if pos('M', t) > 0 & pos('M', f) < 1 then do
if pos('56', f) > 0 then
r = fTstG02A(r, "substr("s"," pos('56', f)", 2)" ,
, pos('M', t))
else
r = "overlay('?'," r"," pos('M', t)")"
end
if pos('56', t) > 0 & pos('56', f) < 1 then
if pos('M', f) > 0 then
r = fTstGA2N2(r, "substr("s"," pos('M', f)", 1)" , "-1",
, pos('56', t))
else
r = "overlay('01'," r"," pos('56', t)")"
if pos('78', t) > 0 & pos('78', f) < 1 then
r = "overlay('01'," r"," pos('78', t)")"
if pos('A8', t) > 0 & pos('A8', f) < 1 then
if pos('78', f) > 0 then
r = fTstG02A(r, "substr("s"," pos('78', f)", 1)" ,
, pos('A8', t))
else
r = "overlay('A1'," r"," pos('A8', t)")"
if pos('hi', t) > 0 & pos('hi', f) < 1 then do
if pos('H', f) > 0 then
r = fTstGA2N1(r, "substr("s"," pos('H', f)", 1)" , "-1",
, pos('hi', t))
else
r = "overlay('00'," r"," pos('hi', t)")"
end
if pos('i', t) > 0 & pos('i', f) < 1 then
r = "overlay('0'," r"," pos('i', t)")"
if pos('H', t) > 0 & pos('H', f) < 1 then do
if pos('hi', f) > 0 then
r = fTstG02A(r, "substr("s"," pos('hi', f)", 1)" ,
, pos('H', t))
else
r = "overlay('A'," r"," pos('H', t)")"
end
if pos('mn', t) > 0 & pos('mn', f) < 1 then
r = "overlay('00'," r"," pos('mn', t)")"
if pos('st', t) > 0 then do
if pos('st', f) < 1 then
if pos('s', f) > 0 then
r = "overlay('0'," r"," pos('t', t)")"
else
r = "overlay('00'," r"," pos('st', t)")"
end
else if pos('s', t) > 0 & pos('s', f) < 1 then
r = "overlay('0'," r"," pos('s', t)")"
if pos('abcdef', t) > 0 & pos('abcdef', f) < 1 then
r = "overlay('000000'," r"," pos('abcdef', t)")"
return r
endProcedure fTstGen
/*--- from Number overlay Character A=0, B=1 etc.. ------------------*/
fTstG02A: procedure expose m.
parse arg r, n, tx
return "overlay(substr(m.ut_alfUc," n "+ 1, 1)," r"," tx")"
/*--- from year overlay Y-Character A=2010 etc..--------------------*/
fTstGYear2Y: procedure expose m.
parse arg r, y, tx
return fTstG02A(r, "("y "+ 10) // 20", tx)
/*--- from character A=0 overlay 1 digit number ---------------------*/
fTstGA2N1: procedure expose m.
parse arg r, y, dlt, tx
return "overlay(right(pos("y", m.ut_alfUc)" dlt", 1)," r"," tx")"
/*--- from character A=0 overlay 2 digit number ---------------------*/
fTstGA2N2: procedure expose m.
parse arg r, y, dlt, tx
return "overlay(right('00' || (pos("y", m.ut_alfUc)" dlt"), 2)",
"," r"," tx")"
/*--- from Y yearCharacter overlay 2 or 4 digit year ----------------*/
fTstGY2Year: procedure expose m.
parse arg r, y, len, tx
if m.f_tstY2ini \== 1 then do /* generate lookup table */
m.f_tstY2ini = 1
n = left(f('%t '), 4)
do i = n-15 to n+4 /* 20 values: from -15 years to + 4 */
j = left(f('%tDY', i'0101'), 1)
m.f_tstY24.j = i
m.f_tstY22.j = right(i, 2)
/* say j m.f_tstY22.j m.f_tstY24.j */
end
end
if wordPos(len, 2 4) < 1 then
call err "fTstGYear2Y bad len" len
return "overlay(mGet('F_TSTY2"len".'"y")," r"," tx")"
endProcedure fTstGY2Year
fWords: procedure expose m.
parse arg fmt, wrds
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if wrds = '' then
return f(f2'%##e')
res = f(f2'%##a', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res
endProcedure fWords
/* copy f end *******************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(ELARDDL0) cre=2013-11-29 mod=2013-11-29-11.14.54 A540769 ---
$#:
* WS2/3 Script fuer Jobs fuer ElarDDL
*
*
lib = XB.ELAR.INFRA.FAM.NDBS.FINAL
gen = DSN.ELAR.GENDDL
creDb = 0 $** create databases if missing
$** nur mit WS3 |||||||||
checkSql = DSN.DBX.XB.SQL(#ELARDDL)
dbSys = DEVG
jn = XBDDLJOB
rxLib = ORG.U0009.B0106.KIDI63.EXEC
* @splitCheckDDL
dbEx = 1
$#@
if $creDb then $@¢
call sqlConnect $dbSys
call sqlQueryPrep 7, "select name from sysibm.sysDatabase" ,
"where name = ?"
$!
$;
$>.fEdit($-gen'(DDLJOB) ::f')
lmmId = lmmBegin($lib)
$do mx=1 to 9999 $@¢
mbr = lmmNext(lmmId)
if mbr = '' then
leave
call readDsn "'"$lib"("mbr")'", i.
db = ''
cnt = 0
do ix=1 to i.0
li = translate(i.ix)
if wordPos('IN', li) > 0 then do
nd = word(li, wordPos('IN', li) + 1)
nd = word(translate(nd, ' ', '.'), 1)
if nd = '' then
call 'err' mbr ix 'bad in:' i.ix
if db = '' then
db = nd
else if db \== nd then
call err 'db was' db 'but now' nd 'in' mbr ix':'i.ix
cnt = cnt + 1
end
if wordPos('DROP', li) > 0 then do
if abbrev(li, '--') then nop
else if subWord(li, wordPos('DROP', li)-2, 2) ,
== 'RESTRICT ON' then nop
else
call err 'drop in' mbr ix':'i.ix
end
end
if db = '' then
call err 'no db found in' mbr
if mx // 20 = 0 then
say mx mbr 'db' db 'cnt' cnt
$=mbr=- mbr
$=db =- db
if $creDb then $@¢
call sqlQueryArgs 7, db
$=dbEx =- sqlFetch(7, ee)
call sqlClose 7
$=mx =- right(mx, 4, 0)
$!
if mx // 50 = 1 then $@=/jc/
//$jn JOB (CP00,KE50),'DB2 ELARDDL',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2
//*MAIN CLASS=LOG
$/jc/
$@=/jcl/
//******** $mx db=$db mbr=$mbr *************************
$*(
// IF RC=0 THEN
//S${mx}CHB EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD DISP=SHR,DSN=$gen.BEF($db)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- elar checkDDl before $mx db=$db mbr=$mbr -------------
// DD DISP=SHR,DSN=$gen(CHKSQL1)
// DD *
INSERT INTO SESSION.FAMLISTE ( FAMILY, DBNAME )
VALUES ( '?', '$db')
;
// DD DISP=SHR,DSN=$gen(CHKSQL2)
// ENDIF $*)
// IF RC=0 THEN
//S${mx}DDL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- elar createDDl $mx db=$db mbr=$mbr -------------
--#SET MAXERRORS 0
set current sqlid = 'S100447';
$@¢ if \ $dbEx then $@=¢
create database $db
BUFFERPOOL BP2 INDEXBP BP1 CCSID EBCDIC
STOGROUP GSMS4
;
$! $!
// DD DISP=SHR,DSN=$lib($mbr)
// ENDIF
$*(
// IF RC=0 THEN
//S${mx}CHA EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD DISP=SHR,DSN=$gen.AFT($db)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- elar checkDDl after $mx db=$db mbr=$mbr -------------
// DD DISP=SHR,DSN=$gen(CHKSQL1)
// DD *
INSERT INTO SESSION.FAMLISTE ( FAMILY, DBNAME )
VALUES ( '?', '$db')
;
// DD DISP=SHR,DSN=$gen(CHKSQL2)
// ENDIF $*)
$@/sleep/ if mx // 10 = 0 then $@=¢
// IF RC = 0 THEN
//SLE$mx EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSPROC DD DISP=SHR,DSN=$rxLib
//WSH DD DUMMY
//SYSTSIN DD *
ws2 @ call sleep 30
// ENDIF
$! if mx > 30 then leave $/sleep/
$/jcl/
$!
call lmmEnd lmmId
$@proc @/splitCheckDDL/
call readDsn $checkSql, c.
do cx=1 to c.0 until abbrev(c.cx,
, 'INSERT INTO SESSION.FAMLISTE ( FAMILY, DBNAME )')
end
if cx >= c.0 then
call err 'INSERT INTO SESSION... not in' $checkSql
call writeDsn $gen'(chkSql1) ::f', c., cx-1, 1
do cx=cx+1 to c.0 until pos(';', c.cx) > 0
end
ox = 0
do cx=cx+1 to c.0
ox = ox+1
o.ox = c.cx
end
call writeDsn $gen'(chkSql2) ::f', o., ox, 1
call writeDsn $gen.bef'(#) ::f133', o., 0, 1
call writeDsn $gen.aft'(#) ::f133', o., 0, 1
$/splitCheckDDL/
$#out 20131129 11:08:28
$#out 20131129 11:05:40
$#out 20131129 11:03:09
$#out 20131129 10:59:13
}¢--- A540769.WK.REXX(ELARDRDD) cre=2013-07-08 mod=2013-07-19-13.27.18 A540769 ---
$#@
call sqlConnect DVBP
$;
$** $>.fEdit() $@/ddl/
call sqlStmts , , 'sql72' $<=/ddl/
SET CURRENT SQLID='S100447';
$*(
alter TABLE s100447.tElarDrop
alter info set data type varchar(1000);
commit;
$*)
xrop tablespace db2admin.elarDrop;
commit;
CREATE TABLESPACE ElarDrop
IN Db2Admin
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
TRACKMOD YES
SEGSIZE 64
BUFFERPOOL BP2
LOCKSIZE ANY
LOCKMAX SYSTEM
CLOSE YES
COMPRESS YES
CCSID UNICODE
DEFINE YES
MAXROWS 255
;
CREATE TABLE s100447.tElarDrop
( tst timestamp not null
, db char(8) not null
, kind char(8) not null
, nm char(20) not null with default
, sta char(2) not null with default
, info varchar(1000) not null with default
, primary key (db, kind, nm, tst)
)
in db2admin.elarDrop
AUDIT NONE
DATA CAPTURE NONE
CCSID UNICODE
NOT VOLATILE
;
CREATE UNIQUE INDEX s100447.IElarDrop0
ON s100447.tElarDrop
(db ASC,
kind ASC,
nm ASC,
tst ASC
)
include(sta)
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 5
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
;
CREATE UNIQUE INDEX s100447.IElarDrop1
ON s100447.tElarDrop
(tst desc,
db ASC,
nm ASC,
kind ASC
)
include(sta)
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 5
GBPCACHE CHANGED
not CLUSTER
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
;
CREATE UNIQUE INDEX s100447.IElarDrop2
ON s100447.tElarDrop
(kind asc,
nm ASC,
db ASC,
tst ASC
)
include(sta)
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 5
GBPCACHE CHANGED
not CLUSTER
BUFFERPOOL BP1
CLOSE YES
COPY NO
DEFINE YES
PIECESIZE 2 G
;
commit;
$/ddl/
}¢--- A540769.WK.REXX(ELARDROP) cre=2013-06-07 mod=2014-01-23-13.05.01 A540769 ---
/* Rexx ****************************************************************
synopsis: ELARDROP
D grp dbListe dbSql yymmdd text
define disposal request mit DB's in dbListe, sqlMbr, stopDatum
plus comment text
I grp DBs analysieren,
C grp check job generieren
? grp report state
CHECK db sta text resultat von check index auf db
s grp stop db
r grp vsam rename (job erstellen)
p grp drop job erstellen
http://chw20025641/host/db2wiki/pmwiki.php?n=App.ElarDrop
23. 1.14 Walter alle starts anzeigen, drop: jobWechsel nur nach drop db
08.11.13 Walter fix drop db
22.10.13 Walter fix db Anzeige
20. 6.13 Walter neu
***********************************************************************/
parse arg mArg
if pos('?', fun grp rest) > 0 then
exit help()
m.noVsamFail = 0
m.warning = 0
m.rxLib = 'A540769.WK.REXX'
m.rxLib = 'ORG.U0009.B0106.KIDI63.EXEC'
if mArg == '' then do
if 0 then
mArg = 'd disp01 XB.ELAR.INFRA.FAM.OLD.DDL.SAVE(STOP01DB)' ,
'stop01sq 130615 pilot request mirco'
else if 0 then
mArg = 'd wal01 dsn.tx.case(per22dbl)' ,
'per22dbs 130715 test walter'
else if 0 then
mArg = 'i req1'
else if 0 then
mArg = 'c req1'
else if 0 then
mArg = 'check dbTest ok job=testJob step=testStep'
else if 0 then
mArg = '? wal01'
else if 1 then
mArg = 'p wal01'
else if 0 then
parse value 'D TS2' with fun grp rest
else if 0 then do
say dbStoppedTS('XBAT8009')
say dbStoppedTS('DXB03')
exit
end
else if 0 then
exit oRun(compInline('jc'))
else if 0 then do
say 'c103ab' c2d(x2c('c103ab')) ,
'q2i' q2i('c103ab', '0123456789abcdef'),
i2q(q2i('c103ab', '0123456789abcdef'), '0123456789abcdef')
say 'uniq DZGROV1V' timeUniq2Lrsn('DZGROV1V'),
timeLrsn2GMT(timeUniq2Lrsn('DZGROV1V')),
timeLrsn2LZT(timeUniq2Lrsn('DZGROV1V'))
exit
end
else
call errHelp 'no fun'
end
parse var mArg fun grp rest
upper fun
call wshIni
m.sqlRetOk = 'w'
call errReset hi
call envPut 'dbSys', 'DVBP'
call envPut 'dbMbr', 'DBP%'
call envPut 'grp', grp
call envPut 'dp2g', 'DP2G'
call sqlConnect envGet('dbSys')
m.tb = 's100447.tElarDrop'
dLib = 'dsn.elarDrop.'grp
m.cIns = 0
if fun == 'D' then do
parse var rest dbDsn sqDsn stop text
if length(stop) = 6 then
stop = '20'stop
if length(stop) <> 8 then
call err 'bad date' stop
info = 'stop='stop 'text='text
if sql2one("select count(*) from" m.tb ,
"where kind = 'disp req' and nm = '"grp"'") ,
<> 0 then
call err 'grp' grp 'already in' m.tb
if sysDsn("'"dLib"'") <> 'DATASET NOT FOUND' then
call err 'grp dsn' dLib 'exists sysdsn='sysDsn("'"dLib"'")
if length(dbDsn) <= 8 then
dbDsn = 'XB.ELAR.INFRA.FAM.OLD.DDL.SAVE('dbDsn')'
call readDsn dbDsn, i.
call writeDsn dLib'(dbList) ::f', i., , 1
if length(sqDsn) <= 8 then
sqDsn = dsnSetMbr(dbDsn, sqDsn)
call readDsn sqDsn, s.
do sx=1 to s.0 while \ abbrev(s.sx, '//SYSIN')
end
ox=0
m.com.0 = 0
call mAdd com, "with e (fam, db) as" ,
, "("
cSto = 0
do sx=sx+1 to s.0 while \ abbrev(s.sx, '//')
s1 = strip(s.sx, t)
if right(s1, 1) = ';' then
s1 = left(s1, length(s1)-1)
ox = ox+1
o.ox = s1
if \ cSto then
cSto = wordPos(translate(word(s1, 1)), ORDER WITH) > 0
if \ cSto then
call mAdd com, s1
end
call writeDsn dLib'(dbSql)', o., ox , 1
call mAdd com,
, ")",
, ", d as",
, "(",
, "select * from s100447.tElarDrop",
, " where kind = 'disp req' and nm = '"grp"'",
, ")",
, ", j (db, com) as",
, "(",
, " select value(e.db, d.db)",
, " , case when e.db is not null and d.db is not null",
"then 'both'",
, " when e.db is not null then 'elarOnly'",
, " when d.db is not null then 'dba Only'",
, " else 'neither'",
, " end",
, " from e full join d on e.db = d.db",
, ")"
call mAdd com,
, "select com, char(count(*)) db",
, " from j",
, " group by com",
, "union all select com, db",
, " from j where com <> 'both'"
call writeDsn dLib'(dbComp)', m.com., , 1
call pipe '+F', file(dLib'(info1)')
call oRun compInline('jc'), 'I'
call oRun compInline('exeED'), 'i', grp
call pipe '-'
call pipe '+F', file(dLib'(info2)')
call oRun compInline('jc'), 'I'
call oRun compInline('exeED'), '?', grp
call pipe '-'
call getTst
do lx=1 to i.0
d1 = strip(substr(i.lx, 22, 8))
call sqlUpdate , "insert into" m.tb "(tst,kind,nm,db,info)" ,
"values ('"m.tst"', 'disp req', '"grp"', '"d1"'" ,
", '"info"')"
end
call sqlCommit
say 'grp='grp lx-1 'dbs inserted, tst='m.tst info
call sql2st mCat(com, '%qn %s'), cout
if m.cout.0 <> 1 | strip(m.cout.1.db) <> lx-1 then do
say 'db mismatch' m.cout.0 'lines ........'
do cx=1 to m.cout.0
say m.cout.cx.com m.cout.cx.db
end
call err 'db mismatch' m.cout.0 'lines'
end
end
else if fun == 'I' then do
call statsIni o
do dx=1 to getDbs(grp)
db = m.dbs.dx
call dbSelect db
call insertInfo db, getTst()
call sqlCommit
if dx // 20 = 0 then
say m.tst db dx 'dbs,' m.cIns 'inserts' statsInfo(o)
end
say m.tst db (dx-1) 'dbs,' m.cIns 'inserts' statsInfo(o)
end
else if abbrev(fun, '?') then do
call statsIni o
call getDbs grp
res = 'dbs='m.dbs.0
if fun == '?' | pos('I', fun) > 0 then do
res = queryInfoChanged(grp)
say res
end
if fun == '?' | pos('C', fun) > 0 then do
res = queryCheck(grp) res
say res
end
if fun == '?' | pos('S', fun) > 0 then do
res = queryStart(grp) res
say res
end
if fun == '?' then do
call sqlUpdate , 'insert into' m.tb ,
'(tst,db,kind,nm,sta,info) values' ,
"('"getTst()"', '', 'disp inf', '"grp"', '', '"res"')"
call sqlCommit
say 'inserted disp inf' m.tst
end
end
else if fun == 'C' then do
jobChars = left(m.ut.alfUC, 25)
jobDbs = 40
if wordPos('ER', translate(rest)) > 0 then
w1 = "<> 'ok'"
else
w1 = "is null"
call sql2St "select strip(db) db from" m.tb "d",
"where kind = 'disp req' and nm = '"grp"'",
"and (select min(nm) from" m.tb "c",
"where c.kind = 'check' and c.db = d.db",
"and c.tst > d.tst)" w1, dq
say 'checking' m.dq.0 "db's from" getDbs(grp)
call pipe '+F', file(dLib'(check)')
do dx=1 to m.dq.0
d1 = m.dq.dx.db
if dx // jobDbs = 1 then do
jc = substr(jobChars, 1 + dx%jobDbs//length(jobChars),1)
call oRun compInline('jc'), jc
end
call oRun compInline('genCheck'), strip(d1), dx
end
call pipe '-'
end
else if fun == 'CHECK' then do
db = grp
parse var rest sta info
if wordPos(sta, 'ok er') < 1 then
call err 'bad sta' sta 'in mArg' mArg
call sqlUpdate , "insert into" m.tb ,
"(tst,db,kind,nm,sta,info) values" ,
"('"getTst()"', '"db"', 'check', '"sta"', '"sta"', '"info"')"
say 'check index' sta 'for db' db 'at' m.tst 'info:' info
end
else if fun == 'S' then do
call checkInfos grp, 's'
call pipe '+F', file(dLib'(stop)')
call oRun compInline('jc'), 'S'
nSto = 500
nSleep = 300
do dx= 1 to m.dbs.0
db = m.dbs.dx
if dx // nSto = 1 then do
nSt = right('000000'dx, 6)
if dx > 1 then do
call out '-dis group'
call oRun compInline('sleep'), 'W'nSt, nSleep
end
call oRun compInline('db2Cmd'), 'S'nSt
call out '-dis group'
end
/* call out '-sto db('db') sp(*)' */
call out '-sto db('db')'
end
call out '-dis group'
call pipe '-'
end
else if fun == 'R' then do
call checkInfos grp, 'r'
call pipe '+F', file(dLib'(rename)')
call oRun compInline('jc'), 'R'
call oRun compInline('idcams')
do dx= 1 to getDbs(grp)
db = m.dbs.dx
if dx // 100 = 0 then
say dx db time()
call sql2St "select info from" m.tb "i",
"where db = '"db"' and kind = 'info dsn'",
"group by info", dsL
do dy=1 to m.dsL.0
i1 = m.dsL.dy.info
cx = pos('dsn=', i1)
dsn = word(substr(i1, cx+4), 1)
cx = pos('.', dsn)
if substr(dsn, cx, 8) \== '.DSNDBC.' then
call err 'bad dsn' dsn
call out ' ALTER' dsn '-'
call out ' NEWNAME('overlay('.MIG', dsn, cx)')'
dsd = overlay('D', dsn, cx+6)
call out ' ALTER' dsd '-'
call out ' NEWNAME('overlay('.MIG', dsd, cx)')'
end
end
call pipe '-'
end
else if fun == 'P' then do
call checkInfos grp, 'p'
iL = m.disp.0
iL = m.disp.iL.info
iDb = substr(fWord('dbs=', iL, ' '), 5)
iTs = substr(fWord('ts=' , iL, ' '), 4)
call sqlPreOpen 1, jCatLines(o2File(compInline('dropSel')))
call pipe '+F', file(dLib'(drop)')
bDb = 0
bTs = 0
tDb = 0
tTs = 0
cDr = 0
lDr = 50
nDr = lDr
nSt = 1
nSleep = 300
call oRun compInline('jc'), 'R'
call oRun compInline('dsnTep2'), 'SQL'nSt
do while sqlFetch(1, qq)
if m.qq.jn == 'both' then do
cDr = cDr + 1
if m.qq.ts == '' then do
call out '?rop database' m.qq.db'; commit;'
bDb = bDb + 1
if cDr >= nDr then do
nDr = cDr + lDr
call oRun compInline('sleep'), 'WAI'nSt, nSleep
if nSt // 100 = 0 then
call oRun compInline('jc'), 'R'
nSt = nSt + 1
call oRun compInline('dsnTep2'), 'SQL'nSt
end
end
else do
call out '?rop tablespace' m.qq.db'.'m.qq.ts'; commit;'
bTs = bTs + 1
end
end
else if m.qq.jn = 'tt' then do
if m.qq.ts == '' then
tDb = tDb + 1
else
tTs = tTs + 1
end
else
call err 'e}'m.db'.'m.ts 'join='m.qq.jn 'new db2 object?'
end
say 'dropping' bDb 'db and' bTs 'ts, already dropped' tDb 'and' tTs
if bDb + tDb <> iDb then
call err 'mismatch to' iDB 'db in info'
if bTs + tTs <> iTS then
call err 'mismatch to' iTs 'ts in info'
call pipe '-'
call sqlClose 1
end
else if 1 then do
call err 'bad fun' fun
end
else if fun == 'Sold' then do
call sqlConnect envGet('dbSys')
call sqlExec "set current path = 'OA1P'"
m.outOK = jOpen(file(pre'.info(elarDrop)'), '>')
m.outNo = jOpen(file(pre'.info(elarDrNo)'), '>')
m.outDDL = jOpen(file(pre'.jcl(elarDDL)'), '>')
m.outStop = jOpen(file(pre'.jcl(elarStop)'), '>')
call pipe '+F', m.outStop
call oRun compInline('jc'), 'S'
call oRun compInline('dbCmd')
call pipe '-', m.outStop
m.LibInfo = pre'.info'
call envPut 'libDDL', translate(pre'.DDL')
m.ddlStep = 0
m.ddlJC =ABCDEFG
m.ddlJN =0
call cntReset
call pipe '+f', , file(pre'.info(dbList)')
do lx=1 to 1e1 while in(li)
call dbSelect strip(substr(m.li, 38, 8))
call dbStop
if lx // 30 = 0 then
say '***'cntLine()
end
say '***'cntLine()
call pipe '-'
call jClose m.outOK
call jClose m.outNo
call jClose m.outDDL
call jClose m.outStop
call sqlDisconnect
end
else if fun == 'V' then do
call sqlConnect envGet('dbSys')
call sqlExec "set current path = 'OA1P'"
call cntReset
ic = infoComp(pre'.info(elarDrop)')
m.outVsam = jOpen(file(pre'.jcl(elarVsam)'), '>')
call pipe '+F', ic
m.vsamC = 0
do lx=1 to 1e99 while infoCompNext(ic)
call dbSelect m.ic.db
call dbOut
call dbCheckStopped
call dbVsam
if lx // 30 = 0 then
say '***' time() cntLine()
end
call pipe '-'
call jClose m.outVsam
say 'infoComp' m.ic.rtsUpd 'rtsUpd' m.ic.rtsUpdMin m.ic.rtsUpdMax
call sqldisconnect
end
else if fun == 'D' then do
call sqlConnect envGet('dbSys')
call sqlExec "set current path = 'OA1P'"
call cntReset
ic = infoComp(pre'.info(elarDrop)')
m.outDrop = jOpen(file(pre'.jcl(elarDrop)'), '>')
call pipe '+F', m.outDrop
call oRun compInline('jc'), 'D'
call oRun compInline('dsnTep2')
call pipe '-', m.outDrop
call pipe '+F', ic
m.dropDb = 0
m.dropTs = 0
do lx=1 to 1e1 while infoCompNext(ic)
call dbSelect m.ic.db
call dbOut
call dbCheckStopped
/* call dbVsam check keine Vsam mehr ???? */
call dbDrop
if lx // 30 = 0 then
say '***' time() cntLine()
end
call pipe '-'
call jClose m.outDrop
say 'infoComp' m.ic.rtsUpd 'rtsUpd' m.ic.rtsUpdMin m.ic.rtsUpdMax
call sqldisconnect
end
else if fun == 'SAY' then do
call sqlConnect envGet('dbSys')
call sqlExec "set current path = 'OA1P'"
call cntReset
call pipe '+f', , file(pre'.info(dbList)')
do lx=1 to 1e1 while in(li)
call dbSelect strip(substr(m.li, 38, 8))
call dbOut
say '***' time() cntLine()
end
call pipe '-'
call sqldisconnect
end
else if 0 then do
call pipe '+F', file('~tmp.texv(elarDrop)')
call delDb 'MF01A1A'
end
else if 0 then do
call sqlExec "set current path = 'OA1P'"
call delDb 'XB375001'
/* call delDb 'XB9DL074 XBAT8007 XBAT8074 XB9O8056 XB375001' */
end
else if 0 then do
call sqlConnect dbof
call sqlExec "set current path = 'OA1P'"
call delDb 'MF01A1P'
end
else
call err 'bad fun' fun
say m.warning 'warnings'
exit 0
getTst: procedure expose m.
m.tst = sql2one("select value(max(current timestamp",
", max(tst)+1e-5 seconds), current timestamp) from" m.tb)
return m.tst
endProcedure getTst
getDbs: procedure expose m.
parse arg grp
w1 = "where nm = '"grp"'"
call sql2st "(select * from" m.tb w1 "and kind = 'disp req'",
"order by db fetch first row only)" ,
"union all (select * from" m.tb w1 "and kind = 'disp inf')",
"order by tst", disp
dc = sql2St("select db from" m.tb w1 "and kind = 'disp req'",
"order by db", 'DBS',
, , ':m.dst')
if dc < 1 then
call err 'e}no dbs in grp' grp
say dc 'dbs in grp' grp
return dc
endProcedure getDbs
/*--- getDbs and check if disp inf is okay for fun ------------------*/
checkInfos: procedure expose m.
parse arg grp, fun
if fun == 's' then
limDays = 10
else if fun == 'r' then
limDays = 30
else if fun == 'p' then
limDays = 90
else
call err 'checkInfos bad fun' fun
fuNo = 'e}'fun 'for' grp 'not allowed'
afLim = 'newer' limDays 'days'
call adrTso 'clear'
call getDbs grp
if m.disp.0 < 2 then
call err fuNo "no 'disp inf' in" m.tb
ww.checked = 'all never'
ww.tsStopped = 'all never'
ww.ixStopped = 'all never'
ww.vsamCl0 = 'all never'
do dx = m.disp.0 by -1 to 2
iL = m.disp.dx.info
ci = fWord('checkIndex=', iL, fuNo)
cj = substr(ci, 12)
t1 = 0
if abbrev(cj, 'allOK') then do
cy = lastPos('ok=', cj)
if substr(ci, lastPos('ok=', ci) + 3) <> m.dbs.0 then do
if dx = m.disp.0 | substr(ci, lastPos('ok=', ci) + 3),
< m.dbs.0 then
call err fuNo': check=allOK but dbs='m.dbs.0 '<>' ci,
'(dx='dx 'tst='m.disp.dx.tst')'
else
say 'warning allok, but less DBs'
end
t1 = 1
end
ww.checked = checki1(ww.checked, t1, dx)
td = fWord('tsDis=', iL, fuNo)
ww.tsStopped = checki1(ww.tsStopped, td == 'tsDis=STOP', dx)
ti = fWord('ixDis=', iL, fuNo)
ww.ixStopped = checki1(ww.ixStopped, ti == 'ixDis=STOP', dx)
ti = fWord('ixDis=', iL, fuNo)
ww.ixStopped = checki1(ww.ixStopped, ti == 'ixDis=STOP', dx)
ti = fWord('vsamCl=', iL)
ww.vsamCl0 = checki1(ww.vsamCl0, ti == 'vsamCl=0', dx)
end
dx = m.disp.0
iL = m.disp.dx.info
ww = 'rtCopyUpdate rtUpdTst riUpdTst'
if fun \== 's' then
ww = 'lastStart lastStaUt' ww
do wx=1 to words(ww)
w1 = word(ww, wx)
sW = fWord(w1'=', iL, fuNo)
v1 = translate(w1)
ww.v1 = translate(substr(sW, length(w1) + 2), ' ', '+')
end
lu = fWord('riLastUse=', iL, fuNo)
ww.riLastUse = translate('1234-56-78', substr(lu, 11), '12345678')
s = m.disp.1.info
t1 = strip(substr(s, pos('text=', s)+5))
s = word(substr(s, pos('stop=', s)+5), 1)
ww.stopRequest = translate('1234-56-78', s, '12345678') t1
vars = 'stopRequest lastInfo checked tsStopped ixStopped' ww ,
'riLastUse vsamCl0'
do vx=1 to words(vars)
v1 = word(vars, vx)
vU = translate(v1)
/* say left(v1, 15) ww.vU */
ok.vU = ''
end
limit = sql2One("select current timestamp -" limDays "days lim" ,
", current timestamp now" ,
", current timestamp - 24 hours lim1" ,
"from sysibm.sysDummy1",dt)
s1 = left(ww.stopRequest, 10)
if s1 > left(m.dt.now, 10) then
ok.stopRequest = 'in der Zukunft'
ww.lastInfo = m.disp.dx.tst
if ww.lastInfo < m.dt.lim1 then
ok.lastInfo = 'older 1 day'
cc = 'rtCopyUpdate riLastUse rtUpdTst riUpdTst'
do cx = 1 to words(cc)
c1 = word(cc, cx)
cU = translate(c1)
ok.cU = if(ww.cU > m.dt.lim, afLim)
end
ok.checked = if(pos('never', ww.checked) > 0 , 'not checked')
if fun \== 's' then do
if ok.stopRequest == '' & s1 > limit then
ok.stopRequest = afLim
v2 = word(ww.tsStopped, 2)
ok.tsStopped = if(v2 == 'never' | v2 > limit, afLim)
v2 = word(ww.ixStopped, 2)
ok.ixStopped = if(v2 == 'never' | v2 > limit, afLim)
ok.lastStart = if(ww.lastStart > limit, afLim)
end
if pos(fun, 'sr') < 1 then do
v2 = word(ww.vsamCl0, 2)
ok.vsamCl0 = if(v2 == 'never' | v2 > limit, afLim)
end
hasErr = 0
do vx=1 to words(vars)
v1 = word(vars, vx)
vU = translate(v1)
if ok.vU \== '' then
hasErr = 1
say left(ok.vU, 20) left(v1, 15) ww.vU
end
if hasErr then
call err fuNo
else
say 'checkInfos ok for' fun
return
endProcedure checkInfos
fWord: procedure expose m.
parse arg fi, src, fuNo
cx = pos(' 'fi, ' 'src)
if cx > 0 then
return word(substr(src, cx), 1)
if fuNo == '' then
return ''
call err fuNo':' fi 'not in info:' src
endProcedure fWord
checki1: procedure expose m.
parse arg old, isOk, dx
if \ abbrev(old, 'all') then
return old
if isOk then
return 'all' m.disp.dx.tst
else
return 'since' subword(old, 2)
endProcedure checki1
statsIni: procedure expose m.
parse arg o
m.o.cTs = 0 /* db2 object counts */
m.o.cTb = 0
m.o.cTp = 0
m.o.cIx = 0
m.o.cIp = 0
m.o.tpSpace = 0 /* tp */
m.o.tpRows = 0
m.o.rtSpace = 0 /* rt */
m.o.rtRows = 0
m.o.rtUpdTst = ''
m.o.rtCopyUpd = ''
m.o.ixSpace = 0 /* ix */
m.o.ixRows = 0
m.o.riSpace = 0 /* ri */
m.o.riRows = 0
m.o.riUpdTst = ''
m.o.riLastUse = ''
m.o.vsamCl = 0 /* vsam */
m.o.vsamDa = 0
m.o.haRba = 0
m.o.huRba = 0
m.o.cRiSPace = 0 /* count of changed rts columns */
m.o.cUpdTst = 0
m.o.tsDis = '' /* -dis db */
m.o.ixDis = ''
m.o.noVsam = 0
m.o.orphan = 0
return
endProcedure statsIni
statsInfo: procedure expose m.
parse arg o
return 'tsDis='translate(m.o.tsDis, '+', ' ') ,
'ixDis='translate(m.o.ixDis, '+', ' ') ,
'rtUpdTst='m.o.rtUpdTst 'riUpdTst='m.o.riUpdTst ,
'rtCopyUpdate='m.o.rtCopyUpd 'riLastUse='m.o.riLastUse ,
'dbs='m.dbs.0 'ts='m.o.cTs 'tb='m.o.cTb 'tp='m.o.cTp ,
f('tpSpace=%7e rtSpace=%7e tpRows=%7e rtRows=%7e' ,
,m.o.tpSpace, m.o.rtSpace, m.o.tpRows, m.o.rtRows ) ,
'ix='m.o.cIx 'ip='m.o.cIp ,
f('ixSpace=%7e riSpace=%7e ixRows=%7e riRows=%7e' ,
,m.o.ixSpace, m.o.riSpace, m.o.ixRows, m.o.riRows ),
'vsamCl='m.o.vsamCl f('haRba=%7e huRba=%7e',
, m.o.haRba, m.o.huRba),
'spWithoutVsam='m.o.noVsam ,
'vsamOrphans='m.o.orphan
endProcedure statsInfo
infoCompIni: procedure expose m.
if m.infoCompIni == 1 then
return
m.infoCompIni = 1
call classNew "n InfoComp u JRW", "m",
, "jOpen",
, "jReset",
, "jClose call jClose m.m.rdr",
, "jWrite call infoCompWrite m, line; return"
return
endProcedure infoCompIni
infoComp: procedure expose m.
parse arg dsn
call infoCompIni
n = oNew('InfoComp')
m.n.rdr = jOpen(file(dsn), '<')
m.n.cDb = ''
m.n.hasRead = jRead(m.n.rdr, n'.LINE')
m.n.db = ''
m.n.rtsUpd = 0
m.n.rtsUpdMax = ''
m.n.rtsUpdMin = 'ffff'x
return n
endProcedure infoComp
infoCompNext: procedure expose m.
parse arg m
if \ m.m.hasRead then
return 0
if \ abbrev(m.m.line, 'db=') then
call err 'not at db= but' m.m.line
aDb = substr(word(m.m.line, 1), 4)
if aDb = m.m.db then
call err 'same db' aDb
m.m.db = aDb
return 1
endProcedure infoCompNext
infoCompWrite: procedure expose m.
parse arg m, what
if \ m.m.hasRead then
call err 'not reading'
ok = what = m.m.line
if \ ok then
ok = abbrev(what, m.m.line)
if \ ok & abbrev(what, 'tableStats=') ,
& abbrev(word(what, 2), 'upd=') then do
ok = delWord(what, 2) = delWord(m.m.line, 2)
m.m.rtsUpd = m.m.rtsUpd + 1
if m.m.rtsUpdMin > word(what, 2) then
m.m.rtsUpdMin = word(what, 2)
if m.m.rtsUpdMax < word(what, 2) then
m.m.rtsUpdMax = word(what, 2)
end
if \ ok then do; trace ?r ; say what; say m.m.line; end;
m.m.hasRead = jRead(m.m.rdr, m'.LINE')
return
endProcedure infoCompWrite
dbDisplay: procedure expose m.
parse arg db
e = ''
call sqlDsn dsp, envGet('dbSys'),
, '-dis db('db') sp(*) limit(*)'
/* DSNT362I -DBP2 DATABASE = XB009001 STATUS = STOP */
do dx=1 to m.dsp.0 until abbrev(m.dsp.dx, 'DSNT362I ')
end
do dx=1 to m.dsp.0 until abbrev(m.dsp.dx, 'DSNT362I ')
end
if dx >= m.dsp.0 | wordPos('DATABASE', m.dsp.dx) < 1 ,
| wordPos(db, m.dsp.dx) < 1 then
e = 'db not found in display'
else if pos('STATUS =', m.dsp.dx) < 20 then do
e = 'db STATUS = not found in display'
end
else do
dbStopped = strip(substr(m.dsp.dx, pos('STATUS =',
, m.dsp.dx)+8)) == 'STOP'
dx = dx+2
if dx >= m.dsp.0 | \ abbrev(m.dsp.dx, 'DSNT397I') then
e = 'output not found in display'
else do
dx = dx+1
if dx >= m.dsp.0 | \ abbrev(m.dsp.dx, 'NAME') ,
| word(m.dsp.dx, 2) \== 'TYPE' ,
| word(m.dsp.dx, 4) \== 'STATUS' then
e = 'bad header' dx m.dsp.dx
end
end
sp = ''
do xTp = 1 to m.tp.0
m.tp.xTp.dis = ''
end
do xIp = 1 to m.ip.0
m.ip.xIp.dis = ''
end
do dx=dx+1 to m.dsp.0 while e == '' & \ abbrev(m.dsp.dx, '*****')
if abbrev(m.dsp.dx, '---') then
iterate
dKi = word(m.dsp.dx, 2)
if wordPos(dKi, 'TS IX') < 1 then do
if word(m.dsp.dx, 1) == '-THRU' then
iterate
e = e'; db' db 'bad -dis line' m.dsp.dx
end
m = getTsIx(word(m.dsp.dx, 1), 'TP IP', '')
if m == '' then do
e = e'; sp' sp 'not found in TP or IP'
leave
end
if (dKi = 'TS' & m.m.kind \== 'tp') ,
| (dKi = 'IX' & m.m.kind \== 'ip') then
e = e'; ts ix mismatch' dx m.dsp.dx
sta = word(m.dsp.dx, 3)
if sta = '' then
iterate
if dbStopped then
sta = 'STOP'
else if datatype(sta, 'n') then
sta = word(m.dsp.dx, 4)
m.m.dis = mergeWords(m.m.dis sta)
end
if e == '' then do
dx = dx+1
if dx <> m.dsp.0 | \ abbrev(m.dsp.dx, 'DSN9022I') then
e = e'; -dis bad end' dx m.dsp.dx
end
rTp = ''
do xTp = 1 to m.tp.0
if m.tp.xTp.dis = '' then
e = e';' xTp 'tp' m.tp.xTp.nm 'not in -dis'
m.tp.xTp.info = m.tp.xTp.info ,
'dis='translate(space(m.tp.xTp.dis, 1), '+', ' ')
rTp = mergeWords(rTp, m.tp.xTp.dis)
end
m.ds.1.tsDis = translate(rTp, '+', ' ')
m.o.tsDis = mergeWords(m.o.tsDis, rTp)
rIx = ''
do xIp = 1 to m.ip.0
if m.ip.xIp.dis = '' then
e = e';' xIp 'ix' m.ip.xIp.nm 'not in -dis'
m.ip.xIp.info = m.ip.xIp.info ,
'dis='translate(space(m.ip.xIp.dis, 1), '+', ' ')
rIx = mergeWords(rIx, m.ip.xIp.dis)
end
m.ds.1.ixDis = translate(rIx, '+', ' ')
m.o.ixDis = mergeWords(m.o.ixDis, rIx)
m.ds.1.info = m.ds.1.info 'tsDis='m.ds.1.tsDis 'ixDis='m.ds.1.ixDis
if e == '' then
return
say 'error' e 'in -dis db('db') sp(*) limit(*)'
call saySt dsp
call err e':'dx m.dsp.dx
endProcedure dbDisplay
mergeWords: procedure expose m.
parse arg src, add
do ax=1 to words(add)
if wordPos(word(add, ax), src) < 1 then
src = src word(add, ax)
end
return space(src, 1)
endProcedure mergeWords
getTsIx: procedure expose m.
parse arg sp, qq
tt = 'TS IP'
do tx=1 to words(tt)
t1 = word(tt, tx)
if qq == '' then
q1 = t1
else
q1 = word(qq, tx)
sx = wordPos(sp, m.t1.all)
if sx > 0 then do
rr = q1'.'sx
if sp == m.rr.nm then
return rr
call err t1 'mismatch' sp 'all' m.t1.all
end
end
if arg() > 2 then
return arg(3)
else
call err 'getTsIx' sp 'not found db=' m.ds.1.name
endProcedure getTsIx
/*
$=/jc/
$=jn =- 'XBDROPX'arg(2)
//$jn JOB (CP00,KE50),'DB2 ELAR DROP',
// MSGCLASS=E,TIME=1440,SCHENV=$dbSys,
// NOTIFY=&SYSUID,REGION=0M
//$'*'MAIN CLASS=LOG ***,DEADLINE=(1400,A,08/31/2013),HOLD=YES
$/jc/
$=/dbCmd/
$=stepNam =- left(arg(2),8)
//$stepNam EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSys)
$/dbCmd/
$=/sleep/
$=stepNam =- left(arg(2),8)
$=secs =- arg(3)
//$stepNam EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSPROC DD DISP=SHR,DSN=$-¢m.rxLib$!
//WSH DD DUMMY
//SYSTSIN DD *
wsh @ call sleep $secs
$/sleep/
$=/genDDL/
//$db EXEC PGM=PTLDRIVM,REGION=0M,PARM='EP=RML@MAIN'
//STEPLIB DD DISP=SHR,DSN=DSN.CADB2.RZ2.P0.CDBALOAD
// DD DISP=SHR,DSN=DB2@.RZ2.P0.DSNLOAD
//PTILIB DD DISP=SHR,DSN=DSN.CADB2.RZ2.P0.CDBALOAD
// DD DISP=SHR,DSN=DB2@.RZ2.P0.DSNLOAD
//PTIPARM DD DISP=SHR,DSN=DSN.CADB2.RZ2.P0.CDBAPARM
//PTIXMSG DD DISP=SHR,DSN=DSN.CADB2.RZ2.P0.CDBAXMSG
//MSGFILE DD SYSOUT=*
//REPFILE DD SYSOUT=*
//ABNLIGNR DD DUMMY SUPPRESS ABENDAID DUMPS
//DDLFILE DD DISP=SHR,DSN=$libDDL($db)
//PARMFILE DD *
STRTSSID $dbSys
CREATOR $jn
QUICKM
DATABASE $dbCr $db
EXPLODE TABLESPACE
EXPLODE TABLE
EXPLODE INDEX
EXPLODE VIEW
EXPLODE SYNONYM
EXPLODE TRIGGER
EXPLODE MQTB_T
EXPLODE MQTB_I
EXPLODE MQTB_V
EXPLODE MQTB_S
EXPLODE MQVW_VW
EXPLODE MQVW_I
EXPLODE MQVW_V
EXPLODE MQVW_S
QUICKEND
TRGSSID $dbSys
AUXIMP N
MQTIMP N
REFMQT N
LOBTOO
RI LOCAL
SEQIMP
VWIMPEXP
RTNIMP A
RTNIIO Y
SQLID S100447
TBOBID
NOAUTHS
DDLONLY
HEADER
TRAILER
REPINDDL
PREFIX DSN.TMP
MODEL4 @DEFAULT
MODEL4C S100447
$/genDDL/
$=/idcams/
//IDCAMS EXEC PGM=IDCAMS
//SYSPRINT DD SYSOUT=*
//SYSIN DD *
$/idcams/
$=/dsnTep2/
$@¢
parse arg , st
if st == '' then
st = 'SQL'
$=stepNm =- left(st,8)
$!
//$stepNm EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
$/dsnTep2/
$@/genCheck/
parse arg , db, no
$=no =- right('000000'no, 5)
$=db =- db
call sql2St "select strip(nm) from" m.tb "where kind = 'info ts'",
"and db = '"db"' group by nm order by nm", 'TS',
, , ':m.dst'
$@=¢
//$'**************' $no db=$db $*(
//$'*** ' -sta ut
//A$no EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSys)
$!
$@do tx=1 to m.ts.0 $@=¢
-sta db($db) sp($-¢m.ts.tx$!) acc(ut)
$!
$@=¢ $*)
//$'*** ' check $db.*
//C$no EXEC PGM=DSNUTILB,
// PARM=($dbSys,'$jn.CHECK'),
// REGION=0M
//DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSys.DBAA.LISTDEF(TEMPL)
//SYSIN DD *
LISTDEF LST INCLUDE INDEXSPACE $db.*
CHECK INDEX LIST LST
SHRLEVEL REFERENCE
SORTDEVT DISK
SORTNUM 200
WORKDDN TSYSUTS
// IF (C$no.RUN AND C$no.RC = 0 ) THEN
//$'*** ' ok status
//O$no EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSPROC DD DISP=SHR,DSN=$-¢m.rxLib$!
//SYSTSIN DD *
%elarDrop check $db ok job=$jn step=C$no
// ELSE
//$'*** ' error status
//E$no EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSPROC DD DISP=SHR,DSN=$-¢m.rxLib$!
//SYSTSIN DD *
%elarDrop check $db er job=$jn step=C$no
// ENDIF $*(
//$'*** ' -sto
//Z$no EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSys)
$!
$@do tx=1 to m.ts.0 $@=¢
-sto db($db) sp($-¢m.ts.tx$!)
$*)
$!
$/genCheck/
$=/exeED/
$=fun =- arg(2)
$=grp =- arg(3)
//RUN EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSPROC DD DISP=SHR,DSN=$-¢m.rxLib$!
//SYSTSIN DD *
%elarDrop $fun $grp
$/exeED/
$=/db2Cmd/
$=stepNam=- arg(2)
//$stepNam EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSys)
$/db2Cmd/
$=/dropSel/
with db as
( select db, tst
from S100447.telarDrop
where kind = 'disp req' and nm = '$grp'
)
, mx as
( select max(tst) tst, db, kind, nm
from S100447.telarDrop
group by db, kind, nm
)
, ts (db, ts) as
( select mx.db, mx.nm
from mx join db
on mx.db = db.db and mx.kind = 'info ts' and mx.tst > db.tst
union all select db, ''
from db
)
, cdb as
( select db
from db join sysibm.sysdatabase c
on db.db = c.name
)
, cc (db, ts) as
(
select c.dbName, c.name
from db join sysibm.sysTablespace c
on db.db = c.dbName
union all select db, ''
from db join sysibm.sysdatabase c
on db.db = c.Name
)
select case when cc.db is not null and ts.db is null then ''
when ts.db is null then 'cc'
when cc.db is null then 'tt'
else 'both' end jn
, strip(value(ts.db, cc.db)) db
, strip(value(ts.ts, cc.ts)) ts
from ts full outer join cc
on ts.db = cc.db and ts.ts = cc.ts
order by 2, 3 desc
$/dropSel/
*/
cntReset: procedure expose m.
m.cDb = 0
m.cTs = 0
m.cTP = 0
m.cTB = 0
m.tRows = 0
m.tSpace = 0
m.rRows = 0
m.rSpace = 0
return
endProcedure cntReset
cntLine: procedure expose m.
return right(m.cDb, 4)'db'right(m.cTs, 6)'ts' ,
|| right(m.cTP, 8)'tp'right(m.cTB, 6)'tb',
'rows' fE(m.rRows, 7) ,
'space' fE(m.rSpace, 7)
endProcedure cntLine
queryCheck: procedure expose m.
parse arg aGrp
call sql2st ,
"with c as",
"( select * from" m.tb "d" ,
"where d.kind = 'check' and d.tst = ",
"( select max(n.tst) from S100447.tElarDrop n" ,
"where n.kind = d.kind and n.db = d.db)",
") select d.nm grp, value(c.nm, 'miss') check , count(*) cnt" ,
"from" m.tb "d left join c",
"on c.db = d.db and c.tst > d.tst",
"where d.kind = 'disp req' and d.nm = '"aGrp"'",
"group by d.nm, c.nm order by 1, 2 desc", qc
cc = 0
txt = ''
do qx=1 to m.qc.0
if m.qc.qx.grp <> aGrp then
call err 'grp mismatch'
cc = cc + m.qc.qx.cnt
txt = txt','strip(m.qc.qx.check)'='m.qc.qx.cnt
if m.qc.qx.check <> 'ok' then
ok = 0
end
if cc <> m.dbs.0 then
call err 'db count mismatch'
return 'checkIndex='if(ok == 0, 'err', 'allOK')txt
endProcedure queryCheck
queryStart: procedure expose m.
parse arg aGrp
do dx=m.disp.0 by -1 to 1 ,
while pos('tsDis=STOP ', m.disp.dx.info) < 1
end
say 'lastStop' dx 'of' m.disp.0 m.disp.dx.tst
if dx < 1 then
return ''
do dx=1 to m.dbs.0
db = strip(m.dbs.dx)
qt.db = 1
do aL=length(db)-1 by -1 to 1
a1 = left(db, aL)
if qt.a1 == 1 then
leave
qt.a1 = 1
end
end
staSq = m.sqlNull
staUt = m.sqlNull
since = 'current timestamp - 12 months'
call sqlConnect envGet('dp2g')
call sqlPreOpen 5, "select strip(cmd) cmd, timestamp, dbmbr",
",CORR, AUTH",
"from oa1p.tAdmCmd",
"where timestamp >=" since "and verb = 'START'" ,
"and dbMbr like '"envGet("dbMbr")"'" ,
"and (upper(cmd) like '%DB%'" ,
"or upper(cmd) like '%DATABASE%')" ,
"order by timestamp desc" , qs
fnd = 0
do kx=1 while sqlFetchInto(5, ':cmd, :tst, :dbMbr, :corr, :auth')
r = translate(cmd)
if abbrev(r, '-') then
r = strip(substr(r, 2))
if abbrev(r, 'START') then
r = strip(substr(r, 6))
else if abbrev(r, 'STA') then
r = strip(substr(r, 4))
else
call err 'start not found:' cmd
if abbrev(r, 'DATABASE') then
r = strip(substr(r, 9))
else if abbrev(r, 'DB') then
r = strip(substr(r, 3))
else
call err 'db not found:' cmd
if abbrev(r, '(') then
r = strip(substr(r, 2))
else
call err '( not found:' cmd
myDbs = 0
do while \ abbrev(r, ')')
vx = verify(r, ' ,)', 'm')
if vx = 0 then
call err ') missing:' cmd
d1 = left(r, vx-1)
r = strip(substr(r, vx))
if abbrev(r, ',') then
r = strip(substr(r, 2))
if right(d1, 1) == '*' then
d1 = left(d1, length(d1)-1)
if pos('*', d1) > 0 | pos(':', d1) > 0 then
call err 'wildcard not supported' d1':' cmd
if qt.d1 == 1 then do
myDbs = 1
end
end
r = strip(substr(r, 2))
ac = ''
do forever
px = pos('ACC', r)
if px < 1 then
leave
r = substr(r, px+3)
if abbrev(r, 'ESS') then
r = strip(substr(r, 4))
else
r = strip(r)
if \ abbrev(r, '(') then
call err '( after acc missing' cmd
px = pos(')', r)
if px < 1 then
call err ') after acc missing' cmd
ac = strip(substr(r, 2, px-2))
leave
end
if \ myDbs then
iterate
if ac == 'UT' & staUt == m.sqlNull then
staUt = left(tst, 19) cmd
if ac \== 'UT' & staSq == m.sqlNull then
staSq = left(tst, 19) cmd
if 1 then
say left(tst, 19) dbMbr corr auth strip(cmd)
else if staSq \== m.sqlNull & staUt \== m.sqlNull then
leave
end
call sqlClose 5
call sqlConnect envGet('dbSys')
return 'lastStart='translate(space(staSq,1), '+', ' '),
'lastStaUt='translate(space(staUt,1), '+', ' ')
endProcedure queryStart
queryInfoChanged: procedure expose m.
parse arg aGrp
infos = 'DS TS TB TP RT IP VSAM'
kinds = 'db ts tb tp rt ip dsn '
do dx=1 to m.dbs.0
aDb = m.dbs.dx
call dbSelect aDb
do ix=1 to words(infos)
nn = word(infos, ix) /* stem new */
k1 = word(kinds, ix)
if k1 == 'dsn' then
ord = "cast (info as varchar(200) ccsid ebcdic)"
else if k1 == 'tb' then
ord = "substr(info, posStr(info, 'ts='), 20), nm"
else
ord = "nm"
call sql2St "select * from" m.tb "i",
"where i.kind = 'info" k1"'",
"and i.db = '"aDb"' and i.tst =" ,
"( select max(n.tst) from" m.tb "n" ,
"where n.kind = i.kind and n.db = i.db ",
"and n.nm = i.nm)",
"order by db, kind," ord, oo
if m.nn.0 <> m.oo.0 & k1 \== 'dsn' then
call err 'count mismatch' aDb k1
do ox=1 to m.oo.0
if m.oo.ox.db <> aDb | m.oo.ox.kind <> 'info' k1 then
call err 'db | kind mismatch' aDb k1':',
m.oo.ox.db m.oo.ox.kind '>>' aDb 'info' k1
if k1 == 'dsn' then do /* register old dsn */
oDsn = word(substr(m.oo.ox.info,
,pos('dsn=',m.oo.ox.info)+4), 1)
if symbol('oDsn.oDsn') == 'VAR' then
call err 'duplicate oDsn' oDsn
oDsn.oDsn = ox
end
else do /* compare all other types */
if m.oo.ox.nm <> m.nn.ox.nm then
call err 'name mismatch' aDb k1 ox ,
"\nnm:" m.oo.ox.nm '>>' m.nn.ox.nm,
"\ninfo:" m.oo.ox.info "\n>>>>:" m.nn.ox.info
call queryInfoComp aDb, k1, m.oo.ox.nm,
, m.oo.ox.info, m.nn.ox.info
end
end
if k1 == 'dsn' then do /* more new dsn's ??? */
do nx=1 to m.nn.0
nDsn = word(substr(m.nn.nx.info,
,pos('dsn=',m.nn.nx.info)+4), 1)
if symbol('oDsn.nDsn') <> 'VAR' then
say 'new dsn' nDsn m.nn.nx.info
else do
ox = oDsn.nDsn
call queryInfoComp aDb, k1, m.oo.ox.nm,
, m.oo.ox.info, m.nn.nx.info
end
end
end
end
if dx // 25 = 0 then
say aDb dx 'ok cUpdTst='m.o.cUpdTst,
'riSpace='m.o.cRiSpace statsInfo(o)
end
return 'cUpdTst='m.o.cUpdTst 'cRiSpace='m.o.cRiSpace statsInfo(o)
return res
endProceudre queryInfoChanged
queryInfoComp: procedure expose m.
parse arg db, k1, nm, oI, nI
ox = 1
nx = 1
do forever
cx = compare(substr(oI, ox), substr(nI, nx))
if cx = 0 | cx > length(oI) then
return
oy = lastPos(' ', oI, ox+cx-1)
ow = word(substr(oI, oy+1), 1)
ny = lastPos(' ', nI, nx+cx-1)
nw = word(substr(nI, ny+1), 1)
if (k1 = 'ip' | k1 = 'rt') & abbrev(ow, 'updTst=') ,
& abbrev(nw, 'updTst=') then
m.o.cUpdTst = m.o.cUpdTst + 1
else if k1 = 'ip' & ow == 'riSpace=---' ,
& abbrev(nw, 'riSpace=') then
m.o.cRiSpace = m.o.cRiSpace + 1
else if k1 = 'db' & substr(nw, 3, 4) == 'Dis=' ,
& nw = translate(substr(oI, ny-nx+ox+1, length(nw)),
, '+', ' ') then
nop
else if right(translate(nw), 8) == 'DIS=STOP' then
nop
else
say err 'infoChange' k1 db'.'strip(nm)':' ow '>>' nw
ox = oy + length(ow)+2
nx = ny + length(nw)+2
end
return
endProcedure queryInfoComp
dbStop: procedure expose m.
db = m.ds.1.name
o = jBuf()
call pipe '+F', o
isOk = dbOut()
call pipe '-'
if isOk then do
call jWriteNow m.outOk, o
end
else do
call jWriteNow m.outNo, o
/* return */
end
f1 = jOpen(file(m.libInfo'('db')'), '>')
call jWriteNow f1, o
call jClose f1
do tx=1 to m.ts.0
call jWrite m.outStop, '-stop db('db') space('m.ts.tx.name')'
end
call envPut 'db', db
call envPut 'dbCr', m.ds.1.creator
call pipe '+F', m.outDDL
if m.ddlStep // 50 = 0 then do
jc = substr(m.ddlJC, m.ddlJn // length(m.ddlJC) + 1, 1)
m.ddlJn = m.ddlJn + 1
call oRun compInline('jc'), jc
end
m.ddlStep = m.ddlStep + 1
call oRun compInline('genDDL')
call pipe '-'
return
endProcedure dbStop
dbCheckStopped: procedure expose m.
db = strip(m.ds.1.name)
st = dbStoppedTS(db)
if words(st) <> m.ds.1.cTs then
call err 'stopped' st 'not' m.ds.1.cTs
do wx=1 to words(st)
if wordPos(strip(m.ts.wx.name), st) < 1 then
call err m.ts.wx.name 'not in stopped' st
end
return
endProcedure dbCheckStopped
dbVsamInfo: procedure expose m.
parse arg db
msOrph = 'orph'
if symbol('m.msOrph.vsamCl') <> 'VAR' then do
m.msOrph.vsamCl = 0
m.msOrph.vsamDa = 0
m.msOrph.kind = 'orphan'
m.msOrph.nm = 'orphan'
end
lst = ''
tt = 'TP IP'
do tx=1 to words(tt)
t1 = word(tt, tx)
do qx=1 to m.t1.0
parse var m.t1.qx.vCat v1 '-' v2
if v1 <> v2 then
call err 'implement vcat' t1 qx m.t1.qx.nm m.t1.qx.vcat
if wordPos(v1, lst) < 1 then do
do lx=1 to words(lst) while v1 >> word(lst, lx)
end
lst = subword(lst, 1, lx-1) v1 subword(lst, lx)
end
m.t1.qx.vsamCl = 0
m.t1.qx.vsamDa = 0
end
end
vx = 0
do lx=1 to words(lst)
v1 = word(lst, lx)
cx = length(v1)+7
cy = length(v1)+2
dsnPrC = v1'.DSNDBC.'db
dsnPrD = overlay('D', dsnPrC, cx)
call csiOpen csC, dsnPrC, 'ENTYPE'
call csiOpen csD, dsnPrD, 'ENTYPE XHARBADS XHURBADS'
if \ csiNext(csD, fd) then
m.fd = 'eof'
do fx=0 while csiNext(csC, fc)
if m.fc.enType \== 'C' then
call err m.fc 'not cluster, entype='m.fc.entype
dw = translate(m.fc, ' ', '.')
if word(dw, 2) \= 'DSNDBC' then
call err 'not dsndbc in vsam' m.fc
if word(dw, 3) \= db then
call err 'not db' db 'in vsam' m.fc
sp = word(dw, 4)
ms = getTsIx(sp, tt, '')
if ms == '' then do
say 'vsam orphan' m.fc 'no db2 object'
m.o.orphan = m.o.orphan + 1
ms = msOrph
end
m.ms.vsamCl = m.ms.vsamCl + 1
vx = vx+1
dsd = overlay('D', m.fc, cx)
rbas=''
do while m.fd \== 'eof' & left(m.fd, length(dsd)) <<= dsd
isOrph = m.fd << dsd
if m.fd.enType \== 'D' then
call err m.fd 'not data, entype='m.fd.entype
m.o.vsamDa = m.o.vsamDa + 1
numeric digits 30
if m.fd.xHarbads \== 'ffffffffffffffff'x then do
bA = c2d(m.fd.xHaRbaDs)
m.o.haRba = m.o.haRba + bA
rbas = rbas 'hArba='bA
end
if m.fd.xHurbads \== 'ffffffffffffffff'x then do
bU = c2d(m.fd.xHuRbaDs)
m.o.huRba = m.o.huRba + bU
rbas = rbas 'hUrba='bU
end
if \ isOrph then do
m.ms.vsamDa = m.ms.vsamDa + 1
end
else do
m.msOrph.vsamDa = m.msOrph.vsamDa + 1
say 'vsamData orphan' m.fd 'no vsamCluster'
end
if \ csiNext(csD, fd) then
m.fd = 'eof'
end
if m.ms.vsamCl \== m.ms.vsamDa then do
t = m.ms.kind':' db'.'m.ms.nm 'vsam' ,
'cl' dsnPrC m.ms.vsamCl '<> da' dsnPrD m.ms.vsamDa
if ms = 'orph' then
say err t
else
call err t
end
call info 'VSAM.'vx, 'dsn', m.ms.nm m.ms.vsamCl ,
, 'dsn='m.fc m.ms.kind'='m.ms.nm || rbas
end
end
m.vsam.0 = vx
do tx=1 to words(tt)
t1 = word(tt, tx)
do qx=1 to m.t1.0
if m.t1.qx.vsamCl <= 0 then do
if m.noVsamFail then
call err 'no vsams for' qx db'.'m.t1.qx.nm
m.o.noVsam = m.o.noVsam + 1
end
else
m.o.vsamCl = m.o.vsamCl + m.t1.qx.vsamCl
end
end
return
endProcedure dbVsamInfo
insertInfo: procedure expose m.
parse arg db, tst
infos = 'DS TS TB TP RT IP VSAM'
do ix=1 to words(infos)
i1 = word(infos, ix)
do iy=1 to m.i1.0
call sqlUpdate , 'insert into' m.tb ,
'(tst,db,kind,nm,sta,info) values' ,
"('"tst"', '"db"', 'info "m.i1.iy.kind"'" ,
", '"m.i1.iy.nm"', '', '"m.i1.iy.info"')"
m.cIns = m.cIns + 1
end
end
return
endProcedure insertInfo
dbVsam: procedure expose m.
db = strip(m.ds.1.name)
lst = ''
do tx=1 to m.tp.0
parse var m.tp.tx.vCat v1 '-' v2
if v1 <> v2 then
call err 'implement vcat' m.tp.tx.vcat
if wordPos(v1, lst) < 1 then
lst = lst v1
end
call pipe '+F', m.outVsam
do lx=1 to words(lst)
v1 = word(lst, lx)
cx = length(v1)+7
cy = length(v1)+2
dsnPrC = v1'.DSNDBC.'db
dsnPrD = overlay('D', dsnPrC, cx)
call csiOpen csC, dsnPrC, 'ENTYPE'
call csiOpen csD, dsnPrD, 'ENTYPE'
call csiNext csD, fd
do fx=0 while csiNext(csC, fc)
if m.vsamC // 50 = 0 then do
call oRun compInline('jc'), 'V'
call oRun compInline('idcams')
end
m.vsamC = m.vsamC + 1
call out 'ALTER' m.fc '-'
call out ' MANAGEMENTCLASS(COM#A014) -'
call out ' NEWNAME('v1'.MIG.'substr(m.fc, cy)')'
dsd = overlay('D', m.fc, cx)
do while abbrev(m.fd, dsd)
call out 'ALTER' m.fD '-'
call out ' NEWNAME('v1'.MIG.'substr(m.fD, cy)')'
if \ csiNext(csD, fd) then
m.fd = ' eof '
end
end
end
call pipe '-'
return
endProcedure dbVsam
dbDrop: procedure expose m.
db = strip(m.ds.1.name)
lst = ''
call pipe '+F', m.outDrop
do tx=1 to m.ts.0
if m.dropTs // 100 = 0 then do
call out "select current timestamp" ,
", '"m.dropDB "DBs," m.dropTS "TSs'" ,
"from sysibm.sysdummy1; -----"
end
m.dropTs = m.dropTs + 1
call out 'xROP TABLESPACE' db'.' m.ts.tx.name'; commit;'
end
call out 'xROP DATABASE' db'; commit;'
m.dropDb = m.dropDb + 1
call pipe '-'
return
endProcedure dbDrop
dbSelect: procedure expose m.
parse arg db
if sql2St("select db.Name, db.creator, db.dbId",
", (select count(*) from sysibm.sysTableSpace ts" ,
"where db.name = ts.dbName) cTs" ,
", (select count(*) from sysibm.sysTables t" ,
"where db.name = t.dbName" ,
"and t.type not in('A', 'V')) cTb" ,
", (select count(*) from sysibm.sysIndexes i" ,
"where db.name = i.dbName) cIx" ,
"from sysibm.sysDatabase db where Name='"db"'" ,
, ds) <> 1 then
call err m.ds.0 'rows for db' db
mDS = 'DS.1'
call info mDs, 'db', ,'db='strip(m.mDS.name) ,
'ts='m.mDS.cTS "tb="m.mDS.cTB 'ix='m.mDS.cIx
if sql2St("select dbName, name, partitions, DBID, OBID, PSID",
", createdTS, alteredTS, type, nTables" ,
",pgSize, segSize, dsSize",
", case",
"when dssize <> 0 then dssize",
"when type in ('G','O','P','R','L') then 4194304",
"when partitions > 254 then 1048576*pgSize",
"when partitions > 64 then 4194304",
"when partitions > 32 then 1048576",
"when partitions > 16 then 2097152",
"when partitions > 0 then 4194304",
"else 2097152",
"end dsSz" ,
"from sysibm.sysTablespace where",
"dbName ='"db"' order by dbName, name",
, 'TS') <> m.mDs.cTs then
call err m.TS.0 'tableSpaces in' db 'not' m.mDs.cTs
m.o.cTs = m.o.cTs + m.Ts.0
m.ts.all = ''
do tsX = 1 to m.ts.0
mTS = 'TS.'tsX
nm = strip(m.mTs.name)
call info mTs, 'ts', nm ,
, 'ts='strip(m.mTS.dbName)'.'nm ,
'parts='m.mTS.partitions ,
'dbid='m.mTS.dbId 'obid='m.mTS.obid 'psid='m.mTS.psid ,
'created='m.mTS.createdTS 'altered='m.mTS.alteredTS,
'type='m.mTS.type,
'pgSize='m.mTS.pgSize 'segSize='m.mTS.segSize,
'dsSize='m.mTS.dsSize 'dsSz='m.mTS.dsSz
if wordPos(nm, m.ts.all) > 0 then
call err 'ts' nm 'already in all' m.ts.all
m.ts.all = m.ts.all nm
if wordPos(nm, m.ts.all) <> tsX then
call err 'ts' nm 'mismatch in all' m.ts.all
end
if sql2St("select creator, name, obid, colcount" ,
", createdTS, alteredTS, dbName, tsName" ,
", (select count(*) from BUA.TXBC181 b" ,
"where b.XBC181_CREATOR=tb.creator",
"and b.XBC181_tabName=tb.name) c181",
"from sysibm.sysTables tb where",
"dbName ='"db"' and type = 'T'" ,
"order by dbName, tsName, name, creator",
, 'TB') <> m.mDs.cTb then
call err m.TB.0 'tables in' db 'not' m.mDs.cTb
m.o.cTb = m.o.cTb + m.Tb.0
tsX = 0
do tbX=1 to m.tb.0
mT = 'TB.'tbX
if m.ts.tsX.name \== m.mT.tsName then do
tsX = tsX + 1
if m.ts.tsX.name \== m.mT.tsName then
call err 'ts for tb mismatch'
mTs = 'TS.'tsX
end
isTbNew = m.mT.c181 > 0
call info mT, 'tb', strip(m.mT.name),
, 'tb='strip(m.mT.creator)'.'strip(m.mT.name) ,
'ts='strip(m.mT.dbName)'.'strip(m.mT.tsName) ,
'cols='m.mT.colCount,
'obid='m.mT.obId 'tbNew='isTbNew ,
'created='m.mT.createdTS 'altered='m.mT.alteredTS
if isTbNew & m.mTs.nTables > 1 then
call warn 'new table' ,
strip(m.mT.creator)'.'strip(m.mT.name),
'with' m.mTs.nTables 'tables in ts' dbTS
if isTbNew & m.mTs.partitions <> m.mT.c181 then
call warn 'new table' ,
strip(m.mT.creator)'.'strip(m.mT.name),
'with' m.mT.c181 'tbxc181 <> parts' m.mTs.partitions
if \ isTbNew & m.mTs.partitions <> 0 then
call warn 'old table' ,
strip(m.mT.creator)'.'strip(m.mT.name),
'with' m.mTs.partitions 'partitions'
end
if tsX <> m.ts.0 then
call err 'after tb tsX='tsX 'not' m.ts.0
if sql2St("select count(*) cnt",
",strip(min(Format) || max(Format)) rowReorder",
", sum(bigint(space))*1024 space" ,
", sum(cardf) rows, sum(dsNum) dsNum" ,
", min(strip(vCatName)) || '-'" ,
" || max(strip(vCatName)) vCat",
", min(iPrefix) || '-' || max(iPrefix) iPrefix" ,
", dbName, tsName" ,
"from sysibm.sysTablePart where",
"dbName ='"db"' group by dbName, tsName" ,
"order by dbName, tsName" ,
, 'TP') <> m.mDs.cTs then
call err m.tp.0 'rows for part Sum in' db 'not' m.mDs.cTs
m.o.cTp = m.o.cTp + m.tp.0
do tpX=1 to m.tp.0
mTp = 'TP.'tpX
mTs = 'TS.'tpX
if m.mTp.dbName\==m.mTs.dbName | m.mTp.tsName\==m.mTs.name then
call err 'mismatch ts tp'
m.o.tpSpace = m.o.tpSpace + m.mTp.space
m.o.tpRows = m.o.tpRows + m.mTp.rows
call info mTp, 'tp', strip(m.mTp.tsName),
, 'tableParts='m.mTP.cnt 'rowReorder='m.mTP.rowReorder,
'space='m.mTP.space 'rows='m.mTP.rows,
'dsNum='m.mTP.dsNum 'vCat='m.mTP.vCat,
'iPrefix='m.mTP.iPrefix
end
tst0 = "'0001-01-01-00.00.00'"
if sql2St("select count(*) cnt, max(updatestatsTime) updTst" ,
", count(copyLasttime) copies" ,
", max(copyLasttime) copyLast" ,
", max(copyUpdateTime) copyUpd" ,
", max(copyUpdateLRSN) updLRSN" ,
", max(value(max(LOADRLASTTIME)," tst0")" ,
",value(max(REORGLASTTIME)," tst0")" ,
",value(max(STATSLASTTIME)," tst0")) LRS" ,
", sum(bigInt(space))*1024 space" ,
", sum(totalRows) rows" ,
", dbName, name" ,
"from sysibm.sysTableSpaceStats where",
"dbName ='"db"' and dbid = "m.mDs.dbid,
"group by dbName, name order by dbName, name",
, 'RT') <> m.mDs.cTs then
call err m.rs.0 'rows rts Sum in' db 'not' m.mDs.cTs
do rtX=1 to m.rt.0
mRt = 'RT.'rtX
if m.mRt.space \== m.sqlNull then
m.o.rtSpace = m.o.rtSpace + m.mRt.space
if m.mRt.rows \== m.sqlNull then
m.o.rtRows = m.o.rtRows + m.mRt.rows
if m.mRt.updTst >> m.o.rtUpdTst then
m.o.rtUpdTst = m.mRt.updTst
if m.mRt.copyUpd >> m.o.rtCopyUpd then
m.o.rtCopyUpd = m.mRt.copyUpd
call info mRt, 'rt', strip(m.mRt.name),
, 'copies='m.mRT.copies 'copyLast='m.mRT.copyLast ,
'copyUpdate='m.mRT.copyUpd c2x(m.mRT.updLrsn) ,
'lastLRS='m.mRT.lrs ,
'space='m.mRT.space 'rows='m.mRT.rows ,
'updTst='m.mRT.updTst
end
if sql2St("select i.creator, i.name, i.indexSpace" ,
", i.tbcreator, i.tbname" ,
", sum(ip.spaceF)*1024 space" ,
", sum(ip.cardf) card, sum(dsNum) dsNum" ,
", min(strip(vCatName)) || '-'" ,
" || max(strip(vCatName)) vCat",
", min(iPrefix) || '-' || max(iPrefix) iPrefix" ,
", count(*) cnt, max(updatestatsTime) updTst" ,
", sum(bigInt(ri.space))*1024 riSpace" ,
", sum(ri.totalEntries) entries" ,
", max(ri.lastUsed) lastUse" ,
"from sysibm.sysIndexes i" ,
"join sysibm.sysIndexPart ip" ,
"on i.creator = ip.ixCreator" ,
"and i.name = ip.ixName",
"left join sysibm.sysIndexSpaceStats ri",
"on ip.ixCreator = ri.creator" ,
"and ip.ixName = ri.name",
"and ip.partition = ri.partition" ,
"where i.dbName ='"db"' and i.dbid = "m.mDs.dbid,
"group by i.creator, i.name, i.indexSpace",
", i.tbcreator, i.tbname" ,
"order by i.indexSpace",
, 'IP') <> m.mDs.cIx then
call err m.rs.0 'rows rts Index Sum in' db 'not' m.mDs.cIx
m.ip.all = ''
m.o.cIx = m.o.cIx + m.ip.0
do ipX=1 to m.ip.0
mIP = 'IP.'ipX
nm = strip(m.mIP.indexSpace)
m.o.cIp = m.o.cIp + m.mIp.cnt
m.o.ixSpace = m.o.ixSpace + m.mIp.space
m.o.ixRows = m.o.ixRows + m.mIp.card
m.o.riSpace = m.o.riSpace + m.mIp.space
if m.mIp.entries\== m.sqlNull then
m.o.riRows = m.o.riRows + m.mIp.entries
if m.mIp.updTst >> m.o.riUpdTst then
m.o.riUpdTst = m.mIp.updTst
lu = translate('56783412', m.mIp.lastUse, '12.34.5678')
if lu >> m.o.riLastUse then
m.o.riLastUse = lu
call info mIP, 'ip', nm ,
, 'ix='strip(m.mip.creator) || '.' || strip(m.mip.name) ,
'tb='strip(m.mip.tbcreator) || '.' || strip(m.mip.tbname),
'parts='m.mip.cnt 'vcat='m.mIp.vCat 'iPrefix='m.mIp.iPrefix,
'dsnum='m.mIp.dsNum 'space='m.mIp.space ,
'card='m.mIp.card ,
'updTst='m.mIp.updTst 'lastUse='m.mIP.lastUse ,
'riSpace='m.mIp.riSpace 'entries='m.mIp.entries
if wordPos(nm, m.ip.all m.ts.all) > 0 then
call err 'ixSp' nm 'already in all' m.ip.all 'or' m.ts.all
m.ip.all = m.ip.all nm
if wordPos(nm, m.ip.all) <> ipX then
call err 'ixSp' nm 'mismatch in all' m.ip.all
end
call dbDisplay db
call dbVsamInfo db
return
endProcedure dbSelect
warn: procedure expose m.
parse arg msg
say 'warning:' msg
m.warning = m.warning + 1
return
endProcedure
info: procedure expose m.
parse arg m, m.m.kind, m.m.nm, m.m.info
/* say info m m.m.kind 'nm='m.m.nm 'info='m.m.info */
return
endProcedure info
dbOut: procedure expose m.
mDS = 'DS.1'
db = strip(m.mDS.name)
cOk = 0
cBad = 0
tbX = 1
tbO = tbX
mTP = 'TP.'tsX
if tsX > m.tp.0 | m.mTs.dbName <> m.mTp.dbName ,
| m.mTs.name <> m.mTp.tsName then
call err 'mismatch tp' m.mTp.dbName'.'m.mTp.tsName
call out ,
if \ (m.mTP.rowReorder='' | m.mTP.rowReorder='RR') then
call err 'rowReorder='m.mTP.rowReorder 'in' dbTs
mRS = 'RS.'tsX
if tsX > m.rs.0 | m.mTs.dbName <> m.mRs.dbName ,
| m.mTs.name <> m.mRs.name then
call err 'mismatch tp' m.mRs.dbName'.'m.mRs.name
if isTbNew then
cUnl = unLoadcheckNew(mRs, db, strip(m.mTs.name))
else
cUnl = unLoadcheckOld(mRs, db, strip(m.mTs.name))
call out 'unloads='cUnl
if cUnl > 0 then
cOk = cOk+1
else
cBad = cBad + 1
m.cTs = m.cTs + 1
m.cTP = m.cTP + max(1, m.mTs.partitions)
m.cTB = m.cTB + m.mTs.nTables
if m.mTp.rows \= '---' then
m.tRows = m.tRows + m.mTp.rows
if m.mTp.space \= '---' then
m.tSpace = m.tSpace + m.mTp.space
if m.mRs.rows \= '---' then
m.rRows = m.rRows + m.mRs.rows
if m.mRs.space \= '---' then
m.rSpace = m.rSpace + m.mRs.space
end
m.cDb = m.cDb + 1
if cBad = 0 & cOk = m.mDs.cTs then
call out 'dbOk='db '------------------------'
else
call out 'dbBad='db '------------------------'
return cBad = 0 & cOk = m.mDs.cTs
endProcedure dbOut
unloadCheckOld: procedure expose m.
parse arg mRs, db, ts
dsnPre = 'XB.DIV.P0.'db'.'ts
call csiOpen csi, dsnPre, 'ENTYPE DSCRDT2 MGMTCLAS VOLSER DEVTYP'
gdg = ''
cUnl = 0
do fx=0 while csiNext(csi, ff)
crD0 = c2x(m.ff.dscrdt2)
if verify(crD0, '0123456789') <= 5 then do
crDa = ''
t2 = 'creDa ?'crD0'?'
end
else do
crD1 = (19+substr(crD0, 7, 2))left(crD0, 5)
crD2 = date('s', left(crD0, 5), 'j')
if \ abbrev(crD1, left(crD2, 4)) then
call err 'century mismatch' crD0 crD1 crD2
crDa = translate('1234-56-78-', crD2, '12345678')
t2 = 'creDa' crDa
end
if crDa == '' then do
t1 = 'bad createDate'
end
else if m.ff.enType == 'B' then do
t1 = 'gdg'
if m.ff = dsnPre'.APROC' then
gdg = m.ff
else
t1 = 'bad name for' t1
end
else if abbrev(m.ff, dsnPre'.SYSREC') then do
llq = strip(substr(m.ff, length(dsnPre) + 9))
if length(llq) <> 8 then
t1 = 'bad &uniq' llq
else do
uqTst = timeLrsn2LZT(timeUniq2Lrsn(llq))
if \abbrev(uqTst, crDa) then
call err 'mismatch Unique' uqTst t2 m.ff
t2 = '&uniq' uqTst
t1 = unloadTstCheck(mRs, uqTst, 'sysrec unload')
end
end
else if \ abbrev(m.ff, gdg, 3) then do
t1 = 'not in GDG'
end
else do
t1 = unloadTstCheck(mRs, crDa, 'inGDG unload')
end
cUnl = cUnl + abbrev(t1, 'ok')
call out t1 t2 m.ff '???unl='cUnl
/* t = t ,
csiArcTape(m.ff.volser, m.ff.mgmtClas, m.ff.devtyp, m.ff)
crDa = c2x(m.ff.dscrdt2)
if verify(crDa, '0123456789') > 5 then
crDa = (19+substr(crDa, 7, 2))left(crDa, 5) ,
date('s', left(crDa, 5), 'j')
say t 'cre' crDa
say ENTYPE m.ff.entType 'crea' c2x(m.DSCRDT2) c2x(DSEXDT2)
say MGMTCLAS m.ff.mgmtclas
*/ end
return cUnl
endProcedure unloadCheckOld
unloadTstCheck: procedure expose m.
parse arg mRs, crDa, okTxt
if m.mRs.copyLast == '---' then
if m.mRs.LRS == '---' & crDa >>= '2012-09-17-' ,
& crDa << '2012-10-07-' then
return 'ok copyLast&LRS null'
else
return 'copyLast+LRS null'
else if m.mRs.copyUpd \= '---' then
if m.mRs.copyUpd << crDa then
return 'copyUpdate<' m.mRs.copyUpd '<<'
else
return 'copyUpdate>' m.mRs.copyUpd '>>='
else
if m.mRs.copyLast << crDa then
return 'ok' okTxt 'copyLast' m.mRs.copyLast '<<'
else if abbrev( m.mRs.copyLast, crDa) then
return 'ok sameDay' okTxt m.mRs.copyLast 'sameDay'
else
return 'copyLast>' m.mRs$copyLast '>>'
endProcedure unloadTstCheck
/* rexx ****************************************************************
wsh: walter's rexx shell version 2.2
interfaces:
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
--- history ------------------------------------------------------------
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
********/ /*** end of help ********************************************
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class.classO
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
call pipeIni /* without tstClass2 gives different result */
parse arg spec
isEdit = 0
if spec = '' & m.err.ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & m.editDsn = 'A540769.WK.REXX(WSH)' then
spec = 't'
end
end
if spec = '?' then
return help()
call utIni
f1 = spec
rest = ''
if pos(verify(f1, m.ut.alfNum), '1 2') > 0 then
parse var spec f1 2 rest
u1 = translate(f1)
if u1 = 'T' then
return wshTst(rest)
else if u1 = 'I' then
return wshInter(rest)
else if u1 = 'S' then
spec = '$#@ call sqlStmtsOpt $.$sqlIn,' quote(rest) '$#sqlIn#='
call wshIni
inp = ''
out = ''
if m.err.os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = s2o('-wsh')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = s2o('-out')
end
end
else if m.err.os == 'LINUX' then do
inp = s2o('&in')
out = s2o('&out')
end
else
call err 'implement wsh for os' m.err.os
m.wshInfo = 'compile'
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit 0
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
call scanWinIni
return
endProcedure wshIni
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect DBAF
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
return 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errCleanup
call errReset 'h'
call errMsg ' }'ggTxt
call mMove err, 1, 2
isScan = 0
if wordPos("pos", m.err.4) > 0 ,
& pos(" in line ", m.err.4) > 0 then do
parse var m.err.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.err.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.err.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.err.0
call out m.err.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', err)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.err.0
call jWrite m.wsh.editOut, m.err.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, err
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.err.0
say m.err.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.ut.alfLC)
c1 = substr(m.ut.alfLC, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jRead(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl, fi1)
nm = substr(m.fi1, lastPos('/', m.fi1)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
say 'tstAll ws2 25.2.13...............'
call tstBase
call tstComp
call tstDiv
if m.err.os = 'TSO' then
call tstZos
call tstTut0
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call tstTime
call sqlIni
call tstSql
call tstSqlC
call tstSqlCSV
call tstSqlQ
call tstSqlUpdComLoop
call tstSqlB
call tstSqlStmt
call tstSqlStmts
call tstSqlO1
call tstSqlO2
call tstSqls1
call tstSqlO
call tstSqlFTab
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*
$=/tstSorQ/
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSorQ/ */
/*
$=/tstSorQAscii/
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSorQAscii/ */
if m.err.os == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err.os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
$/tstMatch/ */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
Lrsn2Lzt(C5E963363741) 2010-05-01-12.34.55.789008
Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs
timeZone 7200.00000 leapSecs 25.0000000
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2Gmt(C5E963363741) 2010-05-01-10.35.20.789008
Lrsn2Lzt(C5E963363741) 2010-05-01-12.34.55.789008
gmt2Lrsn(2011-03-31-14.35.01.234567) C78D87B86E38
lzt2Lrsn(2011-03-31-14.35.01.234567) C78D6CFDD13C
Lrsn2Gmt(gmt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
gmt2Lrsn(Lrsn2Gmt(C5E963363741) C5E963363741
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
LZt2Stc(Lrsn2LZt(C5E963363741)( C5E963363741
$/tstTime/
*/
call jIni
call tst t, 'tstTime'
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out ,
'Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs'
call out 'timeZone' m.timeZone * m.timeStckUnit ,
'leapSecs' m.timeLeap * m.timeStckUnit
call timeReadCvt 1
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
call out 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
call tstEnd t
return
endProcedure tstTime
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlConnect
call jIni
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 from :src
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.sqlInd, :M.STST.B :M.STST.B.sqlInd, :M.+
STST.C :M.STST.C.sqlInd
1 all from dummy1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
sql2St 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
$/tstSql/ */
call tst t, "tstSql"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sql2St(,
"select 'a' a, 2 b, case when 1=0 then 1 else null end c",
"from sysibm.sysDummy1",
, stst) 'all from dummy1'
call out 'a='m.stst.1.a 'b='m.stst.1.b 'c='m.stst.1.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = 'select name' ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name) name" ,
substr(src,12)
call out 'sql2St' sql2St(src, st)
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call tstEnd t
return
endProcedure tstSql
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call csvIni
call sqlConnect
call tst t, "tstSqlCSV"
r = csvWrt(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
/* do rx=1 while jRead(r, vv)
call out rx'<'m.vv'>'
end
call jClose r
*/ call tstEnd t
return
endProcedure tstSqlCsv
ddlCheckExt: procedure expose m.
parse dbSys cr '.' view sels
call sqlConnect dbSys
do sx=1 to words(sels)
parse value word(sels,sx) ty ':' qu '.' nm '?' gp
if verify(qu, '_%', 'm') > 0 then
quPr = 'like' quote(qu, "'")
else
quPr = '=' quote(qu, "'")
end
call sqlDisconnect
return
endProcedure ddlCheckExt
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlPreOpen cx
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call tstEnd t
return
endProcedure tstSqlB
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 from :src
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
tstR: @tstWriteoV2 isA :SQL???class
tstR: .COL1 = erstens
tstR: .COL2 = zweitens
tstR: @tstWriteoV3 isA :TstSqlO
tstR: .FEINS = erstens
tstR: .FZWEI = zweitens
$/tstSqlO/
*/
call sqlConnect
call sqlStmt 'set current schema = A540769';
call tst t, "tstSqlO"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call classNew 'n? TstSqlO u f FEINS v, f FZWEI v'
sq2 = "select 'erstens', 'zweitens' from sysibm.sysDummy1"
call pipe '+N'
call sqlSel sq2
call pipe 'P|'
o1 = inO()
cn = className(objClass(o1))
if abbrev(cn, 'SQL') then
call mAdd t.trans, cn 'SQL???class'
call outO o1
call pipeWriteNow
call pipe '-'
call sqlSel sq2, 'TstSqlO'
call tstEnd t
return
endProcedure tstSqlO
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-XTENTS-LOADRLAST+
TIME--------------REORGLASTTIME--------------EORGINSERTS-EORGDELETE+
S-EORGUPDATES-GUNCLUSTINS-RGDISORGLOB-GMASSDELETE-GNEARINDREF-RGFAR+
INDREF-STATSLASTTIME--------------TATSINSERTS-TATSDELETES-TATSUPDAT+
ES-SMASSDELETE-COPYLASTTIME---------------PDATEDPAGES-COPYCHANGES-C+
OPYUP-COPYUPDATETIME-------------I---DBID---PSID-TITION-STANCE-SPAC+
E---TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-REORG+
SC-REORGHA-HASHLASTUS-DRI-L-STATS01----
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-XTENTS-LOADRLASTTIME--------------REORGLASTTIME----+
----------EORGINSERTS-EORGDELETES-EORGUPDATES-GUNCLUSTINS-RGDISORG+
LOB-GMASSDELETE-GNEARINDREF-RGFARINDREF-STATSLASTTIME--------------+
TATSINSERTS-TATSDELETES-TATSUPDATES-SMASSDELETE-COPYLASTTIME-------+
--------PDATEDPAGES-COPYCHANGES-COPYUP-COPYUPDATETIME-------------+
I---DBID---PSID-SPACE---TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REO+
RGHA-HASHLASTUS-DRI-L-STATS01----
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-XTENTS-LOADRLASTTIME--------------REORGLASTTIME----+
----------EORGINSERTS-EORGDELETES-EORGUPDATES-GUNCLUSTINS-RGDISORG+
LOB-GMASSDELETE-GNEARINDREF-RGFARINDREF-STATSLASTTIME--------------+
TATSINSERTS-TATSDELETES-TATSUPDATES-SMASSDELETE-COPYLASTTIME-------+
--------PDATEDPAGES-COPYCHANGES-COPYUP-COPYUPDATETIME-------------+
I---DBID---PSID-SPACE---TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-REO+
RGHA-HASHLASTUS-DRI-L-STATS01----
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REORGSC+
ANACCESS DRIVETYPE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASIZE +
. REORGHASHACCESS LPFACILITY
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTERSEN+
S HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlPreOpen 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabReset abc, 17, 1, , 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabOthers abc
call sqlfTab abc
call sqlClose 17
call out '--- modified'
call sqlopen 17
call sqlFTabReset abc, 17, 2 1, 1 3 'c', 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabAdd abc, DBNAME, '%-8C', 'db', 'allg vorher' ,
, 'allg nachher'
call sqlFTabAdd abc, NAME , '%-8C', 'ts'
call sqlFTabAdd abc, PARTITION , , 'part'
call sqlFTabAdd abc, INSTANCE , , 'inst'
call fTabAddTit abc, 2, 'others vorher'
call fTabAddTit abc, 3, 'others nachher'
call sqlFTabOthers abc
call sqlFTab abc
call sqlClose 17
call tstEnd t
return
endProcedure tstSqlFTab
tstSqlC: procedure expose m.
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s9 into :M.SQL.9.D from :src
. e 7: with into :M.SQL.9.D = M.SQL.9.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s9 into :M.SQL.9.D from :src
. e 3: with into :M.SQL.9.D = M.SQL.9.D
sys ==> server CHSKA000DBAF .
fetched a1=abc, i2=12, c3=---
. I1 C2 .
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: subsys = DD0G, host = RZ8, interfaceType Csm
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: subsys = DD0G, host = RZ8, interfaceType Csm
sys rz8/DD0G ==> server CHROI000DD0G .
fetched a1=abc, i2=12, c3=---
. I1 C2 .
. 1 eins
2222 zwei
$/tstSqlCCsm/ */
sqlBuf = jBuf("select 1 i1, 'eins' c2 from sysibm.sysDummy1",
, "union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1")
do tx=1 to 2
if tx = 1 then do
call tst t, "tstSqlCRx"
sys = ''
call sqlConnect
end
else do
call tst t, "tstSqlCCsm"
sys = 'rz8/DD0G'
end
call sqlConnect sys
cx = 9
call sqlQuery cx, 'select * from sysibm?sysDummy1'
call sqlQuery cx, 'select * from nonono.sysDummy1'
call sqlQuery cx, "select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"
do while sqlFetch(cx, dst)
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call fmtFTab , sqlRdr(sqlBuf)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlQ: procedure expose m.
/*
$=/tstSqlQ/
### start tst tstSqlQ #############################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlQ/ */
call tst t, "tstSqlQ"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call tstEnd t
return
endProcedure tstSqlQ
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
T
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call tst t, "tstSqlUpdComLoop"
call sqlConnect
call out sqlStmt("declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows")
call out sqlStmt("insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only")
call out sqlStmt("select count(*) cnt from session.dgtt")
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call out sqlStmt("select count(*) cnt from session.dgtt")
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call sqlConnect
call tst t, "tstSqlO1"
sq = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen sq, m.j.cRead
do while assNN('ABC', jReadO(sq))
if m.sq.rowCount = 1 then do
cx = m.sq.cursor
call mAdd t.trans, className(m.sql.cx.type) '<tstSqlO1Type>'
end
call outO abc
end
call jClose sq
call out '--- writeAll'
call pipeWriteAll sq
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlConnect
call tst t, "tstSqlO2"
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fmtFTab abc
call pipe '-'
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlOIni
call tst t, "tstSqlS1"
call sqlConnect dbaf
s1 = fileSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, fileSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :ggSrc
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: select current schema c from sysDummy1
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: (select current schema c from sysDummy1)
$/tstSqlStmt/ */
call sqlConnect
call tst t, "tstSqlStmt"
cn = className(classNew('n* SQL u f C v'))
call mAdd t.trans, cn '<sql?sc>'
call tstOut t, sqlStmt("set current schema = 'sysibm'")
call tstOut t, sqlStmt(" set current schema = sysibm ")
call tstOut t, sqlStmt(" select current schema c from sysDummy1",
, ,'o')
call tstOut t, sqlStmt(" (select current schema c from sysDummy1)",
, ,'o')
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
C
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
C
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
sqlCode 0: set current schema = s100447
#jIn eof 3#
$/tstSqlStmts/ */
call sqlConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b, , '-sql72'
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call tstEnd t
return
endProcedure tstSqlStmts
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompStmtA
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
$/tstCompPrimary/ */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.-{"abc"}=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.-{""abc""}="$.-{"abc"}'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*
$=/tstCompExprCon/
$/tstCompExprCon/ */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompStmtA: procedure expose m.
call pipeIni
/*
$=/tstCompStmtAssAtt/
### start tst tstCompStmtAssAtt ###################################
compile @, 19 lines: call tstCompStmtAA "begin", "tstAssAtt"
run without input
begin tstAssAtt F1=F1val1 F2= F3= FR=
gugus1
ass1 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=
ass2 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=<oAAR2>
ass2 tstAssAr2 F1=FRF1ass2 F2= F3= FR=
gugus3
ass3 tstAssAtt F1=F1val1 F2=F2ass3 F3=F3ass1 FR=<oAAR2>
ass3 tstAssAr2 F1=FRF1ass2 F2=FrF2ass3 F3= FR=<oAAR3>
ass3 tstAssAr3 F1=r2F1as3 F2=r2F2as3 F3= FR=
*** err: no field falsch in class tstAssAtt in EnvPut(falsch, +
falsch, 1)
$/tstCompStmtAssAtt/
*/
call classNew 'n? tstAssAtt u f F1 v, f F2 v,' ,
'f F3 v, f FR r tstAssAtt'
call envPutO 'tstAssAtt', oNew('tstAssAtt')
call envPut 'tstAssAtt.F1', 'F1val1'
call tstComp1 '@ tstCompStmtAssAtt',
, 'call tstCompStmtAA "begin", "tstAssAtt"',
, '$=tstAssAtt=:¢F2=F2ass1 $$gugus1',
, 'F3=F3ass1',
, '!',
, 'call tstCompStmtAA "ass1", "tstAssAtt"',
, '$=tstAssAtt.FR.F1 = FRF1ass2',
, '$=tstAssAr2 =. ${tstAssAtt.FR}',
, 'call mAdd T.trans, $.$tstAssAr2 "<oAAR2>"',
, 'call tstCompStmtAA "ass2", "tstAssAtt"',
';call tstCompStmtAA "ass2", "tstAssAr2"',
, '$=tstAssAtt=:¢F2=F2ass3 $$gugus3',
, ':/FR/ F2= FrF2ass3',
, 'FR=:¢F1=r2F1as3',
, 'F2=r2F2as3',
, ' * blabla $$ sdf',
, '!',
, '/FR/ !',
, '$=tstAssAr3 =. ${tstAssAtt.FR.FR}',
, 'call mAdd T.trans, $.$tstAssAr3 "<oAAR3>";',
'call tstCompStmtAA "ass3", "tstAssAtt";',
'call tstCompStmtAA "ass3", "tstAssAr2";',
'call tstCompStmtAA "ass3", "tstAssAr3"',
, '$=tstAssAtt=:¢falsch=falsch$!'
/*
$=/tstCompStmtAsSuTy/
### start tst tstCompStmtAsSuTy ###################################
compile @, 4 lines: call tstCompStmtA2 "begin", "tstAsSuTy"
run without input
begin tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GTF1ini1 F2= F3= FR=
as2 tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GtF1ass2 F2=F2ass2 F3= FR=
$/tstCompStmtAsSuTy/
*/
call classNew 'n? tstAsSuTy u f G1 v, f GT tstAssAtt'
call envPutO 'tstAsSuTy', oNew('tstAsSuTy')
call envPut 'tstAsSuTy.G1', 'G1ini1'
call envPut 'tstAsSuTy.GT.F1', 'GTF1ini1'
call tstComp1 '@ tstCompStmtAsSuTy',
, 'call tstCompStmtA2 "begin", "tstAsSuTy"',
, '$=tstAsSuTy.GT =:¢F1= GtF1ass2',
, 'F2= F2ass2 $!',
, 'call tstCompStmtA2 "as2", "tstAsSuTy"'
/*
$=/tstCompStmtAssSt/
### start tst tstCompStmtAssSt ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSt H1=H1ass2 HS.0=1 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSt/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', oNew('tstAssSt')
call oClaClear class4Name('tstAssAtt'), envGetO('tstAssSt')'.HS.1'
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSt', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass2',
, 'HS =<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"',
, ''
/*
$=/tstCompStmtAssSR/
### start tst tstCompStmtAssSR ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASR>.HS class <clSR??> in EnvPut(ts+
tAssSR.HS.1.F1, HS.1.ini0, )
begin tstAssSR H1=H1ini1 HS.0=1 .
_..1 tstAssSR. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSR H1=H1ass2 HS.0=1 .
_..1 tstAssSR. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSR H1=H1ass3 HS.0=3 .
_..1 tstAssSR. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSR. F1= F2= F3= FR=
_..3 tstAssSR. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSR/
*/
cl = classNew('n? tstAssSR u f H1 v, f HS s r tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSR', oNew('tstAssSR')
call oClaClear class4Name('tstAssAtt'), envGetO('tstAssSR')'.HS.1'
call envPut 'tstAssSR.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSR', '',
, "call mAdd t.trans, $.$tstAssSR '<oASR>'",
", m.tstCl '<clSR??>'",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSR.HS.0', 1",
";call envPutO 'tstAssSR.HS.1', ''",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass2',
, 'HS =<<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, ';call tstCompStmtSt "ass2", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSR"',
, ''
/*
$=/tstCompStmtassTb/
### start tst tstCompStmtassTb ####################################
compile @, 19 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
tstR: @tstWriteoV4 isA :<assCla H1>
tstR: .H1 = H1ass2
ass2 tstAssSt H1=H1ini1 HS.0=2 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
_..2 tstAssSt. F1= F2=h3+f2as2 F3=h3+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=f3as3 FR=
$/tstCompStmtassTb/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', oNew('tstAssSt')
call oClaClear class4Name('tstAssAtt'), envGetO('tstAssSt')'.HS.1'
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtassTb', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢ $@|¢ H1 ',
, ' H1ass2 ',
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<assCla H1>'} $!",
, 'HS =<|¢ $*(...',
, '..$*) F2 F3 ',
, ' hs+f2as2 hs+f3as2 ' ,
, ' * kommentaerliiii ' ,
, ' ' ,
, ' h3+f2as2 h3+f3as22222$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
'$=tstAssSt =:¢H1= H1ass3',
, 'HS =<|¢F2 F3',
, ' f2as3' ,
, ' ',
, ' $""',
, ' f3as3 $! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"'
/*
$=/tstCompStmtassInp/
### start tst tstCompStmtassInp ###################################
compile @, 11 lines: .
run without input
tstR: @tstWriteoV2 isA :<cla123>
tstR: .eins = l1v1
tstR: .zwei = l1v2
tstR: .drei = l1v3
tstR: @tstWriteoV3 isA :<cla123>
tstR: .eins = l2v1
tstR: .zwei = l2v2
tstR: .drei = l21v3
*** err: undefined variable oo in envGetO(oo)
oo before 0
oo nachher <oo>
tstR: @tstWriteoV5 isA :<cla123>
tstR: .eins = o1v1
tstR: .zwei = o1v2
tstR: .drei = o1v3
$/tstCompStmtassInp/
*/
call envRemove 'oo'
call tstComp1 '@ tstCompStmtassInp', '',
, "$@|¢eins zwei drei ",
, " l1v1 l1v2 l1v3",
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<cla123>'}" ,
, " l2v1 l2v2 l21v3",
, "!",
, "$$ oo before $.$oo",
, "$; $>.$oo $@|¢eins zwei drei",
, " o1v1 o1v2 o1v3 $!",
, "$; call mAdd 'T.TRANS', $.$oo '<oo>'",
, "$; $$ oo nachher $.$oo $@$oo"
return
endProcedure tstCompStmtA
tstCompStmtAA: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'F1='left(envGet(ggN'.F1'), 8),
'F2='left(envGet(ggN'.F2'), 8),
'F3='left(envGet(ggN'.F3'), 8),
'FR='envGetO(ggN'.FR')
return
endSubroutine
tstCompStmtA2: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'G1='left(envGet(ggN'.G1'), 8)
call tstCompStmtAA '_..GT', ggN'.GT'
return
endSubroutine
tstCompStmtSt: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'H1='left(envGet(ggN'.H1'), 8),
'HS.0='left(envGet(ggN'.HS.0'), 8)
do sx=1 to envGet(ggN'.HS.0')
call tstCompStmtAA '_..'sx, ggN'.HS.'sx
end
return
endSubroutine tstCompStmtSt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 17 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@|
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
*** err: scanErr comp2code bad fr | to | for @|| .
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@|'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<={ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith with $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun()
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call envPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun()', '$@oRun-{}' ,
, ' $@oRun-{$"-{1 arg only}" ''oder?''}' ,
, ' $@oRun.{$".{1 obj only}" ''oder?''} $=v2=zwei' ,
, ' $@oRun-{$"{2 args}", "und" $v2"?"}' ,
, ' $@oRun-{$"{3 args}", $v2, "und drei?"}'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+ abc
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@.<$dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $>.$eins $@for vv $$ <$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>.$eins $@for vv $$ <$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.$eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
$/tstCompDirSrc/ */
/*
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
$/tstCompDir/ */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@pi2()
$#pi2#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#=, 6 lines: +
zeile 1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#="
return
endProcedure tstCompDir
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fmtFTab abc
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
*/
call sqlConnect
call tstComp2 'tstCompSql', '@'
return
endProcedure tstCompFile
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DBAF
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* -{sysvar(sysnode) date() time()} ts=$ts 10*len=$-{length($ts) * 10}
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out 20130902 15:39:36
??* -{sysvar(sysnode) date() time()} ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DBAF,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$#out 20130224 11:48:24
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* -{sysvar(sysnode) date() time()} ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DBAF,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DBAF
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out 20101229 13
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DBAF
$@|¢
db ts
DGDB9998 A976
DA540769 A977
!
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DBAF
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out 20101229
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#@
$=subsys = dbaf
$=lst=<:¢
db = DGDB9998
ts =<|¢
ts
A976
A977
!;
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out 201012
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dbtf
$@|¢ ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fmtFtab
$|
$=jx=0
$@forWith t $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect dbaf
$#out 20101231 11:56:23
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 46 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlOIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
call tstComp2 'tstTut04'
call tstComp2 'tstTut05'
call tstComp2 'tstTut07'
call tstTotal
return
endProcedure tstTut0
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call scanIni
call tstO
call tstM
call classIni
call tstMCat
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstOEins
call tstOGet
call jIni
call tstJSay
call tstJ
call tstJ2
call tstJCatSql
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstEnvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile
call tstFileList
call tstF
call tstFTab
call tstFmt
call tstFmtUnits
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMCat: procedure expose m.
/*
$=/tstMCat/
### start tst tstMCat #############################################
mCat(0, ) =;
mCat(0, %qn1%s) =;
mCat(0, %qn112222%s%qe%s11) =;
mCat(0, 1%s%qn231%s%qe%s2) =;
mCat(0, 1%s2@%s%qn33341%s2@%s%=;
mCat(0, 1%s2@%s3@%s%qn451%s2@%=;
mCat(1, ) =eins;
mCat(1, %qn1%s) =eins;
mCat(1, %qn112222%s%qe%s11) =eins11;
mCat(1, 1%s%qn231%s%qe%s2) =1eins2;
mCat(1, 1%s2@%s%qn33341%s2@%s%=1eins2eins333;
mCat(1, 1%s2@%s3@%s%qn451%s2@%=1eins2eins3eins4;
mCat(2, ) =einszwei;
mCat(2, %qn1%s) =eins1zwei;
mCat(2, %qn112222%s%qe%s11) =eins112222zwei11;
mCat(2, 1%s%qn231%s%qe%s2) =1eins231zwei2;
mCat(2, 1%s2@%s%qn33341%s2@%s%=1eins2eins33341zwei2zwei333;
mCat(2, 1%s2@%s3@%s%qn451%s2@%=1eins2eins3eins451zwei2zwei3zwei4;
mCat(3, ) =einszweidrei;
mCat(3, %qn1%s) =eins1zwei1drei;
mCat(3, %qn112222%s%qe%s11) =eins112222zwei112222drei11;
mCat(3, 1%s%qn231%s%qe%s2) =1eins231zwei231drei2;
mCat(3, 1%s2@%s%qn33341%s2@%s%=1eins2eins33341zwei2zwei33341drei2dr+
ei333;
mCat(3, 1%s2@%s3@%s%qn451%s2@%=1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstMCat/ */
call mIni
call tst t, "tstMCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstMCat1 qx
call tstMCat1 qx, '%qn1%s'
call tstMCat1 qx, '%qn112222%s%qe%s11'
call tstMCat1 qx, '1%s%qn231%s%qe%s2'
call tstMCat1 qx, '1%s2@%s%qn33341%s2@%s%qe333'
call tstMCat1 qx, '1%s2@%s3@%s%qn451%s2@%s3@%s%qe4'
end
call tstEnd t
return
endProcedure tstMCat
tstMCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("mCat("m.qq.0"," fmt")", 30)"="mCat(qq, fmt)";"
return
endProcedure tstMCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2o2/
### start tst tstClass2 ###########################################
@CLASS.5 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice v union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .2 refTo @CLASS.6 :class = c
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.7 :class = u
. choice u stem 0
. .3 refTo @CLASS.8 :class = c
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.9 :class = c
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .5 refTo @CLASS.10 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.12 :class = r
. choice r .CLASS refTo @CLASS.5 done :class @CLASS.5
. .6 refTo @CLASS.13 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .7 refTo @CLASS.14 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.16 :class = c
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.15 done :class @CLASS.15
. .9 refTo @CLASS.19 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.20 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.11 done :class @CLASS.11
. .10 refTo @CLASS.21 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.20 done :class @CLASS.20
. .11 refTo @CLASS.22 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.23 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.24 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
$/tstClass2o2/
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.108 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2/ */
call classIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: bad type v: classBasicNew(v, tstClassTf12, )
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.3
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.3
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: bad type v:' ,
'classBasicNew(v, tstClassTf12, )'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class.classV m.class.classW m.class.classO) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'m.t.class)
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
oIsCla(TstOCla1) 0
TstOCla1 -
oIsCla(TstOCla1) 1
TstOCla1 -
oIsCla(TstOCla1) 1
TstOCla1 contents of met1
TstOCla1.met2 -
TstOCla2.met1 contents of met1
TstOCla2.met2 contents of met2
TstOCla1.TstOMet3 -
TstOCla1.TstOMet3 generated met TstOCla1:TstOMet3 code...;
TstOCla2.TstOMet3 generated met TstOCla2:TstOMet3 code...;
tstOObj1.met1 -
tstOObj1.met1 contents of met1
$/tstO/
*/
call mIni
call tst t, 'tstO'
call oIni
c1 = 'TstOCla1'
c2 = 'TstOCla2'
m1 = 'met1'
m2 = 'met2'
m3 = 'TstOMet3'
lg = m.o.lazyGen
call tstOut t, 'oIsCla('c1')' oIsCla(c1)
call tstOut t, c1 oClaMet(c1, 'met1', '-')
call oAddCla c1
call tstOut t, 'oIsCla('c1')' oIsCla(c1)
call tstOut t, c1 oClaMet(c1, 'met1', '-')
call oAddMet c1, m1, 'contents of met1'
call tstOut t, 'oIsCla('c1')' oIsCla(c1)
call tstOut t, c1 oClaMet(c1, m1, '-')
call oAddCla c2, c1
call oAddMet c2, 'met2', 'contents of met2'
call tstOut t, c1'.met2' oClaMet(c1, 'met2', '-')
call tstOut t, c2'.'m1 oClaMet(c2, m1, '-')
call tstOut t, c2'.met2' oClaMet(c2, 'met2', '-')
call tstOut t, c1'.'m3 oClaMet(c1, m3, '-')
call oAddMet lg, m3,
, "return 'generated met' cl':'me 'code...;'"
call tstOut t, c1'.'m3 oClaMet(c1, m3, '-')
call tstOut t, c2'.'m3 oClaMet(c2, m3, '-')
o1 = 'tstOObj1'
o2 = 'tstOObj2'
call tstOut t, o1'.met1' objMet(o1, 'met1', '-')
call oMutate o1, c1
call tstOut t, o1'.met1' objMet(o1, 'met1', '-')
call tstEnd t
drop m.o.cParent.c1 m.o.cMet.c1.m1 m.o.cMet.c1.m2 m.o.cMet.c1.m3
drop m.o.cParent.c2 m.o.cMet.c2.m1 m.o.cMet.c2.m2 m.o.cMet.c2.m3
drop m.o.o2c.o1 m.o.cMet.lg.m3
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :CLASS.3
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call classIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret oClaMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'FLDS of' e mCat(oFlds(e), '%qn, %s')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret oClaMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), '%qn, %s')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
/* call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), '%qn, %s')
*/
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOGet: procedure expose m.
/*
$=/tstOGet/
### start tst tstOGet #############################################
class.NAME= class
class.NAME= class : w
class| = u
*** err: bad stem index 91>7 @ CLASS.4 class class in oGet(CLASS.4,+
. 91)
class.91 = 0
class.1 = CLASS.1 |= u
class.2 = CLASS.5 |= c
$/tstOGet/ */
call oIni
call tst t, 'tstOGet'
cc = m.class.class
call tstOut t, 'class.NAME=' oGet(cc, 'NAME')
o = oGetO(cc, 'NAME')
call tstOut t, 'class.NAME=' o2String(o) ':' className(objClass(o))
call tstOut t, 'class| =' oGet(cc, '|')
call tstOut t, 'class.91 =' className(oGet(cc, 91))
call tstOut t, 'class.1 =' oGetO(cc, '1') '|=' oGet(cc, '1||')
call tstOut t, 'class.2 =' className(oGetO(cc, '2')) ,
'|=' oGet(cc, '2||')
call tstEnd t
/*
$=/tstOGet2/
### start tst tstOGet2 ############################################
tstOGet1 get1 w
tstOGet1.f1 get1.f1 v
tstOGet1.f2 get1.f2 w
tstOGet1.F3| get1.f3 v
tstOGet1.f3.fEins get1.f3.fEins v
tstOGet1.f3.fZwei get1.f3.fZwei w
tstOGet1.f3%fDrei !get1.f3.fDrei w
tstOGet1.f3.fDrei get1.f3.fDrei w
tstOGet1.f3%1 get1.f3.fDrei.1 w
tstOGet1.f3.2 TSTOGET1
tstOGet1.f3.2|f1 get1.f1 v
tstOGet1.f3.2|f3.2|f2 get1.f2 w
*** err: bad stem index 4>3 @ TSTOGET1.F3 class TstOGet0 in oGet(TS+
TOGET1, F3.4)
tstOGet1.f3.4 0
tstOGet1.f3.3 get1.f3.fDrei.3 w
*** err: bad stem index 3>3A @ TSTOGET1.F3 class TstOGet0 in oGet(T+
STOGET1, F3.3)
tstOGet1.f3.2 0
$/tstOGet2/
*/
c0 = classNew('n? TstOGet0 u f FEINS v,f FZWEI w,f FDREI r,v,' ,
's r TstOGet0')
cl = classNew('n? TstOGet u r, f F1 v, f F2 r, f F3 TstOGet0')
call oMutate tstOGet1, cl
m.tstOGet1 = s2o('get1 w')
m.tstOGet1.f1 = 'get1.f1 v'
m.tstOGet1.f2 = s2o('get1.f2 w')
m.tstOGet1.f3 = 'get1.f3 v'
m.tstOGet1.f3.fEins = 'get1.f3.fEins v'
m.tstOGet1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstOGet1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstOGet1.f3.0 = 3
m.tstOGet1.f3.1 = s2o('get1.f3.fDrei.1 w')
m.tstOGet1.f3.2 = tstOGet1
m.tstOGet1.f3.3 = s2o('get1.f3.fDrei.3 w')
call tst t, 'tstOGet2'
call tstOut t, 'tstOGet1 ' oGet(tstOGet1, )
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call tstOut t, 'tstOGet1.f2 ' oGet(tstOGet1, f2)
call tstOut t, 'tstOGet1.F3| ' oGet(tstOGet1, 'F3|')
call tstOut t, 'tstOGet1.f3.fEins ' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3.fZwei ' oGet(tstOGet1, f3.fZwei)
call tstOut t, 'tstOGet1.f3%fDrei ' oGetO(tstOGet1, 'F3%FDREI')
call tstOut t, 'tstOGet1.f3.fDrei ' oGet(tstOGet1, f3.fDrei)
call tstOut t, 'tstOGet1.f3%1 ' oGet(tstOGet1, 'F3%1')
call tstOut t, 'tstOGet1.f3.2 ' oGetO(tstOGet1, 'F3.2')
call tstOut t, 'tstOGet1.f3.2|f1 ' oGet(tstOGet1, 'F3.2|F1')
call tstOut t, 'tstOGet1.f3.2|f3.2|f2' ,
oGet(tstOGet1, 'F3.2|F3.2|F2')
call tstOut t, 'tstOGet1.f3.4 ' oGet(tstOGet1, 'F3.4')
call tstOut t, 'tstOGet1.f3.3 ' oGet(tstOGet1, 'F3.3')
m.tstOGet1.f3.0 = 3a
call tstOut t, 'tstOGet1.f3.2 ' oGet(tstOGet1, 'F3.3')
call tstEnd t
/*
$=/tstOPut3/
### start tst tstOPut3 ############################################
tstOGet1.f1 get1.f1 v
tstOGet1.f1 aPut1 f1.put1
tstOGet1.f2 aPut2 f2.put2
tstOGet1.f3.fEins p3 f3.fEins,p3
tstOGet1.f3%0 3A
tstOGet1.f3%0 =4 4
tstOGet1.f3.4.feins val f3.4|feins
$/tstOPut3/
*/
call tst t, 'tstOPut3'
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call oPut tstOget1, f1, 'f1.put1'
call tstOut t, 'tstOGet1.f1 aPut1' oGet(tstOGet1, f1)
call oPut tstOget1, f2, 'f2.put2'
call tstOut t, 'tstOGet1.f2 aPut2' oGet(tstOGet1, f2)
call oPut tstOget1, f3.fEins, 'f3.fEins,p3'
call tstOut t, 'tstOGet1.f3.fEins p3' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3%0 ' oGet(tstOGet1, 'F3%0')
call oPut tstOget1, f3.0, 4
call tstOut t, 'tstOGet1.f3%0 =4' oGet(tstOGet1, 'F3%0')
call oPutO tstOget1, 'F3.4', ''
call oPut tstOget1, 'F3.4|FEINS', 'val f3.4|feins'
call tstOut t, 'tstOGet1.f3.4.feins' ,
oGet(tstOGet1, 'F3.4|FEINS')
call tstEnd t
return
endProcedure tstOGet
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay.jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while assNN('res', jReadO(b))
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while assNN('ccc', jReadO(c))
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Af', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 's',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
$/tstEnvVars/ */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
call pipe '+F' , envGetO('theBuf', '-b')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, envGetO('theBuf')
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvVars
tstEnvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1| get1 w
tstK1%f1 get1.f1 v
tstK1.f2 get1.f2 w
tstK1%F3 get1.f3 v
ttstK1.F3.FEINS get1.f3.fEins v
tstK1%F3%FZWEI get1.f3.fZwei w
tstK1.F3.FDREI !get1.f3.fDrei w
tstK1%F3%FDREI| get1.f3.fDrei w
tstK1.F3.1 get1.f3.1 w
tstK1%F3%2 TSTEW1
tstK1.F3.2|F1 get1.f1 v
tstK1%F3%2|F3.2|F2 get1.f2 w
*** err: undefined variable F1 in envGet(F1)
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3%FDREI !get1.f3.fDrei w
F3%FDREI| get1.f3.fDrei w
F3%1 get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined variable F1 in envGet(F1)
po-1 F1 0
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call envPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1| ' envGet('tstK1|')
call tstOut t, 'tstK1%f1 ' envGet('tstK1%F1')
call tstOut t, 'tstK1.f2 ' envGet('tstK1.F2')
call tstOut t, 'tstK1%F3 ' envGet('tstK1%F3|')
call tstOut t, 'ttstK1.F3.FEINS ' envGet('tstK1.F3.FEINS')
call tstOut t, 'tstK1%F3%FZWEI ' envGet('tstK1%F3%FZWEI')
call tstOut t, 'tstK1.F3.FDREI ' envGetO('tstK1.F3.FDREI')
call tstOut t, 'tstK1%F3%FDREI| ' envGet('tstK1%F3%FDREI')
call tstOut t, 'tstK1.F3.1 ' envGet('tstK1.F3.1')
call tstOut t, 'tstK1%F3%2 ' envGetO('tstK1%F3%2')
call tstOut t, 'tstK1.F3.2|F1 ' envGet('tstK1.F3.2|F1')
call tstOut t, 'tstK1%F3%2|F3.2|F2' ,
envGet('tstK1%F3%2|F3%2|F2')
call tstOut t, 'F1 ' envGet('F1')
call envPushWith tstEW1
call tstOut t, 'F1 ' envGet('F1')
call tstOut t, 'f2 ' envGet('F2')
call tstOut t, 'F3 ' envGet('F3|')
call tstOut t, 'F3.FEINS ' envGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' envGet('F3.FZWEI')
call tstOut t, 'F3%FDREI ' envGetO('F3%FDREI')
call tstOut t, 'F3%FDREI| ' envGet('F3%FDREI|')
call tstOut t, 'F3%1 ' envGet('F3%1')
call tstOut t, 'pu1 F1 ' envGet('F1')
call envPushWith tstEW2
call tstOut t, 'pu2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-1 F1 ' envGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3.F1 = v(c3.f1)
*** err: no reference @ <c3>.F1 class CLASS.1 in envGet(c3.F1.FEINS+
)
. s c3.F1.FEINS = 0
. s c3.F3.FEINS = .
. s c3.F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS @ <c3> class TstEW in envGet(c3.FEINS)
. s c3.FEINS = 0
*** err: null @ <c3> class TstEW in envGet(c3|FEINS)
. s c3|FEINS = 0
aft Put s c3|FEINS = val(c3|FEINS)
Push c3 s F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS aftPuP= pushPut(F3 @ <c3>.F3 class TstEW0 i+
n envGet(F3.FEINS aftPuP= pushPut(F3.FEINS))
. s F3.FEINS aftPuP= 0
push c4 s F1 = v(c4.f1)
put f2 s F2 = put(f2)
*** err: no field F222 in class TstEW in EnvPut(F222, f222 stopped,+
. 1)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3.f1)
*** err: undefined variable F1 in envGet(F1)
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3.f1)'
call envPutO 'c3', c3
call tstEnvSG , 'c3.F1'
call tstEnvSG , 'c3.F1.FEINS'
call tstEnvSG , 'c3.F3.FEINS'
call envPut 'c3.F3.FEINS', 'val(c3.F3.FEINS)'
call tstEnvSG , 'c3.F3.FEINS'
call tstEnvSG , 'c3.FEINS'
call tstEnvSG , 'c3|FEINS'
call envPut 'c3|FEINS', 'val(c3|FEINS)'
call tstEnvSG 'aft Put', 'c3|FEINS'
call envPushWith c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call envPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG , 'F3.FEINS aftPuP=' envGet('F3.FEINS')
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4.f1)'
call envPut f222, 'f222 no stop'
call envPushWith c4
call tstEnvSG 'push c4', f1
call envPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call envPut f222, 'f222 stopped', 1
call envPut f3.fEins, 'put(f3.fEins)'
call tstEnvSG 'put .. ', f3.fEins
call envPopWith
call tstEnvSG 'popW c4', f1
call envPopWith
call envPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
/*
$=/tstEW4/
### start tst tstEW4 ##############################################
tstO4 S.0 0 R.0 0 class TstEW4
*** err: no field FZWEI in class in EnvPut(FZWEI, v 1.fZwei, 1)
1 fEins s FEINS = v 1.fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1.fEins .# 1 vor
v 1.fEins .# 2 nach withNext e
*** err: undefined variable FEINS in envGet(FEINS)
? fEins s FEINS = 0
1 fEins s FEINS = v 1|fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1|fEins .# 2
$/tstEW4/
*/
c4 = classNew('n? TstEW4 u f S s TstEW0, f R s r TstEW0')
o4 = oClear(oMutate('tstO4', c4))
call tst t, 'tstEW4'
call tstout t, o4 'S.0' m.o4.s.0 'R.0' m.o4.r.0 ,
'class' className(objClass(o4))
call envPushWith o4'.S', m.c4.f2c.s, 'asM'
call envPut fZwei, 'v 1.fZwei', 1
call envWithNext 'b'
call envPut feins, 'v 1.fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
m.o4.s.2.feins = 'vorher'
m.o4.s.2.fZwei = s2o('vorher')
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'vor'
call envWithNext 'e'
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'nach withNext e'
call envPopWith
call tstEnvSG '? fEins ', fEins
call envPushWith o4'.R', m.c4.f2c.r, 'asM'
call envWithNext 'b'
call envPut fEins, 'v 1|fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call envWithNext 'e'
call envPopWith
o41r = m.o4.r.1
call tstOut t, m.o41r.fEins '.#' m.o4.r.0
call tstEnd t
return
endProcedure tstEnvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' envGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then do
ty = classNew('n TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
end
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr";' ,
'return jRead(m.m.rdr, var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+f', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err.os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err.os = 'TSO' then
return pds'('mbr') ::F'
if m.err.os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err.os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err.os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1\s23%s345%s67\%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%s345%S67\%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1\s23%s345%s67\%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\s23%s345%S67\%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%s3@2%S4@%s5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%s2@f2%s3@F3%s4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5i @%8i @%+8i @%-8i -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan Text? gerText? gerText? undEinLa
tstF2 _ %-9C @%5.2i @%12.2i @%+12.2i @%-12.2i -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan Text? nLangerText? nLangerText? undEinLanger
tstF2 _ %-9C @%7e @%8E @%9.2e @%11.3E -----
_ 0 0.00e00 0.00E00 0.00e+00 0.000E+000
_ -1.2 -1.2e00 -1.20E00 -1.20e+00 -1.200E+000
_ 2.34 2.34e00 2.34E00 2.34e+00 2.340E+000
_ -34.8765 -3.5e01 -3.49E01 -3.49e+01 -3.488E+001
_ 567.91234 5.68e02 5.68E02 5.68e+02 5.679E+002
_ -8901 -8.9e03 -8.90E03 -8.90e+03 -8.901E+003
_ 23456 2.35e04 2.35E04 2.35e+04 2.346E+004
_ -789012 -7.9e05 -7.89E05 -7.89e+05 -7.890E+005
_ 34e6 3.40e07 3.40E07 3.40e+07 3.400E+007
_ -56e7 -5.6e08 -5.60E08 -5.60e+08 -5.600E+008
_ 89e8 8.90e09 8.90E09 8.90e+09 8.900E+009
_ txtli txtli txtli txtli txtli .
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.76e-07 8.760E-007
_ 5.43e-11 0.05e-9 0.05E-9 5.43e-11 5.430E-011
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.76e-07 -8.760E-007
_ -5.43e-11 -0.1e-9 -0.05E-9 -5.43e-11 -5.430E-011
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1\s23%s345%s67\%8'
call tstF1 '1\S23%s345%S67\%8'
call tstF1 '1\s23%s345%s67\%8'
call tstF1 '1\s23%s345%S67\%8'
call tstF1 '1%S2%s3@2%S4@%s5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%s2@f2%s3@F3%s4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5i @%8i @%+8i @%-8i', nums
call tstF2 '_ %-9C @%5.2i @%12.2i @%+12.2i @%-12.2i', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @%8E @%9.2e @%11.3E', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call out "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call out 'tstF2' fmt '-----'
do vx=1 to words(vals)
call out f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fmtFTab abc, b
call fmtFAddFlds fmtFReset(abc), oFlds(m.st.1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteSt abc, b'.BUF'
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
call pipeIni
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-ex6-------
-11 -11 b3 -11+d4++++ -111.100 0.00e-9
-1 -10 b 4-10+d4+++ null1 null3 .
- -9 b3b-9 d4-9+d4+++ -11.000 -0.1e-9
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2 .
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1 .
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2 .
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3 .
11+ 11 b3 11+d4+++++ 0.111 0.00e-9
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 0.00e-9
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1 .
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2 .
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-ex6-------
testData end
$/tstFTab/ */
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3
call fTabAdd ft, '.' , '%-6C' , '.', 'testData begin',
, 'testData end'
call fTabAdd ft, 'a2i' , ' %6i'
call fTabAdd ft, 'b3b' , ' %-12C'
call fTabAdd ft, 'd4' , ' %10C'
call fTabAdd ft, 'fl5' , ' %8.3i'
call fTabAdd ft, 'ex6' , ' %7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstfmtUnits: procedure
/*
$=/tstFmtUnits/
### start tst tstFmtUnits #########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -59s0 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -59s0 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -10m1 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -59m5 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -23h1 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -23h3 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d0 --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d1 --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> ----d --> -9999d
. 863965440 ==> ++++d ++> 10000d -+> ----d --> -----d
. 8.6400E+9 ==> ++++d ++> +++++d -+> ----d --> -----d
. .3 ==> 0.300 ++> 0.300 -+> -0.300 --> -0.300
. .8 ==> 0.800 ++> 0.800 -+> -0.800 --> -0.800
. 1 ==> 1.000 ++> 1.000 -+> -1.000 --> -1.000
. 1.2 ==> 1.200 ++> 1.200 -+> -1.200 --> -1.200
. 59 ==> 59.000 ++> 59.000 -+> -59.000 --> -59.000
. 59.07 ==> 59.070 ++> 59.070 -+> -59.070 --> -59.070
. 59.997 ==> 59.997 ++> 59.997 -+> -59.997 --> -59.997
. 60 ==> 60.000 ++> 60.000 -+> -60.000 --> -60.000
. 60.1 ==> 60.100 ++> 60.100 -+> -60.100 --> -60.100
. 611 ==> 611.000 ++> 611.000 -+> -611.00 --> -611.000
. 3599.4 ==> 3k599 ++> 3k599 -+> -3k599 --> -3k599
. 3599.5 ==> 3k600 ++> 3k600 -+> -3k600 --> -3k600
. 3661 ==> 3k661 ++> 3k661 -+> -3k661 --> -3k661
. 83400 ==> 83k400 ++> 83k400 -+> -83k400 --> -83k400
. 999999.44 ==> 999k999 ++> 999k999 -+> -999k99 --> -999k999
. 999999.5 ==> 1M000 ++> 1M000 -+> -1M000 --> -1M000
. 567.6543E6 ==> 567M654 ++> 567M654 -+> -567M65 --> -567M654
. .9999991E9 ==> 999M999 ++> 999M999 -+> -999M99 --> -999M999
. .9999996E9 ==> 1G000 ++> 1G000 -+> -1G000 --> -1G000
. .9999991E12 ==> 999G999 ++> 999G999 -+> -999G99 --> -999G999
. .9999996E12 ==> 1T000 ++> 1T000 -+> -1T000 --> -1T000
. 567.6543E12 ==> 567T654 ++> 567T654 -+> -567T65 --> -567T654
. .9999991E15 ==> 999T999 ++> 999T999 -+> -999T99 --> -999T999
. .9999996E15 ==> 1P000 ++> 1P000 -+> -1P000 --> -1P000
. .9999991E18 ==> 999P999 ++> 999P999 -+> -999P99 --> -999P999
. .9999996E18 ==> 1E000 ++> 1E000 -+> -1E000 --> -1E000
. 567.6543E18 ==> 567E654 ++> 567E654 -+> -567E65 --> -567E654
. .9999991E21 ==> 999E999 ++> 999E999 -+> -999E99 --> -999E999
. .9999996E21 ==> 1000E ++> 1000E -+> -1000E --> -1000E
. .9999992E24 ==> 999999E ++> 999999E -+> ------E --> -999999E
. .9999995E24 ==> ++++++E ++> 1000000E -+> ------E --> -------E
. 10.6543E24 ==> ++++++E ++> +++++++E -+> ------E --> -------E
$/tstFmtUnits/ */
call jIni
call tst t, "tstFmtUnits"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)
end
lst = subword(lst, 1, 14) 999999.44 999999.5,
567.6543e6 .9999991e9 .9999996e9 .9999991e12 .9999996e12 ,
567.6543e12 .9999991e15 .9999996e15 .9999991e18 .9999996e18 ,
567.6543e18 .9999991e21 .9999996e21 .9999992e24 .9999995e24 ,
10.6543e24
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)
end
call tstEnd t
return
endProcedure tstfmtUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 .
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 cd) ) gh) .
$/tstSb/ */
call tst t, 'tstSb'
call scanSBSrc s, 'abcdefghijklkl ?'
call out 'end :' scanSBEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanSBEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanSBEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSBSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSBSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSBSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 .
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 cd) ) gh) .
$/tstSb2/ */
call tst t, 'tstSb2'
call scanIni
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call scanIni
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 1: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 1: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)), '<')
do x=1 while ass('v', jReadO(s)) \== ''
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(scanUtilReset(ScanRead(b)), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstjCatSql: procedure expose m.
/*
$=/tstJCatSql/
### start tst tstJCatSql ##########################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 .
$/tstJCatSql/ */
call tst t, 'tstJCatSql'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ')
call jCatSqlReset tstJCat, , jOpen(b, '<'), 30
do sx=1 until nx = ''
nx = jCatSqlNext(tstJCat, ';')
call tstOut t, 'cmd'sx nx
end
call jClose b
call tstEnd t
return
endProcedure tstJCatSql
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanOpts(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
/* call err implement outDest 'i', 'call tstOut' quote(m)', msg'
*/ end
else do
call oMutatName m, 'Tst'
call oMutatName m'.IN', 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
m.m.in.jReading = 1
m.m.in.jWriting = 1
m.m.in.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
cl = objClass(var, '')
if cl == '' then do
if var == '' then
call tstOut t, 'tstR: @ obj null'
else
call tstOut t, 'no class for' var 'in tstWriteO|'
end
else if abbrev(var, m.o.escW) then do
call tstOut t, o2String(var)
end
else if cl == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
if right(m, 3) == '.IN' then
m = left(m, length(m)-3)
else
call err 'tstReadO bad m' m
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
return s2o(m.m.in.ix)
end
call tstOut m, '#jIn eof' ix'#'
return ''
endProcedure tstReadO
tstFilename: procedure expose m.
parse arg suf, opt
if m.err.os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if m.err.os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err.os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
call errMsg ' }'ggTxt
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy time begin -----------------------------------------------------
11.05.23 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
----------------------------------------------------------------------*/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 15
if m.timeReadCvt \== 1 then
call timeReadCvt
uniq = left(uniq, 8, 'A')
d42 = d2x(q2i(uniq, m.timeUQDigits))
d48 = b2x('00'x2b(d42)'000000')
lrsn = right(d2x(x2d(d48) + x2d(m.timeUQZero)), 12, 0)
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFTab: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = 'FMTF.F'
return fmtFWriteSt(fmtFReset('FMTF.F'), j2Buf(rdr)'.BUF', wiTi)
endProcedure fmtFTab
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteSt: procedure expose m. ?????????
parse arg m, st, wiTi
if m.st.0 < 1 then
return 0
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(m.st.1)
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, m.st.sx)
end
return st.0
fmtFWriteSt
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = m.st.sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa */
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
f1 = substr(format(nMa, 2, 2, 9, 0), 7)
if f1 \= '' then
eMa = max(eMa, f1)
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo */
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.stem.0 = 0
m.comp.idChars = m.ut.alfNum'@_'
call compIniKI '=', "skeleton", "expression or block"
call compIniKI '.', "object", "expression or block"
call compIniKI '-', "string", "expression or block"
call compIniKI '@', "shell", "pipe or $;"
call compIniKI ':', "assignAttributes", "assignment or statement"
call compIniKI '|', "assignTable", "header, sfmt or expr"
call compIniKI '#', "text", "literal data"
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@:|'
m.m.chKin2 = '.-=#;:|'
m.m.chKinC = '.-=@'
m.m.chOp = '.-<@|?'
m.m.chOpNoFi = '.-@|?'
return m
endProcedure compReset
compIniKI: procedure expose m.
parse arg ki, m.comp.kind.ki.name, m.comp.kind.ki.expec
return
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
if src \== '' then
m.nn.cmpRdr = o2File(src)
else
m.nn.cmpRdr = ''
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipe '+F', ouO
call oRun r
if ouO \== '' then
call pipe '-'
return 0
endProcedure compRun
/*--- compile inline (lazy) ------------------------------------------*/
compInline: procedure expose m.
parse arg inl, spec
if symbol('m.compInline.inl') \== 'VAR' then do
b = jBuf()
st = mapInline(inl)
call jBufWriteStem b, st
if spec == '' then
spec = m.st.mark
m.compInline.inl = compile(comp(b), spec)
end
return m.compInline.inl
endProcedure compInline
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKind) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc m.m.scan, spec
m.m.compSpec = 1
res = compCUnit(m, kind, 1)
do while abbrev(m.m.dir, '$#')
call envPutO substr(m.m.dir, 3, length(m.m.dir)-4),
, compCUnit(m, right(m.m.dir, 1))
end
if \ m.m.compSpec then
call jClose m.m.scan
return res
endProcedure compile
/*--- cUnit = compilation Unit = separate compilations
no nesting| --------------------------------------------*/
compCUnit: procedure expose m.
parse arg m, ki, isFirst
s = m.m.scan
code = ''
do forever
m.m.dir = ''
src = compUnit(m, ki, '$#')
if \ compDirective(m) then
return scanErr(s, m.comp.kind.ki.expec "expected: compile",
m.comp.kind.ki.name "stopped before end of input")
if \ compIsEmpty(m, src) then do
/*wkTst??? allow assTb in separatly compiled units */
if isFirst == 1 & m.src.type == ':' ,
& pos(' ', src) < 1 & abbrev(src, 'COMP.AST.') then
call mAdd src, '', ''
code = code || ';'compAst2code(m, src, ';')
end
if m.m.dir == 'eof' then do
if \ m.m.compSpec | m.m.cmpRdr == '' then
return oRunner(code)
call scanReadReset s, m.m.cmpRdr
call jOpen s, m.j.cRead
m.m.compSpec = 0
end
else if length(m.m.dir) == 3 then
ki = substr(m.m.dir, 3, 1)
else
return oRunner(code)
end
endProcedure compCUnit
/*--- directives divide cUnits ---------------------------------------*/
compDirective: procedure expose m.
parse arg m
m.m.dir = ''
s = m.m.scan
lk = scanLook(s)
cx = pos('#', lk, 3)
if \ abbrev(lk, '$#') then do
if \ scanEnd(m.m.scan) then
return 0
m.m.dir = 'eof'
return 1
end
else if scanLit(s, '$#end' , '$#out') then do
m.m.dir = 'eof'
return 1
end
else if pos(substr(lk, 3, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if cx > 3 & pos(substr(lk, cx+1, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, cx+1)
end
else
call scanErr s, 'bad directive:' word(lk, 1)
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan, 'directive mismatch' m.m.dir
return 1
endProcedure compDirective
/**** parse the whole syntax *******************************************
currently, with the old code generation,
parsing and code generation is intermixec
migrating to AST should will separate these tasks
***********************************************************************/
compUnit: procedure expose m.
parse arg m, kind, stopper
s = m.m.scan
if pos(kind, m.m.chKind';') < 1 then
return scanErr(s, 'bad kind' kind 'in compUnit(...'stopper')')
if stopper == '}' then do
if kind \== '#' then do
one = compExpr(m, 'b', translate(kind, ';', '@'))
if compisEmpty(m, one) then
return compAST(m, 'block')
else
return compAST(m, 'block', one)
end
tx = '= '
cb = 1
do forever /* scan nested { ... } pairs */
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
return compAst(m, 'block', tx)
end
else if pos(kind, '.-=') > 0 then do
return compData(m, kind)
end
else if pos(kind, '@;') > 0 then do
call compSpNlComment m
return compShell(m)
end
else if kind == '|' | kind == ':' then do
if kind == '|' then
res = compAssTab(m)
else
res = compAssAtt(m)
if abbrev(res, '#') then
return compAst(m, ':', substr(res, 3))
else
return compAst(m, ';', substr(res, 3))
end
else if kind == '#' then do
res = compAST(m, 'block')
call compSpComment m
if \ scanNL(s) then
call scanErr s,
, 'space nl expected in heredata until' stopper
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanNL(s, 1) then do
if stopper = '$#' then
leave
call scanErr s, 'eof in heredata until' stopper
end
end
return res
end
endProcedure compUnit
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compAST(m, 'block')
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
a = compAst(m, ';')
m.a.text = ''
do forever
one = compPipe(m)
if one \== '' then
m.a.text = m.a.text || one
if \ scanLit(m.m.scan, '$;') then
return a
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsbw') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock,
, if(type=='w', m.m.chNotWord,m.m.chDol))
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki, 1)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki, withChain
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if withChain then do
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
compObj: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '?')
one = compBlock(m, ki pk)
if one \== '' then
return compAstAddOp(m, one, ki)
pp = ''
if pk \== '' then do
ki = right(pk, 1)
pp = left(pk, length(pk)-1)
end
one = compPrimary(m, translate(ki, '.', '@'), 0)
if one \== '' then
return pp || one
if ki == '.' then do
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKinC) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return pp'. compile(comp(j2Buf()), "'m.s.tok'")'
end
end
call scanBack s, pk
return ''
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compCheckNE(m, compExprBlock(m, '='),
, 'block or expr expected for file')
if \ abbrev(res, '.') then do
end
else if substr(res, verify(res, '.', n), 3) == '0* ' then do
st = word(res, 2)
if m.st.0 = 1 & abbrev(m.st.1, '. envGetO(') then
/* if undefined variable use new jbuf */
if pos(')', m.st.1) == length(m.st.1) then
m.st.1 = left(m.st.1, length(m.st.1)-1) ,
|| ", '-b')"
end
return compASTAddOp(m, res, '<')
endProcedure compFile
/*--- scan an operator chain and a kind ------------------------------*/
compOpKi: procedure expose m.
parse arg m, opt
s = m.m.scan
op = ''
if opt == '<' then do
call scanVerify s, m.m.chOpNoFi
op = m.s.tok
if scanLit(s, '<') then
return op'<'
end
call scanVerify s, m.m.chOp
op = op || m.s.tok
k1 = scanLook(s, 1)
if k1 \== '' & pos(k1, m.m.chKind) > 0 then do
call scanLit s, k1
return op || k1
end
if opt == '?' | op == '' | pos(right(op, 1), m.m.chKind) > 0 then
return op
call scanErr s, 'no kind after ops' op
endProcedure compOpKi
/*--- block or expression --------------------------------------------*/
compExprBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '<')
if right(pk, 1) == '<' then
return compAstAddOp(m, compFile(m), pk)
res = compBlock(m, ki pk)
if res \== '' then
return res
if pk \== '' then
lk = right(pk, 1)
else
lk = translate(ki, '.', '@')
res = compExpr(m, 's', lk)
if res \== '' then
return compASTAddOp(m, res, pk)
call scanBack s, pk
return res
endProcedure compExprBlock
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
inp = ''
out = ''
stmts = ''
sBef = ''
do forever
if scanLit(s, '$<') then
inp = inp',' comp2Code(m, compFile(m))
else if scanLit(s, '$>>', '$>') then
if out <> '' then
call scanErr s, 'duplicate output'
else
out = substr('?FA', length(m.s.tok), 1) ,
comp2Code(m, compFile(m))
else if scanLit(s, '$|') then do
if stmts == '' then
call scanErr s, 'stmts expected before $|'
sBef = sBef"; call pipe 'N|'" || stmts
stmts = ''
end
else do
one = comp2code(m, ';'compStmts(m))
if one == '' then
leave
stmts = stmts';' one
end
call compSpNlComment m
end
if sBef == '' then do
if inp == '' & out == '' then
return stmts
if stmts == '' then do
call scanErr s,'no statemtents in pipe'
stmts = '; call pipeWriteAll'
end
end
else if stmts == '' then
call scanErr s, 'stmts expected after $|'
inO = left('f', inp \== '')
inp = substr(inp, 3)
parse var out ouO out
if sBef == '' then
return "; call pipe '+"ouO || strip(inO"',"out","inp, "T", ","),
|| stmts"; call pipe '-'"
else
return "; call pipe '+N" || strip(inO"',,"inp, "T", ",") ,
|| substr(sBef, 17),
|| "; call pipe '"left(ouO'P', 1)"|'" ,
strip(","out,"T", ",") || stmts"; call pipe '-'"
endProcedure compPipe
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
res = compAss(m)
if res == '' then
call scanErr s, 'assignment expected after $='
return res
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNE(m, compExprBlock(m, '@'),
, "block or expr expected after $@"))
fu = m.s.tok
if fu == 'for' | fu == 'with' | fu == 'forWith' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m, 'with'),
, "statement after $@for" v))
if fu == 'forWith' then
st = 'call envSetWith envGetO('v');' st
if abbrev(fu, 'for') then
st = 'do while envReadO('v');' st'; end'
if fu == 'forWith' then
st = 'call envPushWith "";' st '; call envPopWith'
else if fu == 'with' then
st = 'call envPushName' v';' st '; call envPopWith'
return ';' st
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
call compSpComment m
suf = compExpr(m, 's', ';')
if \ compIsEmpty(m, suf) then
suf = comp2Code(m, ':'suf)
else if var \== '' then
call scanErr s, "$@do control construct expected"
else
suf = ''
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInter('return' comp2Code(m, '-'nm)), st
return '; '
end
if scanLit(s, '(') then do
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '{', '.{', '-{', '={') then do
br = m.s.tok
a = compExpr(m, 'b', if(br == '{', '-', left(br, 1)))
if \ scanLit(s, '}') then
call scanErr s, 'closing } expected after $@'fu || br
res = '; call oRun envGetO("'fu'")'
if pos(left(a, 1), 'ec') < 1 then
res = res',' comp2code(m, a)
return res
end
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
end
if scanLit(s, '$$') then
return compCheckNN(m, compExprBlock(m, '='),
, 'block or expression expected after $$')
return ''
endProcedure compStmt
compAss: procedure expose m.
parse arg m, aExt
s = m.m.scan
sla = scanLook(s)
slx = verify(sla, m.m.chKind'/'m.m.chOp, 'n')
if slx > 0 then
sla = left(sla, slx-1)
sla = pos('/', sla) > 0
nm = ''
if \ sla then do
nm = compExpr(m, 'b', '=')
if compIsEmpty(m, nm) then
return ''
nm = comp2Code(m, '-'nm)
if \ scanLit(s, "=") then
return scanErr(s, '= expected after $=' nm)
end
m.m.bName = ''
vl = compCheckNE(m, compExprBlock(m, '='),
, 'block or expression after $=' nm '=')
if sla then
if m.m.bName == '' then
call scanErr s, 'missing blockName'
else
nm = "'"m.m.bName"'"
va = compAstAftOp(m, vl)
if va \== '' & m.va.type == ':' then do
pu = "call envPushName" nm
if abbrev(m.m.astOps, '<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else if abbrev(m.m.astOps, '<<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else
call mAdd va, pu ", 'as1'", "call envPopWith"
return va
end
if compAstKind(m, vl) == '-' then
return '; call envPut' nm',' comp2Code(m, vl)aExt
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)aExt
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, dKi ops
s = m.m.scan
if \ scanLit(s, '{', '¢', '/') then
return ''
start = m.s.tok
if (ops \== '' & pos(right(ops, 1), m.m.chKind) < 1) ,
| pos(dKi, m.m.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block (def' dKi')')
if ops == '' then do
ki = dKi
end
else do
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
end
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper) then do
if pos(ki, ':|') < 1 | \ abbrev(stopper, '$') then
call scanErr s, 'ending' stopper 'expected after' starter
else if \ scanLit(s, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'or' substr(stopper, 2),
'expected after' starter
end
if abbrev(starter, '/') then
m.m.bName = substr(starter, 2, length(starter)-2)
else
m.m.bName = ''
if m.res.text == '' then
m.res.text = ' '
return compAstAddOp(m, res, ops)
endProcedure compBlock
compAssAtt: procedure expose m. aClass
parse arg m
res = ''
aClass = ''
s = m.m.scan
last = ''
do forever
if compSpNlComment(m, '*') then do
end
else if pos(scanLook(s, 1), '/!}') > 0 then do
leave
end
else if scanLit(s, ';', '$;') then do
if last = ';' then
res = res'; call envWithNext'
last = ';'
end
else do
s1 = compAss(m, ", 1")
if s1 == '' then do
s1 = compStmt(m)
if s1 == '' then
leave
end
else do
if last == ';' then
res = res'; call envWithNext'
last = 'a'
end
res = res';' comp2code(m, ';'s1)
end
if res == '' then
res = ';'
end
if last == '' then
return res
else
return '# call envWithNext "b";' res ,
'; call envWithNext "e";'
endProcedure compAssAtt
compAssTab: procedure expose m. aClass
parse arg m
s = m.m.scan
call compSpNlComment m, '*'
hy = 0
tab = ''
do forever
bx = m.s.pos
if \ scanName(s) then
leave
hx = hy + 1
h.hx.beg = bx
if hx > 1 & bx <= h.hy.end then
call scanErr s, 'header overlap' m.s.tok 'pos' bx
h.hx = m.s.tok
tab = tab', f' m.s.tok 'v'
h.hx.end = m.s.pos
hy = hx
call compSpComment m, '*'
end
if tab \== '' then
aClass = classNew('n* Ass u' substr(tab, 3))
res = ''
isFirst = 1
do while scanNL(s)
do forever
call compSpNlComment m, '*'
s1 = compStmt(m)
if s1 == '' then
leave
res = res';' comp2code(m, ';'s1)
last = 's'
end
if pos(scanLook(s, 1), '/!}') > 0 then
leave
do qx=1
bx = m.s.pos
s1 = compExpr(m, 'w', '=')
if compIsEmpty(m, s1) then
leave
ex = m.s.pos
if ex <= bx then
return scanErr(s, 'colExpr backward')
do hy=1 to hx while bx >= h.hy.end
end
hz = hy+1
if hz <= hx & ex > h.hz.beg then
call scanErr s, 'value on hdr' h.hy 'overlaps' h.hz
else if hy > hx | bx >= h.hy.end | ex <= h.hy.beg then
call scanErr s, 'value from' bx 'to' ex ,
'no overlap with header' h.hy
if qx > 1 then
nop
else if isFirst then do
res = res"; call envWithNext 'b', '"aClass"'"
isFirst = 0
end
else
res = res"; call envWithNext"
res = res"; call envPut '"h.hy"'," comp2Code(m, "-"s1)", 1"
call compSpComment m, '*'
end
end
if isFirst then
return res
else
return '#' res"; call envWithNext 'e'"
endProcedure compassTab
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanNL s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
sp = 0
co = 0
do forever
if scanVerify(s, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else if xtra == '' then
leave
else if \ scanLit(s, xtra) then
leave
else do
co = 1
m.s.pos = 1+length(m.s.src)
end
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) then
found = 1
else if scanNL(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/**** small helper routines ******************************************/
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
if pos(' ', ex) < 1 & pos('COMP.AST.', ex) > 0 then do
a = substr(ex, pos('COMP.AST.', ex))
a = compAstAftOp(m, a)
if m.a.type = 'block' then
return 0 /* m.a.0 == 0 */
else
return m.a.text == ''
end
e1 = word(ex, 1)
return ex = '' | verify(e1, 'ec', 'm') > 0
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Graph ***************************************
goal is to migrate to migrate to old codeGenerator to AST
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, tp
n = mNew('COMP.AST')
m.n.type = tp
if wordPos(tp, 'block') > 0 then do
do cx=1 to arg()-2
m.n.cx = arg(cx+2)
end
m.n.0 = cx-1
end
else do
m.n.text = arg(3)
m.n.0 = 0
end
m.a.isAnnotated = 1
return n
endProcedure compAST
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if ops == '' then
return a
if pos('COMP.AST.', a) < 1 then
return ops || a
if m.a.type = 'ops' then do
m.a.text = ops || m.a.text
return a
end
n = compAst(m, 'ops', ops)
call mAdd n, a
return n
endProcedure compAstAddOp
/*--- return the first AST after the operand chain
put the operands into m.m.astOps ---------------------------*/
compASTaftOp: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return ''
do while m.a.type == 'ops'
m.m.astOps = m.a.text || m.m.astOps
a = m.a.1
end
return a
endProcedure compASTAftOpType
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.type == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
/*--- return the code for an AST with operand chain trg --------------*/
compAst2Code: procedure expose m.
parse arg m, a, aTrg
if pos(' ', a) > 0 | \ abbrev(a, 'COMP.AST.') then
return comp2Code(m, aTrg || a)
if \ abbrev(a, 'COMP.AST.') then
call err 'bad ast' a
do while m.a.type == 'ops'
aTrg = aTrg || m.a.text
a = m.a.1
end
trg = compAstOpsReduce(m, aTrg)
if m.a.type == translate(right(trg, 1), ';', '@') then do
if length(trg) == 1 then do
if pos(trg, ';@') > 0 then
return 'do;' m.a.text ';end'
else
return m.a.text
end
else
return compAST2Code(m, a, left(trg, length(trg)-1))
end
if m.a.type == 'block' then do
op = right(trg, 1)
tLe = left(trg, length(trg)-1)
call compASTAnnBlock m, a
if pos(m.a.maxKind, '.-<') > 0 & pos(op, '.-|?') > 0 then do
if m.a.0 = 1 then do
o1 = if(op=='-', '-', '.')
r = compAst2Code(m, m.a.1, o1)
r = compC2C(m, o1, compAstOpsReduce(m, tLe||o1), r)
if pos(op, '.-<') > 0 then
return '('r')'
else
return r
end
if m.a.0 = 0 & op == '?' then
return compC2C(m, '.', compAstOpsReduce(m, tLe'.'))
if op == '-' then do
cd = ''
do cx = 1 to m.a.0
cd = cd '('compAst2Code(m, m.a.cx, '-')')'
end
return compC2C(m, '-', trg, substr(cd, 2))
end
call scanErr m.m.scan, 'bad block cardinality' aTrg
end
cd = ''
do cx = 1 to m.a.0
cd = cd';' compAst2Code(m, m.a.cx, ';')
end
if right(trg, 1) == '@' then
trg = overlay(';', trg, length(trg))
return compC2C(m, ';', trg, 'do;' cd'; end')
end
else if m.a.type == ';' then do
return compC2C(m, ';', trg, m.a.text)
if right(trg, 1) == '-' then
return compAst2Code(m, "- o2String('"oRunner(m.a.text)"')",
, trg)
if right(trg, 1) == '<' then
return compAst2Code(m, "< o2File('"oRunner(m.a.text)"')",
, trg)
end
else if m.a.type == ':' then do
if m.a.0 = 0 then
call mAdd a, 'call envPushWith', 'call envPopWith'
return compC2C(m, ';', trg,
, 'do;' m.a.1';' m.a.text';' m.a.2'; end')
end
call scanErr m.m.scan, 'implement type' m.a.type 'for' a 'trg' trg
endProcedure compAst2Code
/*--- do a chain of code transformations
from code of kind fr by opList
op as from kind operand
= constant -
- rexx string Expr cast to string/ concat file/output
. rexx object Expr cast to object
< rexx file Expr cast to file
; rexx Statements execute, write obj, Str
@ - cast to ORun, run an obj, write file
| - extract exactlyOne
? - extract OneOrNull
----------------------------------------------------------------------*/
compC2C: procedure expose m.
parse arg m, fr, opList, code
oldCode = fr':' code '==>' opList '==>'
do tx=length(opList) by -1 to 1
to = substr(opList, tx, 1)
if fr == to then
iterate
nn = '||||'
if to == '-' then do
if fr == '=' then
nn = quote(code)
else if abbrev(fr code, '. envGetO(') then
nn = 'envGet(' || substr(code, 9)
else if fr == ';' then
nn = "o2String('"oRunner(code)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("code")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(code))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('code')'
else if fr == '<' then
nn = code
else if fr == ';' then
nn = quote(oRunner(code))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' code
else if fr == '<' then
nn = 'call pipeWriteAll' code
else if fr == ';' then
nn = code
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(code)
else if fr == '-' then
nn = 'call out' code
else if fr == '.' | fr == '<' then
nn = 'call outO' code
end
else if to == ':' then do
if fr == '=' then
nn = quote(code)
else
nn = code
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('code')'
else if fr == '=' then
nn = "file("quote(code)")"
else if fr == '.' then
nn = 'o2File('code')'
else if fr == ';' then
nn = 'o2File('oRunner(code)')'
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then
nn = 'fileSingle('code if(to == '|','', ", ''")')'
else if fr == '@' | fr == ';' then
/* ???wkTst optimize: do it directly */
nn = compC2C(m, fr, to'<', code)
to = '.'
end
if nn == '||||' then
return scanErr(m.m.scan,
,'compC2C bad fr' fr 'to' to 'list' opList)
fr = to
code = nn
end
return code
endProcedure compC2C
/*--- reduce a chain of operands -------------------------------------*/
eliminate duplicates and identity transformations ----------*/
compAstOpsReduce: procedure expose m.
parse arg m, ops
ki = ops
ki = space(translate(ops, ' ', 'e('), 0)
fr = ';<; <;< -.- <@<'
to = '; < - < '
fr = fr '== -- .. << ;; @@ @('
to = to '= - . < ; @ (@'
wc = words(fr)
do until ki = oldKi
oldKi = ki
do wx=1 to wc
do forever
wf = word(fr, wx)
cx = pos(wf, ki)
if cx < 1 then
leave
ki = left(ki, cx-1) || word(to, wx) ,
|| substr(ki, cx+length(wf))
end
end
end
return ki
endProcedure compASTOpsReduce
/*--- annotate a block if necessary ----------------------------------*/
compASTAnnBlock: procedure expose m.
parse arg m, a
if m.a.isAnnotated == 1 then
return
mk = ''
do cx=1 to m.a.0
c = m.a.cx
if pos(' ', c) > 0 | \ abbrev(c, 'COMP.AST.') then
ki = left(c, 1)
else if \ abbrev(c, 'COMP.AST.') then
return scanErr(m.m.scan, 'bad ast' c 'parent' a) /0
else
call scanErr m.m.scan, 'implement kind of' c 'type' m.c.type
if pos(ki, '=-.<;@:|') < 1 then do
if pos(ki, 'el0') < 1 then
call err 'bad kind' ki
end
else if mk == '' | pos(ki, '=-.<;@:|') > pos(mk, '=-.<;@:|') then
mk = ki
end
m.a.maxKind = mk
m.a.isAnnotated = 1
return
endProcedrue compASTAnnBlock
/**** old code generator ***********************************************
plan is to replace it with AST ******************************/
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
if expr == '' & pos(' ', ki) < 1 & pos('COMP.AST.', ki) > 0 then do
cx = pos('COMP.AST.', ki)
return compAst2Code(m, substr(ki, cx), left(ki, cx-1))
end
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 | (to == '*' & fr == '*') then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
toBef = to
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' | fr == '<' then
nn = 'call outO' expr
else if fr == '#' then
nn = 'call envPushWith ;'expr'; call envPopWith'
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then do
nn = 'fileSingle('expr if(to == '|','', ", ''")')'
to = '.'
end
else if fr == '@' | fr == ';' then do
to = to'<'fr
nn = expr
end
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' toBef 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ @( $l $0 @#'
to.2 = '= - . < ; ( (- (. (; < ; @ @ (@ $ $ ;#'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; ;<( <(; @(- @(l |(l ?(l'
to.3 = ' 0; l; - - . . ; ;< <; ;(- ;(l (|l (?l'
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 then do
if trgt == '|' | trgt == '?' then
return left(m.st.1, 1) comp2Code(m, m.st.1)
else if trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
end
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/* copy comp end ******************************************************/
/* copy scanSB begin ***************************************************
Achtung: inc generiert SB aus scanSB, Aenderungen nur in scanSB|
ScanSB: basic scan
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
variable interface
scanSrc(m, source) starts scanning a single line
scanEnd(m) : returns whether we reached end of input
scanErr(m, txt): error with current scan location
m is an address, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
/*--- return the next len characters until end of src ----------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src ---------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset ------------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset ------------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End -------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
px = m.m.pos
do forever
px = pos(sep, m.m.src, px)
if px = 0 then do
m.m.tok = ''
return 0
end
px = px + length(sep)
if \ abbrev(substr(m.m.src, px), sep) then do
m.m.tok = substr(m.m.src, m.m.pos, px-m.m.pos)
m.m.pos = px
return 1
end
px = px + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
t1 = m.m.tok
qu = right(t1, 1)
if \ scanStrEnd(m, qu) then do
m.m.pos = m.m.pos - length(t1)
return scanErr(m, 'ending Apostroph('qu') missing')
end
m.m.val = repAll(left(m.m.tok, length(m.m.tok)-1), qu||qu, qu)
m.m.tok = t1 || m.m.tok
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = ' '
if \scanUntil(m, stopper) then
return 0
m.m.val = m.m.tok
if ucWord == 1 then
upper m.m.val
return 1
endProcedure scanWord
/*--- skip, scan and return next word --------------------------------*/
scanSkWord: procedure expose m.
parse arg m, stopper, ucWord, eMsg
if scanWord(scanSkip(m), stopper, ucWord) then
return m.m.val
else if eMsg == '' then
return ''
else
call scanErr m, eMsg 'expected'
endProcedure scanSkWord
/*--- go back the current token --------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- set new src - allow scanning without open ----------------------*/
scanSBSrc: procedure expose m.
parse arg m, m.m.src
return scanSBOpen(m)
endProcedure scanSBSrc
/*--- start scanning with a new single src ---------------------------*/
scanSBOpen: procedure expose m.
parse arg m
m.m.pos = 1
m.m.tok = ''
return m
endProcedure scanSBOpen
/*--- start scanning with a new single src ---------------------------*/
scanSBClose: procedure expose m.
parse arg m
m.m.pos = length(m.m.src) + 1
m.m.tok = '--- closed ---'
return m
endProcedure scanSBClose
scanSBSpace: procedure expose m.
parse arg m
nx = verify(m.m.src, ' ', , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
res = nx <> m.m.pos
m.m.tok = left(' ', res)
m.m.pos = nx
return res
endProcedure scanSBSpace
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
scanErr: procedure expose m.
parse arg m, txt
return err('s}'txt'\n'scanInfo(m))
endProcedure scanErr
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
endProcedure scanSBInfo
/*--- return position in simple format -------------------------------*/
scanSBPos: procedure expose m.
parse arg m
return if(m.m.pos > length(m.m.src), 'E', 'singleSrc' m.m.pos)
/*--- return true if at end of src -----------------------------------*/
scanSBEnd: procedure expose m.
parse arg m
return m.m.pos > length(m.m.src)
/* copy scanSB end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input: with multiple lines
==> all of scanSB
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an address, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini = 1 then
return
m.scan.ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanSB u JRWO', 'm',
, 'scanEnd return 1',
, 'scanNL m.m.tok = ""; return 0',
, 'scanCom m.m.tok = ""; return 0',
, 'scanInfo return scanSBInfo(m)' ,
, 'jReset call scanSbSrc m, arg;' ,
'call scanOpts m, arg2, arg3, arg(4)',
, "jOpen call scanSBOpen scanOC(m, opt, 'ScanSBR')" ,
, "jClose call scanSBClose scanOC(m, , 'ScanSB')",
, 'scanPos scanSBPos(m)'
call classNew 'n ScanSBR u ScanSB', 'm',
, "jReadO if scanType(m) == '' then return '';" ,
" else return oClaCopy('"ts"', m, '')"
return
endProcedure scanIni
/*--- check open opt is read and mutate ------------------------------*/
scanOC: procedure expose m.
parse arg m, opt, cla
if \ abbrev(m.j.cRead, opt) then
call err 'scanOpen opt must be' m.j.cRead 'not' opt
return oMutatName(m, cla)
endProcedure scanOC
/*--- start scanning with a new single src ---------------------------*/
scanSrc: procedure expose m.
parse arg m, src
return scanSbSrc(oMutatName(m, 'ScanSB'), src)
scanOpen: procedure expose m.
parse arg m
opt = ''
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanOpen
scanInfo: procedure expose m.
parse arg m
interpret objMet(m, 'scanInfo')
/*--- return true if at end of src -----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
interpret objMet(m, 'scanEnd')
/*--- scan over white space, nl, comments ...-------------------------*/
scanSpace: procedure expose m.
parse arg m
fnd = 0
do while scanSBSpace(m) | scanCom(m) | scanNl(m)
fnd = 1
end
m.m.tok = left(' ', fnd)
return fnd
endProcedure scanSpace
/*--- scan next line -------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scan one comment -----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
scanPos: procedure expose m.
parse arg m
interpret 'return' objMet(m, 'scanPos')
endProcedure scanPos
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr m, 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
/* ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v') */
call classNew 'n ScanRead u ScanSB', 'm',
, 'scanEnd return m.m.atEnd' ,
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanReadCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen scanOC(m, opt, 'ScanReadR')",
, "jClose call scanReadClose scanOc(m, , 'ScanRead')"
call classNew 'n ScanReadR u ScanRead', 'm',
, 'jReadO' oClaMet(class4Name('ScanSBR'), 'jReadO')
call classNew "n EditRead u JRW", "m",
, "jRead return editRead(m, var)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanReadReset(oNew('ScanRead'), rdr, n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr, n1, np, co
call oMutatName m, 'ScanRead'
call scanOpts m, n1, np, co
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
call jOpen m.m.rdr, '<'
call scanReadNL m, 1
return m
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return scanSBClose(m)
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
return 0
end
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
scanReadCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.pos = 1 + length(m.m.src)
m.m.tok = ' '
return 1
endProcedure scanReadCom
scanReadPos: procedure expose m.
parse arg m, msg
if scanEnd(m) then
return 'E'
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here --------------------*/
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m, var
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) ^= 0 then
return 0
m.var = ll
return 1
endProcedure editRead
/*--- search loop in edit macro --------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanSB', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, "jOpen call scanWinOpen scanOC(m, opt, 'ScanWinR'), arg(3)",
, "jClose call scanReadClose scanOC(m, , 'ScanWin')",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)'
call classNew 'n ScanWinR u ScanWin', 'm',
, 'jReadO' oClaMet(class4Name('ScanSBR'), 'jReadO')
return
endProcedure scanWinIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, wiSz, wiGa, cuPo, cuLe
m.m.atEnd = 'closed after reset'
return scanWinOpts(scanOpts(m), wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinOpts
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
call scanSBOpen m
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment ---------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if scanLit(m, '/*') then do
ex = pos('*/', m.m.src, m.m.pos+2)
if ex <= m.m.pos then
return scanErr(m, '*/ missing after /*')
m.m.pos = ex+2
call scanWinRead m
end
else do
cl = length(m.m.scanComment)
np = scanWinNlPos(m)
if \ ( cl>0 & m.m.pos+cl <= np & m.m.scanComment ,
== substr(m.m.src, m.m.pos, cl)) then do
m.m.tok = ''
return 0
end
m.m.pos = np
end
m.m.tok = ' '
return 1
endProcedure scanWinCom
/*--- scan nl --------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np \= m.m.pos then
return 0
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanEnd(m) then
return 'E'
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
endProcedure scanSqlReset
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpace(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement noSp, use scanNum instead'
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpace m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
scan2Trgs: procedure expose m.
parse arg m, t1, t2
cx = m.m.pos - 1
do forever
cx = verify(m.m.src, t1 || t2, 'm', cx + 1)
if cx = 0 then do
m.m.pos = length(m.m.src) + 1
return ''
end
if pos(substr(m.m.src, cx, 1), t1) > 0 then do
m.m.pos = cx
return substr(m.m.src, cx, 1)
end
do ax=4 to arg()
if arg(ax) == substr(m.m.src, cx, length(arg(ax))) then do
m.m.pos = cx
return arg(ax)
end
end
end
endProcedure scan2Trgs
scanSql2Stop: procedure expose m.
parse arg m, sta, stop
sta = substr(sta, 2)
c1 = left(sta, 1)
if c1 == 't' then do
bx = m.m.pos
c1 = scan2Trgs(m, '"'''stop, '-/', '--', '/*')
if bx < m.m.pos then
return 't'sta
m.m.pos = m.m.pos + length(c1)
c1 = left(c1, 1)
sta = c1 || sta
end
if c1 == '/' then do
bx = m.m.pos
c1 = scan2Trgs(m, '"''', '-*', '--', '*/')
if bx < m.m.pos then
return '+'sta
m.m.pos = m.m.pos + length(c1)
if c1 == '*/' then
return sta
c1 = left(c1, 1)
sta = c1 || sta
end
if abbrev(sta, "'") | abbrev(sta, '"') then do
if scanStrEnd(m, c1) then
return sta
m.m.pos = 1 + length(m.m.src)
return '+'sta
end
if pos(c1, '-'stop) > 0 then do
if c1 == '-' then
m.m.pos = length(m.m.src) + 1
return sta
end
if \ abbrev(sta, '/') then
call err 'bad sta2' sta 'for scanSql2Stop'
call err implement
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
endProcedure scanSql2Stop
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets --------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call mapReset env.vars
m.env.with.0 = 0
call mapReset env.c2w
call mNewArea 'ENV.WICO', '='
m.pipe.0 = 1
m.pipe.1.in = jOpen(oNew('JRWEof'), '<')
m.pipe.1.out = jOpen(oNew('JSay'), '>')
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput Parent saY Newcat File, Appendtofile
psf| parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO, aI
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if pos(oc, 's|fp') > 0 then do
call jClose m.pipe.ax.in
if oc == 'p' then
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
else if oc == '|' then
m.pipe.ax.in = jOpen(oOut, '<')
else if oc == 'f' then do
if arg() <= 3 then
m.pipe.ax.in = jOpen(o2file(aI), '<')
else do
ct = jOpen(Cat(), '>')
do lx = 3 to arg()
call jWriteAll ct, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(ct), '<')
end
end
else if arg() <= 3 then
m.pipe.ax.in = jOpen(jBuf(aI), '<')
else do
bu = jOpen(jBuf(), '>')
do lx = 3 to arg()
call jWrite bu, arg(lx)
end
m.pipe.ax.in = jOpen(jclose(bu), '<')
end
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then
call err 'implement' substr(opts, ox) 'in pipe' opts
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
envIsDefined: procedure expose m.
parse arg na
return '' \== mapValAdr(env.vars, na)
endProcedure envIsDefined
envPushWith: procedure expose m.
parse arg obj, cl, fn, elCl
tos = m.env.with.0 + 1
m.env.with.0 = tos
m.env.with.tos.fun = fn
m.env.with.tos.muElCl = ''
if fn == '' then do
call envSetWith obj, cl
return
end
if cl == '' then
cl = objClass(obj)
if fn == 'as1' then do
call envSetWith obj, cl
m.env.with.tos.muElRef = m.cl.valueCl \== '',
& m.cl.valueCl \== m.class.classV
if m.env.with.tos.muElRef then
m.env.with.tos.muElCl = m.cl.valueCl
else
m.env.with.tos.muElCl = cl
return
end
else if fn \== 'asM' then
call err 'bad fun' fn
ff = oClaMet(cl, 'oFlds') /*just be sure it's initialised */
if m.cl.stemCl == '' then
call err 'class' className(cl) 'not stem'
cc = m.cl.stemCl
isRef = m.cc == 'r'
m.env.with.tos.muElRef = isRef
if m.cc \== 'r' then
m.env.with.tos.muElCl = cc
else if elCl \== '' then
m.env.with.tos.muElCl = elCl
else if m.cc.class == '' then
call err 'elCl null for envPushWith('obj ','cl ','multi', ...)'
else
m.env.with.tos.muElCl = m.cc.class
m.env.with.tos.class = ''
m.env.with.tos.muCla = cl
m.env.with.tos.muObj = obj
return
endProcedure envPushWith
envSetWith: procedure expose m.
parse arg obj, cl
if cl == '' & obj \== '' then
cl = objClass(obj)
tos = m.env.with.0
m.env.with.tos = obj
m.env.with.tos.class = cl
return
endProcedure envSetWith
envWithObj: procedure expose m.
tos = m.env.with.0
if tos < 1 then
call err 'no with in envWithObj'
return m.env.with.tos
endProcedure envWithObj
envAccPath: procedure expose m. m cl
parse arg pa, stop, nllNw
nullNew = nllNw == 1
dx = verify(pa, m.class.cPath, 'm')
if dx = 0 then do
n1 = pa
p2 = ''
end
else do
n1 = left(pa, dx-1)
p2 = substr(pa, dx)
end
wCla = ''
do wx = m.env.with.0 by -1 to if(stop==1, m.env.with.0, 1)
wCla = m.env.with.wx.class
if symbol('m.wCla.f2c.n1') == 'VAR' then
return oAccPath(m.env.with.wx, pa, m.env.with.wx.class)
end
if stop == 1 then
return 'no field' n1 'in class' className(wCla)
vv = mapValAdr(env.vars, n1)
if vv \== '' then
if p2 == '' then
return oAccPath(vv, '', m.class.classR)
else
return oAccPath(vv, '|'p2, m.class.classR)
else if nullNew & p2 == '' then
return oAccPath(mapValAdr(env.vars, n1,'a'), p2,m.class.classR)
else
return 'undefined variable' pa
endProcedure envAccPath
envWithNext: procedure expose m.
parse arg beEn, defCl, obj
tos = m.env.with.0
if tos < 1 then
call err 'envWithNext with.0' tos
st = m.env.with.tos.muObj
if beEn == 'b' then do
if m.env.with.tos.fun == 'asM' then
m.st.0 = 0
if m.env.with.tos.muElCl == '' then
m.env.with.tos.muElCl = defCl
end
else if m.env.with.tos.fun == 'asM' then
m.st.0 = m.st.0 + 1
else if m.env.with.tos.fun == '' then
call outO m.env.with.tos
else if beEn = '' then
call err 'no multi allowed'
if beEn == 'e' then
return
if m.env.with.tos.fun == 'as1' then do
if m.env.with.tos == '' then
call err 'implement withNext null'
return
end
/* if obj \== '' then do
if \ m.env.with.tos.muElRef then
call err 'obj but not ref'
m.nn = obj
call envSetWith obj
end
*/
if m.env.with.tos.fun == '' then do
call envSetWith oNew(m.env.with.tos.muElCl)
return
end
nn = st'.' || (m.st.0 + 1)
if m.env.with.tos.muElRef then do
m.nn = oNew(m.env.with.tos.muElCl)
call envSetWith m.nn
end
else do
call oClear oMutate(nn, m.env.with.tos.muElCl)
call envSetWith nn
end
return
endProcedure envWithNext
envPushName: procedure expose m.
parse arg nm, multi, elCl
res = envAccPath(nm, , 1)
if res \== 1 then
return err(res 'in envPushName('nm',' multi')')
do while m.cl == 'r'
if m.m == '' then do
res = oRefSetNew(m, cl)
if res \== 1 then
call err res 'in envPushName('nm',' multi')'
end
m = m.m
cl = objClass(m)
end
call envPushWith m, cl, multi, elCl
return
endProcedure envPushName
envNewWiCo: procedure expose m.
parse arg co, cl
k1 = strip(co cl)
n = mapGet('ENV.C2W', k1, '')
if n \== '' then
return n
k2 = k1
if co \== '' then do
k2 = strip(m.co.classes cl)
n = mapGet('ENV.C2W', k2, '')
end
k3 = k2
if n == '' then do
cx = wordPos(cl, m.co.classes)
if cx > 0 then do
k3 = space(subWord(m.co.classes, 1, cx-1),
subWord(m.co.classes, cx+1) cl, 1)
n = mapGet('ENV.C2W', k3, '')
end
end
if n == '' then
n = envNewWico2(co, k3)
call mapAdd 'ENV.C2W', k1, n
if k2 \== k1 then
call mapPut 'ENV.C2W', k2, n
if k3 \== k2 & k3 \== k1 then
call mapPut 'ENV.C2W', k3, n
return n
endProcedure envNewWiCo
envNewWiCo2: procedure expose m.
parse arg co, clLi
n = mNew('ENV.WICO')
if co == '' then
m.n.level = 1
else
m.n.level = m.co.level + 1
m.n.classes = clLi
na = ''
do cx = 1 to words(clLi)
c1 = word(clLi, cx)
na = na className(c1)
do qx=1 to 2
ff = c1 || word('.FLDS .STMS', qx)
do fx = 1 to m.ff.0
fn = m.ff.fx
if fn == '' then
iterate
fn = substr(fn, 2)
m.n.f2c.fn = cx
end
end
end
m.n.classNames = space(na, 1)
return n
endProcedure envNewWiCo2
envPopWith:procedure expose m.
tos = m.env.with.0
m.env.with.0 = tos - 1
return
endProcedure envPopWith
envGet: procedure expose m.
parse arg na
res = envAccPath(na)
if res == 1 then
res = oAccStr(m, cl)
if res == 1 then
return str
return err(res 'in envGet('na')')
endProcedure envGet
envGetO: procedure expose m.
parse arg na, opt
res = envAccPath(na, , opt == '-b')
if res == 1 then
res = oAccO(m, cl, opt)
if res == 1 then
return ref
return err(res 'in envGetO('na')')
endProcedure envGetO
envPutO: procedure expose m.
parse arg na, ref, stop
res = envAccPath(na, stop, 1)
if res == 1 then
res = ocPutO(m, cl, ref)
if res = 1 then
return ref
return err(res 'in envPutO('na',' ref',' stop')')
endProcedure envPutO
envPut: procedure expose m.
parse arg na, va, stop
res = envAccPath(na, stop , 1)
if res == 1 then
res = ocPut(m, cl, va)
if res == 1 then
return va
return err(res 'in EnvPut('na',' va',' stop')')
endProcedure envPut
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
res = inO()
if res == '' then
return 0
call envPutO na, res
return 1
endProcedure envReadO
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
res = jReadO(m.m.catRd)
if res \== '' then
return res
call catNextRdr m
end
return ''
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
fileSingle: procedure expose m.
parse arg m
call jOpen m, '<'
res = jReadO(m)
two = jReadO(m)
call jClose m
if res == '' then
if arg() < 2 then
call err 'empty file in fileSingle('m')'
else
res = arg(2)
if two \== '' then
call err '2 or more recs in fileSingle('m')'
return res
endProcedure fileSingle
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call errIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
call classAddMet m.class.classV, 'o2File return file(m.m)'
call classAddMet m.class.classW, 'o2File return file(substr(m,2))'
if m.err.os == 'TSO' then
call fileTsoIni
else if m.err.os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' m.err.os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class.classV
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.m.defDD = 'CAT*'
m.fileTso.buf = m.fileTso.buf + 1
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call tsoOpen word(aa, 1), 'R'
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
parse var aa m.m.dd m.m.free
m.m.dsn = m.dsnAlloc.dsn
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' & m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call tsoClose m.m.dd
call tsoFree m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = oNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, var)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlDiv begin **************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, cx, tBef, tAft, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar == 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.flds = ''
m.ff.sqlX = cx
call fTabReset ff, tBef, tAft
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return
endProcedure sqlFTabReset
/*--- set a defaultFormat for type tx in fTab ff ---------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
sqlFTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
if word(m.m.set.sx, 1) == c1 & sx <= m.m.set.0 then do
parse var m.m.set.sx c1 aDone
f1 = m.m.set.sx.fmt
l1 = m.m.set.sx.label
end
end
cx = m.m.sqlX
kx = sqlCol2kx(cx, c1)
if kx == '' then
call err 'colName not found' c1
do tx=2 to arg()-3
if arg(tx+3) \== '' then
call fTabAddTit m, tx, arg(tx+3)
end
if f1 \== '' then do
if right(f1, 1) \== ' ' then
f1 = f1' '
return fTabAdd(m, c1 aDone, f1, l1)
end
ty = m.sql.cx.d.kx.sqlType
le = m.sql.cx.d.kx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f2 = m.m.sql2fmt.ty
if f2 == 'c' then
f2 = '%-'min(le, m.m.maxChar)'C'
else if f2 == 'd' then do
trace ?r
pr = le % 256
de = le // 256
f2 = '%'pr'.'de'i'
end
if \ abbrev(f2, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f2
return fTabAdd(m, c1 aDone, f2' ', l1)
endProcedure sqlFTabAdd
sqlFTabOthers: procedure expose m.
parse arg m, doNot
cx = m.m.sqlX
call sqlRxFetchVars cx
do kx=1 to m.sql.cx.d.sqlD
c1 = m.sql.cx.col.kx
wx = wordPos(c1, m.m.cols)
if (wx < 1 | m.m.wx.done \== 1) & wordPos(c1, doNot) < 1 then
call sqlFTabAdd m, m.sql.cx.col.kx
end
return
endProcedure sqlFTabOthers
sqlFTab: procedure expose m.
parse arg m
call fTabBegin m
do while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out f(m.m.fmt, 'sqlFTab')
end
return fTabEnd(m)
endProcedure sqlFTab
sqlFTabCol: procedure expose m.
parse arg m
do rx=1 while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out left('--- row' rx '', 100, '-')
call fTabCol m, 'sqlFTab'
end
call out left('--- end of' (rx-1) 'rows ', 100, '-')
return
endProcedure sqlFTabCol
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
deleteSqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
tstCatTb:
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call tstEnd t
return
endProcedure tstCatTb
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabReset ft, cx, 'c 1', '1 c', 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , '%-12H'
call FTabSet ft, 'RBA1' , '%-12H'
call FTabSet ft, 'RBA2' , '%-12H'
call FTabSet ft, 'START_RBA' ,'%-12H'
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlPreOpen cx, sq
call sqlFTabOthers ft
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlRxClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql.conDbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
stops = '(select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
call out int || substr(sq, cx, nx-cx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
return sq
endProcedure sqlCatIXStats
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
', timestamp(rba1 || x''0000'') rba1Tst' ,
', timestamp(rba2 || x''0000'') rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , '%-12H'
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , '%-12H'
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
return sq
endProcedure sqlCatTables
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , '%-12H', 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
return sq
endProcedure sqlCatTSStats
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFlds(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = substr(m.ff.fx, 2)
v = m.m.f1
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut.alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 | vx = 0 then do
l1 = min(60, vx)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/* copy sqlDiv end **************************************************/
/* copy db2Cat begin **************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'", ,'')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq, colName, ordering" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlPreOpen 1, sql
res = ''
do kx=1 while sqlFetchInto(1, ':sq, :col, :ord')
if sq \= kx then
call err 'expected' kx 'but got colSeq' sq ,
'in index' cr'.'ix'.'col
res = res || strip(col) || translate(ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlPreOpen 1, sql
pr = ' '
do kx=1 while sqlFetchInto(1, ':na, :ty, :nu, :de, :nn')
/* say kx na ty nu de 'nn' nn */
if pos('CHAR', ty) > 0 then
dv = "''"
else if pos('INT' ,ty) > 0 | wordPos(ty, 'REAL FLOAT') > 0 then
dv = 0
else if ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', ty) > 0 then
dv = ty"('')"
else
dv = '???'
if nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if ty = 'ROWID' then do
r = '--'
end
else if nn == 'new' then do
if de = 'Y' then
r = '--'
else if nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if nu = 'Y' | (nu = nn) then
r = ''
else
r = 'coalesce('na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' ty 'in' tCr'.'tTb'.'na
call out r na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end **************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
call jIni
m.sqlO.cursors = left('', 200)
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk, resTy)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, retOk,resTy)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, retOk, resTy)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, retOk,resTy)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlOIni
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
hst = ''
cTy = 'Rx'
end
if m.sql.conType==cTy & m.sqlHost==hst & m.sqlconDbSYs == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
else
m.sql.conDbSys = sys
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conDbSys = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, resTy
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
endProcedure sqlCall
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if (sub == '' & m.sql.conDbSys== '') ,
| (sub \== '' & m.sql.conDbSys \== sub) then
call sqlConnect sub
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
dlm = ';'
isStr = oStrOrObj(sqlSrc, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call scanSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
if translate(left(s1, 10)) == 'TERMINATOR' then do
dlm = strip(substr(s1, 11))
if length(dlm) \== 1 then
call scanErr sqlStmts, 'bad terminator' dlm
iterate
end
call outSt(splitNl(sqlTmp, sqlStmt(s1, retOk, opt)))
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = m.sql.sqlHaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk, opt
src = inp2Str(src)
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then
return sqlMsgLine( , upds, src, coms 'commits')
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ut2Lc(fun)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut.alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%qn %S'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlReset crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec 'describe cursor c'crs 'into :m.sql.'crs'.D'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%qn v, f %s')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = oNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/* copy sqlO end **************************************************/
/* copy sqlC begin ***************************************************
sql interface Compatibility mode
***********************************************************************/
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
m.sql.cx.type = ''
res = sqlPrepare(cx, src, ggRetOk, descOut)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
if arg() >= 4 then do
call sqlDescribeInput ggCx
do ggAx=4 to arg()
call sqlDASet ggCx, 'I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx use)
end
else do
ggRes = sqlOpen(ggCx)
end
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlRxClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
endProcedure sqlOpAllCl
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecStmt:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
if ggAx > 1 then
call sqlDescribeInput ggCx
do ggAx=2 to arg()
call sqlDASet ggCx, 'I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure execStmt
/*--- execute immediate the sql src ----------------------------------*/
/* copy sqlC end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conDbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call err 'csmappc rc' rc
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, retOk, resTy, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
f = ''
if resTy \== '' then do
f = oClaMet(class4Name(resTy), 'oFlds')
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.kx
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql.defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql.ini = 1
m.sql.conType = ''
m.sql.conDbSys = ''
m.sql.conhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
/* else if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
*/ else
call err 'no default subsys for' sysvar(sysnode)
m.sql.conDbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conDbSys = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk, resTy
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
m.sql.cx.type = resTy
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = m.sql.defCurs
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlRxClose cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = m.sql.defCurs
call sqlQuery cx, src
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlRxClose cx
if \ f1 then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if f2 then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sql2One
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
return
endProcedue sqlReset
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, retOk, descOut
src = inp2str(src, '%qn%s ')
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlReset cx
return sqlExec('prepare s'cx s 'from :src', retOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx us
if us == '' then do
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlExePreSt: procedure expose m.
parse arg cx retOk
if arg() <= 1 then
return sqlExec('execute s'cx, retOk)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
endProcedure sqlExePreSt
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
f = m.sql.cx.type
m.sql.cx.sqlNull.0 = 0
if abbrev(f, ':') then
return mPut(sql.cx.fetchVars, f)
call sqlDescribeOutput cx
if f \== '' then do
f = class4Name(f)
m.sql.cx.type = f
f = oClaMet(f, 'oFlds')
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
m.sql.cx.col2kx.cn = kx
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlRxFetchVars cx
if symbol('M.SQL.CX.COL2KX.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col2kx.nm
if m.sql.cx.col.kx == nm then
return kx
drop m.sql.cx.col.kx
return ''
endProcedure sqlCol2kx
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('sqlVarName.sNa') == 'VAR' then
sNa = 'COL'kx
sqlVarName.sNa = 1
return sNa
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql.sqlHaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if sqlCode == -204 & wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & verb=='DROP' ,
& wordPos('rod', retok) > 1 then do
hahi = m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql.sqlHaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' m.sql.conDbSys ,
|| ', host =' m.sql.conHost', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut.alfRexN1) > 0 then
iterate
ex = verify(src, m.ut.alfRex, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut.alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
/* say fi '=??? <'m.o.fi'>' c2x(m.o.fi) */
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, retOk
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysTo = '*' then do
old = sysDsn("'"dsnTo"'")
end
else if sysFr = '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call tsoFree word(alRes, 2)
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
csmRc = adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , retOk)
if sysTo = '*' & old <> 'OK' then do
/* csm normally does not set mgmtclass - avoid delete | */
call adrTso "ALTER '"dsnTo"' mgmtclas(COM#A091)"
end
return csmRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if disp = 'NEW' and nn \== '' then
a2 = a2 dsnCreateAtts( , nn, 1)
if retRc <> '' | nn = '' then
return adrCsm('allocate' al a2 rest, retRc)
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return 0
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 11
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt=opt'
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', p.
call tsoClose rmtsPrt
say p.0 'tso output lines'
do px=1 to p.0
say ' ' strip(p.px, 't')
end
call err ee
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/* copy csm end *******************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'o' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'a' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy csv begin *****************************************************/
csvIni: procedure expose m.
if m.csv.ini == 1 then
return
m.csv.ini = 1
call jIni
call classNew "n CsvRdr u JRWO, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvRdrOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvRdr'"
call classNew "n CsvRdrR u CsvRdr", "m",
, "jReadO return csvRdrReadO(m)"
call classNew "n CsvWrt u JRW, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvWrtOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvWrt'"
call classNew "n CsvWrtR u CsvWrt", "m",
, "jRead return csvWrtRead(m, var)"
return
endProcedure csvIni
/*--- create a new csvRdr --------------------------------------------*/
csvRdr: procedure expose m.
parse arg rdr
return jReset(oNew('CsvRdr'), rdr)
endProcedure csvRdr
/*--- open csvRdr: read first line and create dataClass --------------*/
csvRdrOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
if jRead(m.m.rdr, m'.LINE') then do
ff = 'f' repAll(m.m.line, ',', ' v, f ') 'v'
m.m.class = classNew("n* CsvF u" ff)
end
call oMutatName m, 'CsvRdrR'
return
endProcedure csvRdrOpen
/*--- read next line and return derived object -----------------------*/
csvRdrReadO: procedure expose m.
parse arg m
do until m.m.line <> ''
if \ jRead(m.m.rdr, m'.LINE') then
return ''
end
var = oNew(m.m.class)
ff = oClaMet(m.m.class, 'oFlds')
s = m'.SCAN'
call scanSrc s, m.m.line
do fx=1
f1 = substr(m.ff.fx, 2)
if scanString(s, '"') then
m.var.f1 = m.s.val
else do
call scanUntil s, ','
m.var.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
if fx <> m.ff.0 then
call scanerr s, 'csv cla' m.ff.0 'fields but' cx 'in line'
return var
endProcedure csvRdrReadO
/*--- create a new csvRdr --------------------------------------------*/
csvWrt: procedure expose m.
parse arg rdr
return jReset(oNew('CsvWrt'), rdr)
endProcedure csvWrt
/*--- open csvRdr: read first line and create dataClass --------------*/
csvWrtOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
m.m.class = ''
m.m.o1 = ''
call oMutatName m, 'CsvWrtR'
return
endProcedure csvWrtOpen
/*--- read next line and return derived object -----------------------*/
csvWrtRead: procedure expose m.
parse arg m, var
if m.m.o1 == '' then
i1 = jReadO(m.m.rdr)
else do
i1 = m.m.o1
m.m.o1 = ''
end
if i1 == '' then
return 0
if m.m.class == '' then do
m.m.class = objClass(i1)
m.m.o1 = i1
t = ''
ff = oFlds(i1)
do fx=1 to m.ff.0
t = t','substr(m.ff.fx, 2)
end
m.var = substr(t, 2)
return 1
end
else do
t = ''
ff = oFlds(i1)
do fx=1 to m.ff.0
f1 = i1 || m.ff.fx
val = m.f1
if pos(',', val) > 0 | pos('"', val) > 0 then
t = t','quote(val, '"')
else
t = t','val
end
m.var = substr(t, 2)
return 1
end
endProcedure csvWrtRead
/* copy csv end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then
return jCatSql(m, substr(fmt, 5))
else
fmt = '%s%qn %s%qe%q^'fmt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%Qn', m.line)
end
call jClose m
return res || f(fmt'%Qe')
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if m.m.src == '' then
m.m.src = ' '
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
sta = 'tt'
res = ''
do forever
do while scanSBEnd(m)
if \ jCatSqlNl(m) then
return strip(res)
end
bx = m.m.pos
sta = scanSql2Stop(m, sta, stop)
s1 = left(sta, 1)
if pos(s1, stop) > 0 then do
if res <> '' then
return strip(res)
end
else if s1 == '-' | s1 == '/' then
res = res' '
else if pos('/', sta) = 0 then
res = res || substr(m.m.src, bx, m.m.pos - bx)
end
/*-------- ?????????????????????
jCatSqlNext?: procedure expose m.
parse arg m, stop
res = ''
bx = m.m.pos
do forever
call scanUntil m, '"''-/'stop
if scanSBEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if scanLit(m, "'", '"') then do
c1 = m.m.tok
do while \ scanStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call scanChar m, 1
if res <> '' then
return strip(res)
bx = m.m.pos
end
else if \ scanLit(m, '-', '/') then do
call err 'bad char at' substr(m.m.src, m.m.pos) 'in' m.m.src
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return strip(res)
end
endProcedure jCatSqlNext
??????????????*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new return jReset("m.class.basicNew", arg, arg2, arg3)",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new return jReset("m.class.basicNew", arg)",
, "jRead return jRead(m.m.deleg, var)" ,
, "jReadO return jReadO(m.m.deleg)" ,
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.errRead = "return err('jRead('m',' var') but not opened r')"
m.j.errReadO = "return err('jReadO('m',' var') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutatName m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m, var)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m, var)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if oClaInheritsOf(ggCla, 'JBuf') & m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutatName m, 'JBufSR'
else
call oMutatName m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutatName m, 'JBufSW'
else
call oMutatName m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutatName m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return m.m.buf.nx
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return s2o(m.m.buf.nx)
endProcedure jBufSReadO
jBufORead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.var = m.m.buf.nx
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allS \== 1 then
call err '1 \== allS' m.m.allS 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = oFlds(ref)
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
if the parent is class OLazyMet, a methof found there is
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o.ini == 1 then
return
m.o.ini = 1
call mIni
m.o.escW = '!'
m.o.lazyGen = 'OLazyMetGen' /* lazy method generator */
call oAddCla m.o.lazyGen
return
endProcedure oIni
/*--- return whether cl is a currently defined class ----------------*/
oIsCla: procedure expose m.
parse arg cl
return symbol('m.o.cParent.cl') == 'VAR'
endProcedure oIsCla
/*--- add class cl with the given parents ---------------------------*/
oAddCla: procedure expose m.
parse arg cl, parents
if verifId(cl, '.') > 0 | pos('.', cl) <> lastPos('.', cl) then
call err 'bad class name' cl 'in oAddCla('cl',' parents')'
if oIsCla(cl) then
call err 'duplicate class' cl 'in oAddCla('cl',' parents')'
do px=1 to words(parents)
if \ oIsCla(word(parents, px)) then
call err word(parents, px) 'is no class' ,
'in oAddCla('cl',' parents')'
end
m.o.cParent.cl = parents
return
endProcedure oAddCla
/*--- add to class cl method met ------------------------------------*/
oAddMet: procedure expose m.
parse arg cl, met, cont
if \ oIsCla(cl) then
call err 'undefined class' cl 'in oAddMet('cl',' met',' cont')'
if symbol('m.o.cMet.cl.met') == 'VAR' then
call err 'duplicate method' met 'in oAddMet('cl',' met',' cont')'
m.o.cMet.cl.met = cont
return
endProcedure oAddMet
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
interpret oClaMet(cl, 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o.escW) then
return m.class.classW
else if arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return oClaInheritsOf(cl, sup)
endProcedure oKindOf
oClaInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
if symbol('m.o.cParent.sup') \== 'VAR' then
sup = class4name(sup)
if cl == sup then
return 1
do sx=1 to words(m.o.cParent.cl)
if oClaInheritsOf(word(m.o.cParent.cl, sx), sup) then
return 1
end
return 0
endProcedure oClaInheritsOf
/*--- return the code of method me of object m
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o.escW) then
ggClass = "w"
else if arg() >= 3 then
return arg(3)
else
return err('no class found for object' m)
if symbol('m.o.cMet.ggClass.me') == 'VAR' then
return m.o.cMet.ggClass.me
code = oClaMet(ggClass, me, '---')
if code \== '---' then
return code
else if arg() >= 3 then
return arg(3)
return err('no method' me 'in class' className(ggClass) ,
'of object' m)
endProcedure objMet
oClaMet: procedure expose m.
parse arg cl, me
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
if \ oIsCla(cl) then do
c2 = class4Name(cl, '')
if c2 \== '' & oIsCla(c2) then do
cl = c2
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
end
else do
if arg() >= 3 then
return arg(3)
else
return err('no class' cl 'in oClaMet('cl',' me')')
end
end
code = oLazyMetGen(m.o.lazyGen, cl, me)
do px = 1 to words(m.o.cParent.cl) while code == '---'
code = oClaMet(word(m.o.cParent.cl, px), me, '---')
end
if code == '---' then do
if arg() >= 3 then
return arg(3)
else
return err('no met' me 'in class' cl)
end
m.o.cMet.cl.me = code
return code
endProcedure oClaMet
oLazyMetGen: procedure expose m.
parse arg lg, cl, me
if symbol('m.o.cMet.lg.me') \== 'VAR' then
return '---'
interpret m.o.cMet.lg.me
endProcedure oLazyMetGen
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oPrint: procedur expose m.
parse arg m
ff = oFlds(m)
t = ''
do fx=1 to m.ff.0
f1 = m || m.ff.fx
t = t',' substr(m.ff.fx, 2)'='m.f1
end
return m'='className(objClass(m))'('substr(t, 3)')'
endProcedure oPrint
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.o.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
oClaClear: procedure expose m.
parse arg cla, m
interpret "drop cla;" oClaMet(cla, 'oClear')
return m
endProcedure oClaClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
call oClaMet cl, 'oFlds'
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = oNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" oClaMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.class.in2 = 0
call oIni
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
m.class.basicNew = "oMutate(mNew(cl), cl)"
call oAddMet m.o.lazyGen, 'new', "return classGenNew(cl, me)"
call oAddMet m.o.lazyGen,'oClear',"return classGenClear(cl, me)"
call oAddMet m.o.lazyGen,'oFlds',"return classGenFlds(cl, me)"
call oAddMet m.o.lazyGen, 'oCopy', "return classGenCopy(cl, me)"
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classFinish cr
call oClaMet cr, 'oFlds' /* generate flds */
end
m.class.in2 = 1
call oAddMet m.class.classV, 'oCopy', "return oCopyV(m, t)"
call classAddMet m.class.classV, 'o2String return m.m'
call classAddMet m.class.classW, 'o2String return substr(m, 2)'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if isNew & m.class.in2 then
call classFinish n
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
return n
endProcedure classNew
/*--- to the finish for new class cl -------------------------------*/
classFinish: procedure expose m.
parse arg cl, force
call oMutate cl, m.class.class
/* find super and sub classes */
m.cl.sub = ''
sups = ''
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 \== 'u' then
iterate
if wordPos(u1, sups) > 0 then
call err u1 'already in sups' sups': classSuperSub('cl')'
sups = sups u1
if wordPos(m.cl.SUB, cl) > 0 | symbol('m.u1.sub') \== 'VAR' then
call err cl 'is already in' u1'.sub' u1.SUB ,
|| ': classSuperSub('cl')'
m.u1.sub = strip(m.u1.sub cl)
end
m.cl.super = sups
/* add class to o */
call oAddCla cl, sups
if pos(m.cl, 'mfrsv') < 1 then do
allMets = ''
forceMets = ''
do cx=1 to m.cl.0
ch = m.cl.cx
if m.ch == 'm' then do
call oAddMet cl, m.ch.name, m.ch.met
allMets = allMets m.ch.name
end
else if symbol('m.class.forceDown.ch') == 'VAR' then
forceMets = forceMets m.class.forceDown.ch
end
myForce = ''
do fx=1 to words(forceMets)
parse value word(forceMets, fx) with fCla '#' fMet
if wordPos(fMet, allMets) < 1 then do
call oAddMet cl, fMet, m.o.cMet.fCla.fMet
myForce = myForce cl'#'fMet
allMets = allMets fMet
end
end
if myForce \== '' then
m.class.forceDown.cl = strip(myForce)
end
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object addresses */
call mNewArea cl, 'O.'substr(cl,7)
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
return
endProcedure classFinish
classAddMet: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
call mAdd cl, classNew('m' met code)
call oAddMet cl, met, code
return cl
endProcedure classAddMet
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
classGenNew: procedure expose m.
parse arg cl, met
return "m=" m.class.basicNew";" oClaMet(cl, 'oClear') ";" ,
"return m"
endProcedure classGenNew
classGenFlds: procedure expose m.
parse arg cl, met
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classGenFldsAdd cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
return cl'.FLDS'
endProcedure classGenFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classGenFldsAdd: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classGenFldsAdd(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classGenFldsAdd(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classGenFldsAdd f, m.cl.tx, nm
end
return 0
endProcedure classGenFldsAdd
classGenClear: procedure expose m.
parse arg cl, met
r = ''
call oClaMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
r = r classGenStmt(f1, "m.m~ = '"m.o.escW"';")
else
r = r classGenStmt(f1, "m.m~ = '';")
end
do sx=1 to m.cl.stms.0
r = r classGenStmt(m.cl.stms.sx, "m.m~.0 = 0;")
end
return r
endProcedure classGenClear
classGenStmt: procedure expose m.
parse arg f, st, resWo
isNice = translate(f) == f
resWo = translate(resWo) 'GGFF M'
fDod = '.'f'.'
do wx=1 to words(resWo) while isNice
isNice = pos('.'word(resWo, wx)'.', fDot) < 1
end
if isNice then
return repAll(st, '~', f)
else
return "ggFF = '"substr(f, 2)"';" repAll(st, '~', '.ggFF')
endProceduer classGenAss
classGenCopy: procedure expose m.
parse arg cl, me
r = repAll("if t == '' then t =" m.class.basicNew ";" ,
"else call oMutate t, cl;", 'cl', "'"cl"'")
ff = oClaMet(cl, 'oFlds') /* build code for copy */
do fx=1 to m.cl.flds.0
r = r classGenStmt(m.cl.flds.fx, 'm.t~ = m.m~;', 't')
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == '' then
st = ''
else do
r = r "st = '"substr(nm, 2)"';"
st = '.st'
end
r = r "m.t"st".0 = m.m"st".0;" ,
"do sx=1 to m.m"st".0;" ,
"call oClaCopy '"sc"', m"st".sx, t"st".sx; end;"
end
return r 'return t;'
endProcedure classGenCopy
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class.classV)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut.alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mNew
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
if tx < fx then
return ''
fmt = '%s%qn%s%qe%q^'fmt
res = f(fmt, m.st.fx)
do sx=fx+1 to tx
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCatFT
mIni: procedure expose m.
if m.m.ini == 1 then
return
m.m.ini = 1
call utIni
m.mBase64 = m.ut.alfUC || m.ut.alfLc || m.ut.digits'+-'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy fTab begin ****************************************************/
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft
m.m.generated = ''
m.m.0 = 0
m.m.len = 0
m.m.cols = ''
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
m.m.set.0 = 0
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
return m
endProcedure fTabReset
/* add a piece to title tx at current pos */
fTabAddTit: procedure expose m.
parse arg m, tx, t1
m.m.generated = ''
m.m.tit.tx = left(m.m.tit.tx, m.m.len) || t1
return m
endProcedure fTabAddTit
/*--- set the infos for one column -----------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, l1
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.label = l1
m.m.set.c1 = sx
return
endProcedure fTabSet
fTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
cx = m.m.0 + 1
m.m.generated = ''
m.m.0 = cx
m.m.cols = m.m.cols c1
if words(m.m.cols) <> cx then
call err 'mismatch of column number' cx 'col' c1
if length(aDone) > 1 | wordPos('<'aDone'>', '<> <0> <1>') < 1 then
call err 'bad done' length(aDone) '<'aDone'> after c1' c1
m.m.cx.col = c1
m.m.cx.done = aDone \== 0
if l1 == '' then
m.m.cx.label = c1
else
m.m.cx.label = l1
px = pos('%', f1)
ax = pos('@', f1)
if px < 1 | (ax > 0 & ax < px) then
m.m.cx.fmt = f1
else
m.m.cx.fmt = left(f1, px-1)'@'c1 || substr(f1, px)
m.fTabTst.c1 = m.m.cx.label
t1 = f(f1, m.m.cx.label)
if pos(strip(t1), m.m.cx.label) < 1 then
t1 = left(left('', max(0, verify(t1, ' ') -1))m.m.cx.label,
, length(t1))
m.m.cx.len = length(t1)
call fTabAddTit m, 1, t1
do tx=2 to arg()-3
if arg(tx+3) \== '' then
call fTabAddTit m, tx, arg(tx+3)
end
m.m.len = m.m.len + length(t1)
return m
endProcedure fTabAdd
fTabGenerate: procedure expose m.
parse arg m
f = ''
do kx=1 to m.m.0
f = f || m.m.kx.fmt
end
m.m.fmt = m'.fmtKey'
call fGen f, m.m.fmt
cSta = m.m.tit.0+3
do cEnd=cSta until kx > m.m.0
cycs = ''
do cx=cSta to cEnd
m.m.tit.cx = ''
cycs = cycs cx
end
cx = cSta
ll = 0
do kx=1 to m.m.0 while length(m.m.tit.cx) < max(ll,1)
m.m.tit.cx = left(m.m.tit.cx, ll)m.m.kx.col
cx = cx + 1
if cx > cEnd then
cx = cSta
ll = ll + m.m.kx.len
end
end
m.m.cycles = strip(cycs)
m.m.tit.1 = translate(lefPad(m.m.tit.1, m.m.len), '-', ' ')'---'
m.m.generated = m.m.generated't'
return
endProcedure fTabGenerate
fTabColGen: procedure expose m.
parse arg m
do kx=1 to m.m.0
l = if(m.m.kx.label == m.m.kx.col, , m.m.kx.label)
f = lefPad(l, 10) lefPad(m.m.kx.col, 18)
if length(f) > 29 then
if length(l || m.m.kx.col) < 29 then
f = l || left('', 29 - length(l||m.m.kx.col))m.m.kx.col
else
f = lefPad(strip(l m.m.kx.col), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabColGen
fTab: procedure expose m.
parse arg m
call fTabBegin m
do forever
i = inO()
if i == '' then
leave
call out f(m.m.fmt, i)
end
return fTabEnd(m)
endProcedure fTab
fTabCol: procedure expose m.
parse arg m, i
if pos('c', m.m.generated) < 1 then
call fTabColGen m
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenerate m
return fTabTitles(m, m.m.titBef)
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/* copy fTab end ****************************************************/
/* copy f begin *******************************************************/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f.fmt.ggFmt') == 'VAR' then
interpret M.f.fmt.ggFmt
else
interpret fGen(ggFmt)
endProcedure f
fAll: procedure expose m.
parse arg fmt
do forever
o = inO()
if o == '' then
return
call out f(fmt, o)
end
endProcedure f
/*--- format character2hex (if not sql null) -------------------------*/
fH: procedure expose m.
parse arg v, l
if v \== m.sqlNull then
v = c2x(v)
if l >= 0 then
return right(v, l)
else
return left(v, -l)
endProcedure fH
/*--- format integer or fixPoint Decimal -----------------------------*/
fI: procedure expose m.
parse arg v, l, d
if datatype(v, 'n') then do
if d == '' then
v = format(v, ,0,0)
else
v = format(v, ,d,0)
if abbrev(l, '+') then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > abs(l) then
return right('', abs(l), '*')
end
if l >= 0 then
return right(v, l)
else
return left(v, -l)
endProcedure fI
/*--- format floating point in E notitaion ---------------------------*/
fE: procedure expose m.
parse arg v, l, d, eChar
if eChar == '' then
eChar = 'e'
if \ datatype(v, 'n') then
return left(v, l)
else if l = 7 then
return fEStrip(format(v, 2, 2, 2, 0), 0, 2, 0, 2, eChar)
else if l = 8 then
return fEStrip(format(v, 2, 2, 2, 0), 1, 2, 0, 2, eChar)
else if l < 7 then
call err 'bad width fE('v',' l',' d')'
else if d == '' then
return fEStrip(format(v, 2, l-6, 2, 0), 1, l-6, 0, 2, eChar)
else if l - d - 5 < 1 then
call err 'bad prec fE('v',' l',' d')'
else
return fEStrip(format(v, 2, d, l-d-5, 0), 1, d, 1, l-d-5, eChar)
endProcedure fE
fEStrip: procedure expose m.
parse arg v, mSi, de, eSi, ePr, eChar
parse var v ma 'E' ex
if ex == '' then do
ma = strip(ma, 't')
ex = '+'left('', ePr, 0)
end
if eSi == 0 then do
if abbrev(ex, '+') then
ex = substr(ex, 2)
else if abbrev(ex, '-0') then
ex = '-'substr(ex, 3)
else do
exO = ex
ex = left('-9', ePr, '9')
/* say 'format('ma '* (1E'exO') / (1E'ex'), 2,' de', 0)' */
ma = format(ma * ('1E'exO) / ('1E'ex), 2, de, 0)
end
end
if mSi == 0 then
if abbrev(ma, ' ') then
ma = substr(ma, 2)
else
ma = format(ma, 2, de-1)
r = ma || eChar || ex
if length(r) - length(eChar) <> 2 + mSi + de + eSi + ePr then
call err 'bad fEStrip('v',' mSi',' de',' eSi',' ePr',' eChar ,
|| ') ==>' r 'bad len' length(r)
return r
endProcedure fEStrip
/*--------------------------------------------------------------------
fGen: Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
+ \s a single space
+ \n a newLine
+ \% \@ \\ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character a
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- d or i Signed decimal integer
- e Scientific notation (mantissa/exponent) using e character 3.9265e+2
- E Scientific notation (mantissa/exponent) using E character 3.9265E+2
- f Decimal floating point
- g Use the shorter of %e or %f
- G Use the shorter of %E or %f
- h Characters in hex
- o Unsigned octal 610
- S Strip(..., both)
- u Unsigned decimal integer
- x Unsigned hexadecimal integer
- X Unsigned hexadecimal integer (capital letters)
- p Pointer address
- n Nothing printed. The argument must be a pointer to a signed int, wh
+ % A % followed by another % character will write % to stdout. %
+ Q for iterator first nxt end
Flags:
- - Left-justify within the given field width; Right justification is
- + Forces to precede the result with a plus or minus sign (+ or -)
- (space) If no sign is going to be written, a blank space is inserte
- # Used with o, x or X specifiers the value is preceeded with 0, 0x
force decimalpoint ...
- 0 Left-pads the number with zeroes (0) instead of spaces, where pad
+ = reuse previous input argument
length not implemented
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg src, key
if key == '' then do
qSuf = right(src, 3)
if length(qSuf) == 3 & abbrev(qSuf, '%Q') then
s2 = left(src, length(src) - 3)
else
s2 = src
call fGen s2, s2
if symbol('m.f.fmt.src') == 'VAR' then
return m.f.fmt.src
call err fGen 'format' src 'still undefined'
end
call scanIni
cx = 1
ky = key
do forever
cy = pos('%q', src, cx)
if cy < 1 then do
m.f.fmt.ky = fGenCode(substr(src, cx), 'F.INFO.'ky)
leave
end
m.f.fmt.ky = fGenCode(substr(src, cx, cy-cx), 'F.INFO.'ky)
if substr(src, cy, 3) == '%q^' then do
if substr(src, cy, 5) == '%q^%q' then
cy = cy+3
else if length(src) = cy + 2 then
leave /* do not overrite existing fmt | */
end
if cy > length(src)-2 then
call err 'bad final %q in' src
if substr(src, cy, 3) == '%q^' then
ky = key
else
ky = key'%Q'substr(src, cy+2, 1)
m.f.tit.ky.0 = 0
cx = cy+3
end
if symbol('m.f.fmt.key') == 'VAR' then
return m.f.fmt.key
call scanErr fGen 'format' src 'still undefined'
endProcedure fGen
fGenCode: procedure expose m.
parse arg aS, jj
jx = 0
call scanSrc fGen, aS
call scanSrc fGen, aS
ax = 0
cd = ''
do forever
txt = fText()
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(fGen) then do
m.jj.0 = jx
if cd \== '' then
return "return" substr(cd, 4)
else
return "return ''"
end
an = ''
af = '-'
if \ scanLit(fGen, '@') then do
ax = ax + 1
end
else do
if scanWhile(fGen, '0123456789') then
ax = m.fGen.tok
else if ax < 1 then
ax = 1
if substr(m.fGen.src, m.fGen.pos, 1) \== '%' then do
call scanLit fGen, '.'
af = fText()
end
end
if \ scanLit(fGen, '%') then
call scanErr fGen, 'missing %'
call scanWhile fGen, '-+'
flags = m.fGen.tok
call scanWhile fGen, '0123456789'
len = m.fGen.tok
siL = len
if len \== '' & flags \== '' then
siL = left(flags, 1)len
prec = ''
if scanLit(fGen, '.') then do
if len == '' then
call scanErr fGen, 'empty len'
call scanWhile fGen, '0123456789'
prec = m.fGen.tok
end
call scanChar fGen, 1
sp = m.fGen.tok
if ax < 3 then
aa = 'ggA'ax
else
aa = 'arg(' || (ax+1) || ')'
if af \== '-' then do
if af \== '' then
af = '.'af
if abbrev(aa, 'ggA') & pos('.GG', af) < 1 ,
& translate(af) == af then
aa = 'm.'aa || af
else
aa = 'mGet('aa '||' quote(af, "'")')'
end
if sp = 'c' then do
pd = word('rigPad lefPad', (pos('-', flags) > 0)+1)
if prec \== '' then
cd = cd '||' pd'(substr('aa',' prec'),' len')'
else
cd = cd '||' pd'('aa',' len')'
end
else if sp = 'C' then do
if prec \== '' then
cd = cd '|| substr('aa',' prec',' len')'
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa", '"siL"')"
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then do
cd = cd "|| fI("aa", '"siL"'"
if prec == '' then
cd = cd')'
else
cd = cd',' prec')'
end
else if sp == 'E' | sp == 'e' then
cd = cd "|| fE("aa"," len"," prec", '"sp"')"
else if sp == 's' then
cd = cd '||' aa
else if sp = 'S' then
cd = cd '|| strip('aa')'
else
call scanErr fGen, 'bad specifier' sp
jx = jx + 1
m.jj.jx.arg = ax
m.jj.jx.name = af
end
endProcedure fGenCode
fText: procedure expose m. ft.
res = ''
do forever
if scanUntil(fGen, '\@%') then
res = res || m.fGen.tok
if \ scanLit(fGen, '\') then
return res
call scanChar fGen, 1
if pos(m.fGen.tok, 's\@%') < 1 then
res = res'\' || m.fGen.tok
else
res = res || translate(m.fgen.tok, ' ', 's')
end
endProcedure fText
/* copy f end *******************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut.ini == 1 then
return
m.ut.ini = 1
m.ut.digits = '0123456789'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
m.ut.alfNum = m.ut.alfa || m.ut.digits
m.ut.alfDot = m.ut.alfNum || '.'
m.ut.alfId = m.ut.alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut.alfIdN1 = m.ut.digits /* not as first character */
m.ut.alfRex = m.ut.Alfa'.0123456789@#$?' /* charset puff mit ¬*/
m.ut.alfRexN1= '.0123456789'
m.ut.alfPrint = m.ut.alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut.alfLc, m.ut.alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut.alfIdN1) > 0 then
return 1
else
return verify(src, m.ut.alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
tstUtc2d: procedure expose m.
numeric digits 33
say c2d('ffffff'x)
say utc2d('ffffff'x)
say utc2d('01000000'x) 256*256*256
say utc2d('01000001'x)
say utc2d('020000FF'x) 256*256*256*2+255
say utc2d('03020000EF'x) 256*256*256*770+239
return
endProcedure tstUtc2d
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(ELARGEN) cre=2013-11-29 mod=2015-01-06-11.40.45 A540769 ---
$#:
* WSH Script fuer ElarDDL generate ddl execution jobs
*
*
lib = XB.ELAR.INFRA.FAM.NDBS.FINAL $** ddl input
lib = DSN.ELAR.GENPROD
gen = DSN.ELAR.GENDDL $** generiert jobs
gen = A540769.TST.ELAR $** generiert jobs
$** chkOut = DSN.ELAR.GENDDL.CHKOUT
creDb = 0 $** create databases if missing
dbSys = DEVG
rxLib = DSN.DB2.EXEC
$<>
$>. fEdit($-gen'(XBDDLEXE) ::f')
$@ddlExe
$<>
$*(
$>. fEdit($-gen'(XBDDLCHK) ::f')
$@ddlChk
$*)
$proc $@/ddlExe/
$= dbEx = 1
$= jn = XBDDLEXE
if $creDb then $@¢
call sqlConnect $dbSys
call sqlQueryPrep 7, "select name from sysibm.sysDatabase" ,
"where name = ?"
$!
$;
lmmId = lmmBegin($lib)
allDb = ''
$do mx=1 to 9999 $@¢
mbr = lmmNext(lmmId)
if mbr = '' then
leave
call readDsn "'"$lib"("mbr")'", i.
db = ''
cnt = 0
cCA = 0
do ix=1 to i.0
li = translate(i.ix)
cCA = cCA + (wordPos('CREATE', li) > 0) ,
+ (wordPos('ALTER', li) > 0)
if wordPos('IN', li) > 0 then do
nd = word(li, wordPos('IN', li) + 1)
nd = word(translate(nd, ' ', '.'), 1)
if nd = '' then
call 'err' mbr ix 'bad in:' i.ix
if db = '' then
db = nd
else if db \== nd then
call err 'db was' db 'but now' nd 'in' mbr ix':'i.ix
cnt = cnt + 1
end
if wordPos('DROP', li) > 0 then do
if abbrev(li, '--') then nop
else if subWord(li, wordPos('DROP', li)-2, 2) ,
== 'RESTRICT ON' then nop
else
call err 'drop in' mbr ix':'i.ix
end
end
if db <> '' & wordPos(db, allDb) < 1 then
allDB = allDb db
if db = '' then
if cCA <> 0 then
call err 'no db found in' mbr
if mx // 20 = 0 then
say mx mbr 'db' db 'cnt' cnt 'cCA' cCA
$=mbr=- mbr
$=db =- db
if $creDb & db <> '' then $@¢
call sqlQueryArgs 7, db
$=dbEx =- sqlFetch(7, ee)
call sqlClose 7
$=mx =- right(mx, 4, 0)
$!
if mx // 50 = 1 then $@=/jc/
//$jn JOB (CP00,KE50),'DB2 ELARDDL',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2
//*MAIN CLASS=LOG
//* ddl execution generiert von dsn.elar.ddlGen(elarGen)
//* im $-¢sysvar(sysNode) 'um' f('%t s')$!
$/jc/
$@=/jcl/
//******** $mx db=$db mbr=$mbr *************************
// IF RC=0 THEN
//S${mx}DDL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- elar createDDl $mx db=$db mbr=$mbr -------------
--#SET MAXERRORS 0
set current sqlid = 'S100447';
$@¢ if \ $dbEx then $@=¢
create database $db
BUFFERPOOL BP2 INDEXBP BP1 CCSID EBCDIC
STOGROUP GSMS4
;
$! $!
// DD DISP=SHR,DSN=$lib($mbr)
// ENDIF
$@/sleep/ if mx // 10 = 0 then $@=¢
// IF RC = 0 THEN
//SLE$mx EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSPROC DD DISP=SHR,DSN=$rxLib
//WSH DD DUMMY
//SYSTSIN DD *
wsh @ call sleep 30
// ENDIF
$! $/sleep/
$/jcl/
$!
call lmmEnd lmmId
$=allDb =- allDb
$/ddlExe/
$proc $@=/ddlChk/
$=jn = XBDDLCHK
//$jn JOB (CP00,KE50),'DB2 ELARDDL',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2
//*MAIN CLASS=LOG
//CLEANUP EXEC PGM=IDCAMS
//SYSPRINT DD SYSOUT=*
//SYSIN DD *
DEL ('DSN.DBX.*.ELARDDL.RQ1') PURGE NOSCRATCH
SET MAXCC = 0
$@do dx=1 to words($allDb) $@=/oneDb/
$= db =- word($allDb, dx)
//******************** $dx $db
//SQL$dx EXEC PGM=IKJEFT01,REGION=0M
//SYSEXEC DD DISP=SHR,DSN=DSN.GENERAL.EXEC
//RXPARM DD DISP=SHR,DSN=DSN.DBX.ELARDDL.SETUP(ELARDDL)
//SYSUDUMP DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD *
%EXECSQL CONNECTID="$dbSys" -
¢TAYLORING! TAYLORING=YES HLQ="DSN.DBX" -
TAYLOR.0=4 -
TAYLOR.1.NAME="&FAMILY" TAYLOR.1.VALUE=NULL -
TAYLOR.2.NAME="&DBNAME" TAYLOR.2.VALUE="'$db'" -
TAYLOR.3.NAME="&CREATE_FROM" TAYLOR.3.VALUE="'10.12.2014'" -
TAYLOR.4.NAME="&CREATE_TO" TAYLOR.4.VALUE="'13.12.9999'"
//*
//* copy to output lib
//*
//COP$dx EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSUT2 DD DISP=SHR,DSN=$chkOut($db)
//SYSUT1 DD DISP=(MOD,DELETE,DELETE),
// DSN=DSN.DBX.&SYSUID..ELARDDL.RQ1
//SYSIN DD DUMMY
$/oneDb/
$/ddlChk/
$#out 20150106 11:40:09
$#out 20150106 11:39:47
*** run error ***
adr ispExec rc 8 in LMINIT DATAID(lmmId) DATASET('XB.ELAR.INFRA.FAM.NDBS.FINAL')
$#out 20141218 10:54:46
*** run error ***
adr ispExec rc 8 in LMINIT DATAID(lmmId) DATASET('XB.ELAR.INFRA.FAM.NDBS.FINAL.N
$#out 20141218 10:43:28
$#out 20141218 10:41:04
}¢--- A540769.WK.REXX(ELARICLU) cre=2010-11-11 mod=2010-11-11-15.07.03 A540769 ---
//A540769T JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//*MAIN CLASS=LOG
//*
//DDL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM(DVBP)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//***PRINT DD DISP=SHR,DSN=A540769.WK.TEXW(PDBGENNJ)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD * DISP=SHR,DSN=A540769.WK.SQL(PDBGENNJ)
SET CURRENT SQLID = 'S100447';
ALTER INDEX BUA.IPDRW003 NOT CLUSTER ;
ALTER INDEX BUA.IDRWIT001 CLUSTER ;
COMMIT ;
DROP INDEX BUA.IPDHA007; -- INDEX BUA.IPDHA006 holds all rel. Columns
COMMIT;
DROP INDEX BUA.IPDHA008; -- INDEX BUA.IPDHA010 HOLDS ALL REL. COLUMNS
commit;
DROP INDEX BUA.IPDHA009; -- INDEX BUA.IPDHA011 HOLDS ALL REL. COLUMNS
COMMIT;
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DVBP,'A540769T.REORG'),
// REGION=0M
//DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=DVBP.DBAA.LISTDEF(TEMPL)
//SYSIN DD *
LISTDEF LST#REO INCLUDE TABLESPACE XBDRW001.SIT002 PARTLEVEL
REORG TABLESPACE LIST LST#REO
LOG NO
SORTDATA
COPYDDN(TCOPYD)
SHRLEVEL CHANGE
MAPPINGTABLE S100447.MAPTAB03
MAXRO 1000
DRAIN ALL
DELAY 300
TIMEOUT TERM
UNLOAD CONTINUE
PUNCHDDN TPUNCH
DISCARDDN TDISCA
NOSYSREC
SORTKEYS
SORTDEVT DISK
SORTNUM 160
STATISTICS
INDEX ALL
REPORT NO
UPDATE ALL
}¢--- A540769.WK.REXX(ELARIDDD) cre=2010-11-10 mod=2010-11-10-16.21.24 A540769 ---
DROP INDEX BUA.IPDHA007; -- INDEX BUA.IPDHA006 holds all rel. Columns
--
COMMIT;
DROP BUA.IPDHA008; -- INDEX BUA.IPDHA010 holds all rel. Columns
commit;
DROP BUA.IPDHA009; -- INDEX BUA.IPDHA011 holds all rel. Columns
COMMIT;
--
}¢--- A540769.WK.REXX(ELARIDDL) cre=2010-07-12 mod=2010-11-11-16.04.25 A540769 ---
-----------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA001 On BUA.XBDHA001PS002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHA001
ON BUA.XBDHA001PS002001
(EA1STRN ASC,
EN1PART ASC)
-- EN1ENTERTAG ASC, /*SKU PS002 table doesnot have column*/
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA002
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA002 On BUA.XBDHA001PS002001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHA002
ON BUA.XBDHA001PS002001
(EA1ATRN ASC)
-- en1entertag ASC)/*SKU PS002 table doesnot have column*/
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA003
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA003 On BUA.XBDHA001IT002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHA003
ON BUA.XBDHA001IT002001
(EA1STRN ASC,
EN1STK1 ASC,
EN1STK2 ASC,
EN1PART ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA004
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA004 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHA004
ON BUA.XBDHA001PS001001
(EA1ATRN ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA005
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA005 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHA005
ON BUA.XBDHA001PS001001
(EN1PAGINATOR ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA006
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA006 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHA006
ON BUA.XBDHA001PS001001
(EN1CIF ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA007
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA007 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA008
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA008 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA009
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA009 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA010
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA010 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHA010
ON BUA.XBDHA001PS001001
(EA1BEZNR ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA011
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA011 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHA011
ON BUA.XBDHA001PS001001
(EA1KNAME ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHA012
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHA001
-- Index=BUA.IPDHA012 On BUA.XBDHA001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHA012
ON BUA.XBDHA001PS001001
(EB1WERT1 ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS1
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY001
-- --
------------------------------------------------------------------------
--
--
------------------------------------------------------------------------
-- Stogroup=GSMS4
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY001 On BUA.XBDHY001PS002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHY001
ON BUA.XBDHY001PS002001
(EA1STRN ASC,
-- en1entertag ASC, does not exist |||
EN1PART ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY002
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY002 On BUA.XBDHY001PS002001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY002
ON BUA.XBDHY001PS002001
(EA1ATRN ASC)
-- en1entertag ASC) does not exist |||
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY003
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY003 On BUA.XBDHY001IT002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHY003
ON BUA.XBDHY001IT002001
(EA1STRN ASC,
EN1STK1 ASC,
EN1STK2 ASC,
-- en1entertag ASC, does not exist |||
EN1Part ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY004
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY004 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHY004
ON BUA.XBDHY001PS001001
(EA1ATRN ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY005
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY005 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDHY005
ON BUA.XBDHY001PS001001
(EN1PAGINATOR ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY006
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY006 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY006
ON BUA.XBDHY001PS001001
(EN1CIF ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY007
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY007 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY007
ON BUA.XBDHY001PS001001
(EN1CIF ASC,
en1entertag ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY008
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY008 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY008
ON BUA.XBDHY001PS001001
(EA1BEZNR ASC,
en1entertag ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY009
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY009 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY009
ON BUA.XBDHY001PS001001
(EA1KNAME ASC,
en1entertag ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY010
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY010 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY010
ON BUA.XBDHY001PS001001
(EA1BEZNR ASC,
EN1ENTERTAG ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY011
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY011 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY011
ON BUA.XBDHY001PS001001
(EA1KNAME ASC,
EN1ENTERTAG ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDHY012
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDHY001
-- Index=BUA.IPDHY012 On BUA.XBDHY001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDHY012
ON BUA.XBDHY001PS001001
(EB1WERT1 ASC,
EN1ENTERTAG ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS4
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL001
-- --
------------------------------------------------------------------------
--
--
------------------------------------------------------------------------
-- Stogroup=GSMS3
------------------------------------------------------------------------
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL001 On BUA.XBEHL001PS002001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPEHL001
ON BUA.XBEHL001PS002001
(EA1ATRN ASC,
en1entertag ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL002
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL002 On BUA.XBEHL001PS002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPEHL002
ON BUA.XBEHL001PS002001
(EA1STRN ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL003
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL003 On BUA.XBEHL001IT002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPEHL003
ON BUA.XBEHL001IT002001
(EA1STRN ASC,
EN1STK1 ASC,
EN1STK2 ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL004
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL004 On BUA.XBEHL001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPEHL004
ON BUA.XBEHL001PS001001
(EA1ANUM ASC,
EN1VALOR ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL005
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL005 On BUA.XBEHL001PS001001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPEHL005
ON BUA.XBEHL001PS001001
(EN1VALOR ASC,
en1entertag ASC,
ET1LOGPROD ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL006
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL006 On BUA.XBEHL001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPEHL006
ON BUA.XBEHL001PS001001
(EA1ANUM ASC,
EA1TEILAUSF ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPEHL007
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBEHL001
-- Index=BUA.IPEHL007 On BUA.XBEHL001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPEHL007
ON BUA.XBEHL001PS001001
(EA1ATRN ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS3
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDJW001
-- --
------------------------------------------------------------------------
--
--
------------------------------------------------------------------------
-- Stogroup=GSMS2
------------------------------------------------------------------------
------------------------------------------------------------------------
-- Database=XBDJW001
-- Index=BUA.IPDJW001 On BUA.XBDJW001PS002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDJW001
ON BUA.XBDJW001PS002001
(EA1STRN ASC,
-- en1entertag ASC, does not exist |||
EN1PART ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDJW002
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDJW001
-- Index=BUA.IPDJW002 On BUA.XBDJW001PS002001
------------------------------------------------------------------------
--
CREATE INDEX BUA.IPDJW002
ON BUA.XBDJW001PS002001
(EA1ATRN ASC)
-- en1entertag ASC) does not exist |||
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDJW003
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDJW001
-- Index=BUA.IPDJW003 On BUA.XBDJW001IT002001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDJW003
ON BUA.XBDJW001IT002001
(EA1STRN ASC,
EN1STK1 ASC,
EN1STK2 ASC,
-- en1entertag ASC, does not exist ||||
EN1PART ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDJW004
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDJW001
-- Index=BUA.IPDJW004 On BUA.XBDJW001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDJW004
ON BUA.XBDJW001PS001001
(EA1ATRN ASC,
en1entertag ASC,
EN1PART ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
------------------------------------------------------------------------
-- --
-- ADB2GEN: Generate DDL for Index=BUA.IPDJW005
-- --
------------------------------------------------------------------------
--
------------------------------------------------------------------------
-- Database=XBDJW001
-- Index=BUA.IPDJW005 On BUA.XBDJW001PS001001
------------------------------------------------------------------------
--
CREATE UNIQUE INDEX BUA.IPDJW005
ON BUA.XBDJW001PS001001
(EN1ENTERTAG ASC,
EA1SWVERSION ASC,
EA1FNAME ASC,
EA1SYSTEM ASC,
ET1LOGPROD ASC,
EN1PART ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
--
------------------------------------------------------------------------
-- Index von Uwe 1.9.10 --
------------------------------------------------------------------------
--
CREATE INDEX BUA.IDRWPS001 -- ??? dups in pta
ON BUA.XBDRW001PS001001
( EA1IMATCHDB ASC, ---uwe9.9
EB1POSTENNUMMER ASC,
EB1MATCHID ASC,
ED1DATUMABGL ASC,
EN1ENTERTAG ASC,
ET1LOGPROD ASC ---uwe9.9
) --,EN1PART ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
--
CREATE INDEX BUA.IDRWPS002
ON BUA.XBDRW001PS001001
(EN1ENTERTAG ASC,
EN1KONTO ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
CREATE INDEX BUA.IDRWPS003
ON BUA.XBDRW001PS001001
( EB1AMOUNT ASC ,
EN1ENTERTAG ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
--
CREATE INDEX BUA.IDRWPS004
ON BUA.XBDRW001PS001001
(ED1VALUTA ASC ,
EN1ENTERTAG ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
--
CREATE INDEX BUA.IDRWPS005
ON BUA.XBDRW001PS001001
(EA1BUCHREF ASC,
EN1ENTERTAG ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
NOT CLUSTER
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
--
CREATE INDEX BUA.IDRWIT001
ON BUA.XBDRW001IT002001
(EA1STRN ASC,
EN1STK1 ASC,
EN1STK2 ASC)
USING STOGROUP GSMS2
PRIQTY -1 SECQTY -1
ERASE NO
GBPCACHE CHANGED
not CLUSTER --||| already has clustering index
BUFFERPOOL BP20
CLOSE NO
COPY NO
DEFER NO
DEFINE YES
PIECESIZE 8 G;
--
COMMIT;
--
}¢--- A540769.WK.REXX(ELARIW) cre=2010-07-12 mod=2010-11-10-16.39.29 A540769 ---
$@fam()
sta = 0
$=cx=0
$=ssid=DVBP
$=f1=EN1ENTERTAG
$=hasEnterTag= 0
call sqlConnect $ssid
actTb = ''
$;
$<A540769.WK.REXX(ELARIddl)
$@for li $@¢
if sta=0 then do
if word($li, 1) \== create then
iterate
ix = wordPos(index, $li)
ix = word($li, ix+1)
if left(ix, 4) \== 'BUA.' then
call err 'bad ix' ix
ix = substr(ix, 5)
fx = m.i2f.ix
$=cx=- $cx+1
$=jx=- fx || right($cx, 2, 0)
$=ix=- ix
$@checkIx()
$=fx=- fx
$=fa=- m.family.fx
sta = 1
$=big = 0
$=creLine = $li
say $jx $ix 'fam' $fx $fa
iterate
end
li = $li
w1 = translate(word(li, 1))
if sta == 1 then do
if w1 \= 'ON' then
call err 'on expected' li
sta = 2
$=tb=- word(li, 2)
if \ abbrev($tb, 'BUA.') then
call err 'bad on': li
$@checkSz()
if actTb \= $tb then do
actTb = $tb
if $cx > 1 then do
$@jcl2()
call pipeEnd
end
$=job=YELAR$jx
call pipeBeLa '>' s2o('A540769.TMP.JCL('$job')')
m.tbix.0 = 0
$@jcl1()
end
call mAdd tbix, $ix
$@ixBeg()
end
else do
if w1 = 'DEFER' then do
li = ' DEFER YES'
end
else if w1 = 'PIECESIZE' then do
li = ' PARTITIONED;'
sta = 0
end
else if w1 = 'BUFFERPOOL' then do
if $big then
li = ' bufferpool BP16K2'
end
else if 0 & pos($f1, translate(li)) > 0 ,
& \ $hasEnterTag then do
lu = translate(li)
cx = pos($f1, lu)
le = strip(left(lu, cx-1))
n = space(substr(lu, cx), 1)
if n = $f1 'ASC,' | n = $f1 'ASC ,' then
li = le
else if (n = $f1 'ASC)' | n = $f1 'ASC )') ,
& right(le, 1) == ',' then do
say le length(le)
li = left(le, length(le)-1) ')'
end
else
call err 'bad' $f1':' li
end
end
$$- li
$!
if $cx > 1 then do
$@jcl2()
call pipeEnd
end
$;
$@proc jcl1 $@=¢
//$job JOB (CP00,KE50),
// MSGCLASS=T,TIME=1440,
// NOTIFY=A540769
//*MAIN CLASS=LOG
//* index $ix family $fa
//DDL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($ssid)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//***PRINT DD DISP=SHR,DSN=A540769.WK.TEXW(PDBGENNJ)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD * DISP=SHR,DSN=A540769.WK.SQL(PDBGENNJ)
set current sqlid = 'S100447';
$!
$@proc ixBeg $@¢
if $ixExists then $@=¢
drop index bua.$ix;
commit;
$!
$$ $creLine
$!
$@proc jcl2 $@=¢
commit;
// IF RC <= 4 THEN
//REBUI EXEC PGM=DSNUTILB,TIME=1440,
// PARM=($ssid,'$job.REBUI'),
// REGION=0M
//DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$ssid.DBAA.LISTDEF(TEMPL)
//SYSIN DD *
LISTDEF IX
$@do yy=1 to m.tbIx.0 $@=¢
INCLUDE INDEX BUA.$-{m.tbIx.yy} PARTLEVEL
$!
REBUILD INDEX LIST IX
SORTDEVT SYSDA
SORTNUM 140
WORKDDN(TSYUTD)
LISTDEF TS INCLUDE TABLESPACES LIST IX
RUNSTATS TABLESPACE LIST TS
INDEX(ALL) KEYCARD UPDATE ALL
// ENDIF
//*** jclEnd $-{m.tbIx.0} ix $-{m.tbIx.1} ...
$!
$@proc fam $@¢
$<A540769.WK.REXX(ELARIx)
oldFa = ''
m.family.0 = 0
$@for li $@¢
parse value $li with fa ix .
if ix \== '' then do
call mAdd family, fa
m.i2f.ix = m.family.0
end
else do
m.i2f.fa = m.family.0
end
$!
$!
$@proc checkSz $@¢
parse value $tb with cr'.'tb
et = sqlPreAllCl(1, "select 1",
"from sysibm.sysColumns",
"where tbCreator = '"cr"' and tbName ='"tb"'" ,
"and name = 'EN1ENTERTAG'", s , ":c1")
$=hasEnterTag=- et
say "hasEnterTag" $hasEnterTag $tb
call sqlPreAllCl 1, "select count(*),max(s.dbName), max(s.name), ",
"real(max(r.space)) * 1024" ,
"from sysibm.systables t, sysibm.sysTableSpace s,",
"sysibm.systableSpaceStats r" ,
"where t.creator = '"cr"' and t.name ='"tb"'" ,
"and t.dbName = s.dbName and t.tsName = s.name",
"and r.dbId = s.dbId and r.psId = s.psId",
, s, ":cnt, :qDb :i1, :qTs :i2, :qSz :i2"
if cnt >= 1 then do
$=big =- qSz > 5e9
say cr'.'tb m.s.0 '=>' qDb'.'qTs '=' qSz 'big' $big
end
else do
say "||| no table" cr"."tb "for ix" $ix
$=big=0
end
$!
$@proc checkIx $@¢
ixTy = 'noIndex'
cnt =sqlPreAllCl(1, "select indexType",
"from sysibm.sysIndexes",
"where creator = 'BUA' and name ='"$ix"'", s , ":ixTy")
say ixTy 'ix bua.'$ix 'cnt' cnt
$=ixExists =- cnt = 1
$!
$#out 20101110 16:38:03
$#out 20101110 16:37:12
$#out 20101110 16:36:01
$#out 20101110 16:32:10
$#out 20101110 16:28:40
$#out 20101110 16:25:56
$#out 20101110 16:22:21
$#out 20101110 16:06:09
$#out 20101101 13:21:42
$#out 20101110 16:03:52
$#out 20101101 13:12:12
}¢--- A540769.WK.REXX(ELARIX) cre=2010-07-12 mod=2010-09-02-09.45.13 A540769 ---
CL.CORR.K IPDHA001
IPDHA002
IPDHA003
IPDHA004
IPDHA005
IPDHA006
IPDHA007
IPDHA008
IPDHA009
IPDHA010
IPDHA011
IPDHA012
CL.CORR.NK IPDHY001
IPDHY002
IPDHY003
IPDHY004
IPDHY005
IPDHY006
IPDHY007
IPDHY008
IPDHY009
IPDHY010
IPDHY011
IPDHY012
EFF.JOURNAL IPEHL001
IPEHL002
IPEHL003
IPEHL004
IPEHL005
IPEHL006
IPEHL007
SANCT.FILTER IPDJW001
IPDJW002
IPDJW003
IPDJW004
IPDJW005
UWE.FILTER IDRWPS001
IDRWPS002
IDRWPS003
IDRWPS004
IDRWPS005
IDRWIT001
}¢--- A540769.WK.REXX(ELARORPH) cre=2014-08-19 mod=2014-08-19-14.38.01 A540769 ---
$#@
$*( check vsam Datasets and report if DB is no longer in Db2
optionally, add xHUrba and xHArba
HUrba is only 32 bit which gets truncated|
$*)
$=wRBA = 1 $** with haRBA and huRRA, 0 = without (faster)
call sqlConnect dvbp
numeric digits(20)
call sql2St 'select name db from sysibm.sysDatabase' ,
'except all select db from S100447.TELARDROP' ,
"where kind='disp req' and nm in ('disp07', 'disp08#2')" ,
'order by 1' , dbs, ':m.dst'
say m.dbs.0 'dbs'
do dx=1 to m.dbs.0
db = strip(m.dbs.dx)
m.db2x.db = dx
end
call csiOpen csi, 'DVBP*.DSNDBD.**' , copies('XHARBADS XHURBADS', $wRBA)
cNoDb = 0
aUse = 0
aAlc = 0
nUse = 0
nAlc = 0
do c=0 while csiNext(csi, nx)
if $wRBA then $@¢
$** say c2x(m.nx.Xharbads) c2x(m.nx.Xhurbads) m.nx
if m.nx.xhaRBAds == 'ffffffffffffffff'x ,
| m.nx.xhuRBAds == 'ffffffffffffffff'x then do
a1 = 0
u1 = 0
say 'bad rba' m.nx
end
else do
a1 = c2d(m.nx.xharbads)
u1 = c2d(m.nx.xhurbads)
end
aUse = aUse + u1
aAlc = aAlc + a1
$!
db = word(translate(m.nx, ' ', '.'), 3)
if symbol('m.db2x.db') \== 'VAR' then do
$$- left(db, 8) left(m.nx, 44) copies(a1 u1, $wRBA)
cNoDb = cNoDb + 1
if $wRBA then $@¢
nUse = nUse + u1
nAlc = nAlc + a1
$!
end
if c // 10000 = 0 then
say 'noDb' cNoDb nUse nAlc 'all' c aUse aAlc db':'m.nx
end
say 'noDb' cNoDb nUse nAlc 'all' c aUse aAlc db':'m.nx
$$- 'noDb' cNoDb nUse nAlc 'all' c aUse aAlc db':'m.nx
$#out 20140819 11:40:26
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E5174199
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E5184328
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E9093468
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E9483641
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E9491715
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E9495407
XBZZZZZZ DVBP.DSNDBD.XBZZZZZZ.SIT003.E9503088
XBAHD002 DVBP1.DSNDBD.XBAHD002.SHS001.I0001.A001
XBAHD012 DVBP1.DSNDBD.XBAHD012.SHS001.I0001.A001
XBAHD024 DVBP1.DSNDBD.XBAHD024.SHS001.I0001.A001
XBAHM001 DVBP1.DSNDBD.XBAHM001.SHS001.I0001.A001
XBAON002 DVBP1.DSNDBD.XBAON002.SHS001.I0001.A001
XBDM7001 DVBP1.DSNDBD.XBDM7001.SPM01002.J0001.A007
XB9NY002 DVBP1.DSNDBD.XB9NY002.SHS001.I0001.A001
XB9OA001 DVBP1.DSNDBD.XB9OA001.SHS001.I0001.A001
XB9OB001 DVBP1.DSNDBD.XB9OB001.SHS001.I0001.A001
XB9OC002 DVBP1.DSNDBD.XB9OC002.SHS001.I0001.A001
XB9OD001 DVBP1.DSNDBD.XB9OD001.SHS001.I0001.A001
XB9OH002 DVBP1.DSNDBD.XB9OH002.SHS001.I0001.A001
XB9ON005 DVBP1.DSNDBD.XB9ON005.SHS001.I0001.A001
XB9ON011 DVBP1.DSNDBD.XB9ON011.SHS001.I0001.A001
XB9ON017 DVBP1.DSNDBD.XB9ON017.SHS001.I0001.A001
XB9ON027 DVBP1.DSNDBD.XB9ON027.SHS001.I0001.A001
XB9OO004 DVBP1.DSNDBD.XB9OO004.SHS001.I0001.A001
XB9OO008 DVBP1.DSNDBD.XB9OO008.SHS001.I0001.A001
XB9OO031 DVBP1.DSNDBD.XB9OO031.SHS001.I0001.A001
XB9OO034 DVBP1.DSNDBD.XB9OO034.SHS001.I0001.A001
XB9OO044 DVBP1.DSNDBD.XB9OO044.SHS001.I0001.A001
XB9OO047 DVBP1.DSNDBD.XB9OO047.SHS001.I0001.A001
XB9OO054 DVBP1.DSNDBD.XB9OO054.SHS001.I0001.A001
XB9OO066 DVBP1.DSNDBD.XB9OO066.SHS001.I0001.A001
XB9OO070 DVBP1.DSNDBD.XB9OO070.SHS001.I0001.A001
XB9OO085 DVBP1.DSNDBD.XB9OO085.SHS001.I0001.A001
XB9OO096 DVBP1.DSNDBD.XB9OO096.SHS001.I0001.A001
XB9OO109 DVBP1.DSNDBD.XB9OO109.SHS001.I0001.A001
XB9OO114 DVBP1.DSNDBD.XB9OO114.SHS001.I0001.A001
XB9OO118 DVBP1.DSNDBD.XB9OO118.SHS001.I0001.A001
XB9OO122 DVBP1.DSNDBD.XB9OO122.SHS001.I0001.A001
XB9OO127 DVBP1.DSNDBD.XB9OO127.SHS001.I0001.A001
XB9OO131 DVBP1.DSNDBD.XB9OO131.SHS001.I0001.A001
XB9OO138 DVBP1.DSNDBD.XB9OO138.SHS001.I0001.A001
XB9OO139 DVBP1.DSNDBD.XB9OO139.SHS001.I0001.A001
XB9OO141 DVBP1.DSNDBD.XB9OO141.SHS001.I0001.A001
XB9OO154 DVBP1.DSNDBD.XB9OO154.SHS001.I0001.A001
XB9OO165 DVBP1.DSNDBD.XB9OO165.SHS001.I0001.A001
XB9OO169 DVBP1.DSNDBD.XB9OO169.SHS001.I0001.A001
XB9OO174 DVBP1.DSNDBD.XB9OO174.SHS001.I0001.A001
XB9OO178 DVBP1.DSNDBD.XB9OO178.SHS001.I0001.A001
XB9OO186 DVBP1.DSNDBD.XB9OO186.SHS001.I0001.A001
XB9OO189 DVBP1.DSNDBD.XB9OO189.SHS001.I0001.A001
XB9OO197 DVBP1.DSNDBD.XB9OO197.SHS001.I0001.A001
XB9OO200 DVBP1.DSNDBD.XB9OO200.SHS001.I0001.A001
XB9OO204 DVBP1.DSNDBD.XB9OO204.SHS001.I0001.A001
XB9OP001 DVBP1.DSNDBD.XB9OP001.SHS001.I0001.A001
XB9OP003 DVBP1.DSNDBD.XB9OP003.SHS001.I0001.A001
XB9OP006 DVBP1.DSNDBD.XB9OP006.SHS001.I0001.A001
XB9OP010 DVBP1.DSNDBD.XB9OP010.SHS001.I0001.A001
XB9OP030 DVBP1.DSNDBD.XB9OP030.SHS001.I0001.A001
XB9OP036 DVBP1.DSNDBD.XB9OP036.SHS001.I0001.A001
XB9OP040 DVBP1.DSNDBD.XB9OP040.SHS001.I0001.A001
XB9OP046 DVBP1.DSNDBD.XB9OP046.SHS001.I0001.A001
XB9OP047 DVBP1.DSNDBD.XB9OP047.SHS001.I0001.A001
XB9OP054 DVBP1.DSNDBD.XB9OP054.SHS001.I0001.A001
XB9OP070 DVBP1.DSNDBD.XB9OP070.SHS001.I0001.A001
XB9OP071 DVBP1.DSNDBD.XB9OP071.SHS001.I0001.A001
XB9OP082 DVBP1.DSNDBD.XB9OP082.SHS001.I0001.A001
XB9OP088 DVBP1.DSNDBD.XB9OP088.SHS001.I0001.A001
XB9OP091 DVBP1.DSNDBD.XB9OP091.SHS001.I0001.A001
XB9OS001 DVBP1.DSNDBD.XB9OS001.SHS001.I0001.A001
XB9OS002 DVBP1.DSNDBD.XB9OS002.SHS001.I0001.A001
XB9OX002 DVBP1.DSNDBD.XB9OX002.SHS001.I0001.A001
XB9O7002 DVBP1.DSNDBD.XB9O7002.SHS001.I0001.A001
XB9O7010 DVBP1.DSNDBD.XB9O7010.SHS001.I0001.A001
XB9O8002 DVBP1.DSNDBD.XB9O8002.SHS001.I0001.A001
XB9O8004 DVBP1.DSNDBD.XB9O8004.SHS001.I0001.A001
XB9O8007 DVBP1.DSNDBD.XB9O8007.SHS001.I0001.A001
XB9O8010 DVBP1.DSNDBD.XB9O8010.SHS001.I0001.A001
XB9O8014 DVBP1.DSNDBD.XB9O8014.SHS001.I0001.A001
XB9O8027 DVBP1.DSNDBD.XB9O8027.SHS001.I0001.A001
XB9O8033 DVBP1.DSNDBD.XB9O8033.SHS001.I0001.A001
XB9O8043 DVBP1.DSNDBD.XB9O8043.SHS001.I0001.A001
XB9O8044 DVBP1.DSNDBD.XB9O8044.SHS001.I0001.A001
XB9O8051 DVBP1.DSNDBD.XB9O8051.SHS001.I0001.A001
XB9O8058 DVBP1.DSNDBD.XB9O8058.SHS001.I0001.A001
XB9O8062 DVBP1.DSNDBD.XB9O8062.SHS001.I0001.A001
XB9O8067 DVBP1.DSNDBD.XB9O8067.SHS001.I0001.A001
XB9O8068 DVBP1.DSNDBD.XB9O8068.SHS001.I0001.A001
XB9O8072 DVBP1.DSNDBD.XB9O8072.SHS001.I0001.A001
XB9O8107 DVBP1.DSNDBD.XB9O8107.SHS001.I0001.A001
XB9PB002 DVBP1.DSNDBD.XB9PB002.SHS001.I0001.A001
XB9P2002 DVBP1.DSNDBD.XB9P2002.SHS001.I0001.A001
XB9P3003 DVBP1.DSNDBD.XB9P3003.SHS001.I0001.A001
XB9P4002 DVBP1.DSNDBD.XB9P4002.SHS001.I0001.A001
XB9P4006 DVBP1.DSNDBD.XB9P4006.SHS001.I0001.A001
XBAHD008 DVBP2.DSNDBD.XBAHD008.SHS001.I0001.A001
XBAHD009 DVBP2.DSNDBD.XBAHD009.SHS001.I0001.A001
XBAHD019 DVBP2.DSNDBD.XBAHD019.SHS001.I0001.A001
XBAHD029 DVBP2.DSNDBD.XBAHD029.SHS001.I0001.A001
XBAOQ001 DVBP2.DSNDBD.XBAOQ001.SHS001.I0001.A001
XBAT8002 DVBP2.DSNDBD.XBAT8002.SHS001.I0001.A001
XBB9H001 DVBP2.DSNDBD.XBB9H001.SHS001.I0001.A001
XB9NR002 DVBP2.DSNDBD.XB9NR002.SHS001.I0001.A001
XB9NS001 DVBP2.DSNDBD.XB9NS001.SHS001.I0001.A001
XB9NZ001 DVBP2.DSNDBD.XB9NZ001.SHS001.I0001.A001
XB9OB002 DVBP2.DSNDBD.XB9OB002.SHS001.I0001.A001
XB9OF002 DVBP2.DSNDBD.XB9OF002.SHS001.I0001.A001
XB9ON001 DVBP2.DSNDBD.XB9ON001.SHS001.I0001.A001
XB9ON010 DVBP2.DSNDBD.XB9ON010.SHS001.I0001.A001
XB9ON016 DVBP2.DSNDBD.XB9ON016.SHS001.I0001.A001
XB9ON022 DVBP2.DSNDBD.XB9ON022.SHS001.I0001.A001
XB9OO001 DVBP2.DSNDBD.XB9OO001.SHS001.I0001.A001
XB9OO003 DVBP2.DSNDBD.XB9OO003.SHS001.I0001.A001
XB9OO012 DVBP2.DSNDBD.XB9OO012.SHS001.I0001.A001
XB9OO023 DVBP2.DSNDBD.XB9OO023.SHS001.I0001.A001
XB9OO029 DVBP2.DSNDBD.XB9OO029.SHS001.I0001.A001
XB9OO033 DVBP2.DSNDBD.XB9OO033.SHS001.I0001.A001
XB9OO043 DVBP2.DSNDBD.XB9OO043.SHS001.I0001.A001
XB9OO046 DVBP2.DSNDBD.XB9OO046.SHS001.I0001.A001
XB9OO061 DVBP2.DSNDBD.XB9OO061.SHS001.I0001.A001
XB9OO065 DVBP2.DSNDBD.XB9OO065.SHS001.I0001.A001
XB9OO069 DVBP2.DSNDBD.XB9OO069.SHS001.I0001.A001
XB9OO074 DVBP2.DSNDBD.XB9OO074.SHS001.I0001.A001
XB9OO084 DVBP2.DSNDBD.XB9OO084.SHS001.I0001.A001
XB9OO088 DVBP2.DSNDBD.XB9OO088.SHS001.I0001.A001
XB9OO091 DVBP2.DSNDBD.XB9OO091.SHS001.I0001.A001
XB9OO095 DVBP2.DSNDBD.XB9OO095.SHS001.I0001.A001
XB9OO099 DVBP2.DSNDBD.XB9OO099.SHS001.I0001.A001
XB9OO112 DVBP2.DSNDBD.XB9OO112.SHS001.I0001.A001
XB9OO121 DVBP2.DSNDBD.XB9OO121.SHS001.I0001.A001
XB9OO130 DVBP2.DSNDBD.XB9OO130.SHS001.I0001.A001
XB9OO140 DVBP2.DSNDBD.XB9OO140.SHS001.I0001.A001
XB9OO150 DVBP2.DSNDBD.XB9OO150.SHS001.I0001.A001
XB9OO161 DVBP2.DSNDBD.XB9OO161.SHS001.I0001.A001
XB9OO177 DVBP2.DSNDBD.XB9OO177.SHS001.I0001.A001
XB9OO182 DVBP2.DSNDBD.XB9OO182.SHS001.I0001.A001
XB9OO185 DVBP2.DSNDBD.XB9OO185.SHS001.I0001.A001
XB9OO188 DVBP2.DSNDBD.XB9OO188.SHS001.I0001.A001
XB9OO192 DVBP2.DSNDBD.XB9OO192.SHS001.I0001.A001
XB9OO203 DVBP2.DSNDBD.XB9OO203.SHS001.I0001.A001
XB9OP009 DVBP2.DSNDBD.XB9OP009.SHS001.I0001.A001
XB9OP023 DVBP2.DSNDBD.XB9OP023.SHS001.I0001.A001
XB9OP039 DVBP2.DSNDBD.XB9OP039.SHS001.I0001.A001
XB9OP051 DVBP2.DSNDBD.XB9OP051.SHS001.I0001.A001
XB9OP061 DVBP2.DSNDBD.XB9OP061.SHS001.I0001.A001
XB9OP062 DVBP2.DSNDBD.XB9OP062.SHS001.I0001.A001
XB9OP069 DVBP2.DSNDBD.XB9OP069.SHS001.I0001.A001
XB9OP085 DVBP2.DSNDBD.XB9OP085.SHS001.I0001.A001
XB9OP087 DVBP2.DSNDBD.XB9OP087.SHS001.I0001.A001
XB9OP090 DVBP2.DSNDBD.XB9OP090.SHS001.I0001.A001
XB9OP094 DVBP2.DSNDBD.XB9OP094.SHS001.I0001.A001
XB9OR002 DVBP2.DSNDBD.XB9OR002.SHS001.I0001.A001
XB9OV002 DVBP2.DSNDBD.XB9OV002.SHS001.I0001.A001
XB9O7005 DVBP2.DSNDBD.XB9O7005.SHS001.I0001.A001
XB9O7013 DVBP2.DSNDBD.XB9O7013.SHS001.I0001.A001
XB9O8003 DVBP2.DSNDBD.XB9O8003.SHS001.I0001.A001
XB9O8020 DVBP2.DSNDBD.XB9O8020.SHS001.I0001.A001
XB9O8022 DVBP2.DSNDBD.XB9O8022.SHS001.I0001.A001
XB9O8036 DVBP2.DSNDBD.XB9O8036.SHS001.I0001.A001
XB9O8045 DVBP2.DSNDBD.XB9O8045.SHS001.I0001.A001
XB9O8048 DVBP2.DSNDBD.XB9O8048.SHS001.I0001.A001
XB9O8057 DVBP2.DSNDBD.XB9O8057.SHS001.I0001.A001
XB9O8061 DVBP2.DSNDBD.XB9O8061.SHS001.I0001.A001
XB9O8074 DVBP2.DSNDBD.XB9O8074.SHS001.I0001.A001
XB9O8081 DVBP2.DSNDBD.XB9O8081.SHS001.I0001.A001
XB9O8084 DVBP2.DSNDBD.XB9O8084.SHS001.I0001.A001
XB9O8087 DVBP2.DSNDBD.XB9O8087.SHS001.I0001.A001
XB9O8095 DVBP2.DSNDBD.XB9O8095.SHS001.I0001.A001
XB9O8102 DVBP2.DSNDBD.XB9O8102.SHS001.I0001.A001
XB9O8111 DVBP2.DSNDBD.XB9O8111.SHS001.I0001.A001
XB9O8113 DVBP2.DSNDBD.XB9O8113.SHS001.I0001.A001
XB9P2004 DVBP2.DSNDBD.XB9P2004.SHS001.I0001.A001
XB9P3001 DVBP2.DSNDBD.XB9P3001.SHS001.I0001.A001
XB9P8001 DVBP2.DSNDBD.XB9P8001.SHS001.I0001.A001
XB9ZT001 DVBP2.DSNDBD.XB9ZT001.SHS001.I0001.A001
XB9ZU002 DVBP2.DSNDBD.XB9ZU002.SHS001.I0001.A001
XB9ZV001 DVBP2.DSNDBD.XB9ZV001.SHS001.I0001.A001
XBAHD001 DVBP3.DSNDBD.XBAHD001.SHS001.I0001.A001
XBAHD010 DVBP3.DSNDBD.XBAHD010.SHS001.I0001.A001
XBAHD011 DVBP3.DSNDBD.XBAHD011.SHS001.I0001.A001
XBAHD017 DVBP3.DSNDBD.XBAHD017.SHS001.I0001.A001
XBAHD021 DVBP3.DSNDBD.XBAHD021.SHS001.I0001.A001
XBAHD025 DVBP3.DSNDBD.XBAHD025.SHS001.I0001.A001
XBAOQ002 DVBP3.DSNDBD.XBAOQ002.SHS001.I0001.A001
XBAQC001 DVBP3.DSNDBD.XBAQC001.SHS001.I0001.A001
XBAT8001 DVBP3.DSNDBD.XBAT8001.SHS001.I0001.A001
XBB9G001 DVBP3.DSNDBD.XBB9G001.SHS001.I0001.A001
XB217032 DVBP3.DSNDBD.XB217032.SIT002.I0001.A001
XB217032 DVBP3.DSNDBD.XB217032.SPS001.I0001.A001
XB9JC855 DVBP3.DSNDBD.XB9JC855.SHS001.I0001.A001
XB9NS002 DVBP3.DSNDBD.XB9NS002.SHS001.I0001.A001
XB9NS003 DVBP3.DSNDBD.XB9NS003.SHS001.I0001.A001
XB9NS007 DVBP3.DSNDBD.XB9NS007.SHS001.I0001.A001
XB9NS008 DVBP3.DSNDBD.XB9NS008.SHS001.I0001.A001
XB9NU002 DVBP3.DSNDBD.XB9NU002.SHS001.I0001.A001
XB9NV001 DVBP3.DSNDBD.XB9NV001.SHS001.I0001.A001
XB9NY001 DVBP3.DSNDBD.XB9NY001.SHS001.I0001.A001
XB9ON002 DVBP3.DSNDBD.XB9ON002.SHS001.I0001.A001
XB9ON003 DVBP3.DSNDBD.XB9ON003.SHS001.I0001.A001
XB9ON006 DVBP3.DSNDBD.XB9ON006.SHS001.I0001.A001
XB9ON007 DVBP3.DSNDBD.XB9ON007.SHS001.I0001.A001
XB9ON038 DVBP3.DSNDBD.XB9ON038.SHS001.I0001.A001
XB9OO006 DVBP3.DSNDBD.XB9OO006.SHS001.I0001.A001
XB9OO010 DVBP3.DSNDBD.XB9OO010.SHS001.I0001.A001
XB9OO015 DVBP3.DSNDBD.XB9OO015.SHS001.I0001.A001
XB9OO022 DVBP3.DSNDBD.XB9OO022.SHS001.I0001.A001
XB9OO026 DVBP3.DSNDBD.XB9OO026.SHS001.I0001.A001
XB9OO028 DVBP3.DSNDBD.XB9OO028.SHS001.I0001.A001
XB9OO032 DVBP3.DSNDBD.XB9OO032.SHS001.I0001.A001
XB9OO040 DVBP3.DSNDBD.XB9OO040.SHS001.I0001.A001
XB9OO056 DVBP3.DSNDBD.XB9OO056.SHS001.I0001.A001
XB9OO060 DVBP3.DSNDBD.XB9OO060.SHS001.I0001.A001
XB9OO064 DVBP3.DSNDBD.XB9OO064.SHS001.I0001.A001
XB9OO067 DVBP3.DSNDBD.XB9OO067.SHS001.I0001.A001
XB9OO073 DVBP3.DSNDBD.XB9OO073.SHS001.I0001.A001
XB9OO079 DVBP3.DSNDBD.XB9OO079.SHS001.I0001.A001
XB9OO087 DVBP3.DSNDBD.XB9OO087.SHS001.I0001.A001
XB9OO094 DVBP3.DSNDBD.XB9OO094.SHS001.I0001.A001
XB9OO107 DVBP3.DSNDBD.XB9OO107.SHS001.I0001.A001
XB9OO111 DVBP3.DSNDBD.XB9OO111.SHS001.I0001.A001
XB9OO116 DVBP3.DSNDBD.XB9OO116.SHS001.I0001.A001
XB9OO120 DVBP3.DSNDBD.XB9OO120.SHS001.I0001.A001
XB9OO124 DVBP3.DSNDBD.XB9OO124.SHS001.I0001.A001
XB9OO133 DVBP3.DSNDBD.XB9OO133.SHS001.I0001.A001
XB9OO147 DVBP3.DSNDBD.XB9OO147.SHS001.I0001.A001
XB9OO156 DVBP3.DSNDBD.XB9OO156.SHS001.I0001.A001
XB9OO160 DVBP3.DSNDBD.XB9OO160.SHS001.I0001.A001
XB9OO172 DVBP3.DSNDBD.XB9OO172.SHS001.I0001.A001
XB9OO176 DVBP3.DSNDBD.XB9OO176.SHS001.I0001.A001
XB9OO180 DVBP3.DSNDBD.XB9OO180.SHS001.I0001.A001
XB9OO199 DVBP3.DSNDBD.XB9OO199.SHS001.I0001.A001
XB9OO202 DVBP3.DSNDBD.XB9OO202.SHS001.I0001.A001
XB9OO206 DVBP3.DSNDBD.XB9OO206.SHS001.I0001.A001
XB9OP008 DVBP3.DSNDBD.XB9OP008.SHS001.I0001.A001
XB9OP020 DVBP3.DSNDBD.XB9OP020.SHS001.I0001.A001
XB9OP022 DVBP3.DSNDBD.XB9OP022.SHS001.I0001.A001
XB9OP028 DVBP3.DSNDBD.XB9OP028.SHS001.I0001.A001
XB9OP031 DVBP3.DSNDBD.XB9OP031.SHS001.I0001.A001
XB9OP034 DVBP3.DSNDBD.XB9OP034.SHS001.I0001.A001
XB9OP048 DVBP3.DSNDBD.XB9OP048.SHS001.I0001.A001
XB9OP084 DVBP3.DSNDBD.XB9OP084.SHS001.I0001.A001
XB9OP089 DVBP3.DSNDBD.XB9OP089.SHS001.I0001.A001
XB9OP093 DVBP3.DSNDBD.XB9OP093.SHS001.I0001.A001
XB9OQ002 DVBP3.DSNDBD.XB9OQ002.SHS001.I0001.A001
XB9OR001 DVBP3.DSNDBD.XB9OR001.SHS001.I0001.A001
XB9OU004 DVBP3.DSNDBD.XB9OU004.SHS001.I0001.A001
XB9OV001 DVBP3.DSNDBD.XB9OV001.SHS001.I0001.A001
XB9O6001 DVBP3.DSNDBD.XB9O6001.SHS001.I0001.A001
XB9O8019 DVBP3.DSNDBD.XB9O8019.SHS001.I0001.A001
XB9O8025 DVBP3.DSNDBD.XB9O8025.SHS001.I0001.A001
XB9O8032 DVBP3.DSNDBD.XB9O8032.SHS001.I0001.A001
XB9O8047 DVBP3.DSNDBD.XB9O8047.SHS001.I0001.A001
XB9O8060 DVBP3.DSNDBD.XB9O8060.SHS001.I0001.A001
XB9O8073 DVBP3.DSNDBD.XB9O8073.SHS001.I0001.A001
XB9O8079 DVBP3.DSNDBD.XB9O8079.SHS001.I0001.A001
XB9O8082 DVBP3.DSNDBD.XB9O8082.SHS001.I0001.A001
XB9O8086 DVBP3.DSNDBD.XB9O8086.SHS001.I0001.A001
XB9O8097 DVBP3.DSNDBD.XB9O8097.SHS001.I0001.A001
XB9O8101 DVBP3.DSNDBD.XB9O8101.SHS001.I0001.A001
XB9O8106 DVBP3.DSNDBD.XB9O8106.SHS001.I0001.A001
XB9O8110 DVBP3.DSNDBD.XB9O8110.SHS001.I0001.A001
XB9O8112 DVBP3.DSNDBD.XB9O8112.SHS001.I0001.A001
XB9O9002 DVBP3.DSNDBD.XB9O9002.SHS001.I0001.A001
XB9O9007 DVBP3.DSNDBD.XB9O9007.SHS001.I0001.A001
XB9O9009 DVBP3.DSNDBD.XB9O9009.SHS001.I0001.A001
XB9PB001 DVBP3.DSNDBD.XB9PB001.SHS001.I0001.A001
XB9PI001 DVBP3.DSNDBD.XB9PI001.SHS001.I0001.A001
XB9P2003 DVBP3.DSNDBD.XB9P2003.SHS001.I0001.A001
XB9ZT002 DVBP3.DSNDBD.XB9ZT002.SHS001.I0001.A001
XB9ZU001 DVBP3.DSNDBD.XB9ZU001.SHS001.I0001.A001
XBAHD003 DVBP4.DSNDBD.XBAHD003.SHS001.I0001.A001
XBAHD014 DVBP4.DSNDBD.XBAHD014.SHS001.I0001.A001
XBAHR001 DVBP4.DSNDBD.XBAHR001.SHS001.I0001.A001
XBAL7001 DVBP4.DSNDBD.XBAL7001.SHS001.I0001.A001
XB9NR001 DVBP4.DSNDBD.XB9NR001.SHS001.I0001.A001
XB9NZ002 DVBP4.DSNDBD.XB9NZ002.SHS001.I0001.A001
XB9OF001 DVBP4.DSNDBD.XB9OF001.SHS001.I0001.A001
XB9OJ002 DVBP4.DSNDBD.XB9OJ002.SHS001.I0001.A001
XB9OM001 DVBP4.DSNDBD.XB9OM001.SHS001.I0001.A001
XB9ON019 DVBP4.DSNDBD.XB9ON019.SHS001.I0001.A001
XB9ON021 DVBP4.DSNDBD.XB9ON021.SHS001.I0001.A001
XB9ON028 DVBP4.DSNDBD.XB9ON028.SHS001.I0001.A001
XB9ON035 DVBP4.DSNDBD.XB9ON035.SHS001.I0001.A001
XB9ON036 DVBP4.DSNDBD.XB9ON036.SHS001.I0001.A001
XB9ON037 DVBP4.DSNDBD.XB9ON037.SHS001.I0001.A001
XB9ON039 DVBP4.DSNDBD.XB9ON039.SHS001.I0001.A001
XB9OO005 DVBP4.DSNDBD.XB9OO005.SHS001.I0001.A001
XB9OO009 DVBP4.DSNDBD.XB9OO009.SHS001.I0001.A001
XB9OO014 DVBP4.DSNDBD.XB9OO014.SHS001.I0001.A001
XB9OO017 DVBP4.DSNDBD.XB9OO017.SHS001.I0001.A001
XB9OO027 DVBP4.DSNDBD.XB9OO027.SHS001.I0001.A001
XB9OO039 DVBP4.DSNDBD.XB9OO039.SHS001.I0001.A001
XB9OO041 DVBP4.DSNDBD.XB9OO041.SHS001.I0001.A001
XB9OO045 DVBP4.DSNDBD.XB9OO045.SHS001.I0001.A001
XB9OO048 DVBP4.DSNDBD.XB9OO048.SHS001.I0001.A001
XB9OO051 DVBP4.DSNDBD.XB9OO051.SHS001.I0001.A001
XB9OO063 DVBP4.DSNDBD.XB9OO063.SHS001.I0001.A001
XB9OO072 DVBP4.DSNDBD.XB9OO072.SHS001.I0001.A001
XB9OO082 DVBP4.DSNDBD.XB9OO082.SHS001.I0001.A001
XB9OO086 DVBP4.DSNDBD.XB9OO086.SHS001.I0001.A001
XB9OO101 DVBP4.DSNDBD.XB9OO101.SHS001.I0001.A001
XB9OO105 DVBP4.DSNDBD.XB9OO105.SHS001.I0001.A001
XB9OO106 DVBP4.DSNDBD.XB9OO106.SHS001.I0001.A001
XB9OO110 DVBP4.DSNDBD.XB9OO110.SHS001.I0001.A001
XB9OO115 DVBP4.DSNDBD.XB9OO115.SHS001.I0001.A001
XB9OO119 DVBP4.DSNDBD.XB9OO119.SHS001.I0001.A001
XB9OO123 DVBP4.DSNDBD.XB9OO123.SHS001.I0001.A001
XB9OO128 DVBP4.DSNDBD.XB9OO128.SHS001.I0001.A001
XB9OO132 DVBP4.DSNDBD.XB9OO132.SHS001.I0001.A001
XB9OO142 DVBP4.DSNDBD.XB9OO142.SHS001.I0001.A001
XB9OO152 DVBP4.DSNDBD.XB9OO152.SHS001.I0001.A001
XB9OO155 DVBP4.DSNDBD.XB9OO155.SHS001.I0001.A001
XB9OO171 DVBP4.DSNDBD.XB9OO171.SHS001.I0001.A001
XB9OO184 DVBP4.DSNDBD.XB9OO184.SHS001.I0001.A001
XB9OO194 DVBP4.DSNDBD.XB9OO194.SHS001.I0001.A001
XB9OO198 DVBP4.DSNDBD.XB9OO198.SHS001.I0001.A001
XB9OO201 DVBP4.DSNDBD.XB9OO201.SHS001.I0001.A001
XB9OO205 DVBP4.DSNDBD.XB9OO205.SHS001.I0001.A001
XB9OP004 DVBP4.DSNDBD.XB9OP004.SHS001.I0001.A001
XB9OP007 DVBP4.DSNDBD.XB9OP007.SHS001.I0001.A001
XB9OP013 DVBP4.DSNDBD.XB9OP013.SHS001.I0001.A001
XB9OP014 DVBP4.DSNDBD.XB9OP014.SHS001.I0001.A001
XB9OP021 DVBP4.DSNDBD.XB9OP021.SHS001.I0001.A001
XB9OP025 DVBP4.DSNDBD.XB9OP025.SHS001.I0001.A001
XB9OP037 DVBP4.DSNDBD.XB9OP037.SHS001.I0001.A001
XB9OP049 DVBP4.DSNDBD.XB9OP049.SHS001.I0001.A001
XB9OP053 DVBP4.DSNDBD.XB9OP053.SHS001.I0001.A001
XB9OP063 DVBP4.DSNDBD.XB9OP063.SHS001.I0001.A001
XB9OP065 DVBP4.DSNDBD.XB9OP065.SHS001.I0001.A001
XB9OP072 DVBP4.DSNDBD.XB9OP072.SHS001.I0001.A001
XB9OP076 DVBP4.DSNDBD.XB9OP076.SHS001.I0001.A001
XB9OP078 DVBP4.DSNDBD.XB9OP078.SHS001.I0001.A001
XB9OP083 DVBP4.DSNDBD.XB9OP083.SHS001.I0001.A001
XB9OT001 DVBP4.DSNDBD.XB9OT001.SHS001.I0001.A001
XB9OT002 DVBP4.DSNDBD.XB9OT002.SHS001.I0001.A001
XB9OU001 DVBP4.DSNDBD.XB9OU001.SHS001.I0001.A001
XB9OZ001 DVBP4.DSNDBD.XB9OZ001.SHS001.I0001.A001
XB9O7001 DVBP4.DSNDBD.XB9O7001.SHS001.I0001.A001
XB9O7011 DVBP4.DSNDBD.XB9O7011.SHS001.I0001.A001
XB9O8005 DVBP4.DSNDBD.XB9O8005.SHS001.I0001.A001
XB9O8009 DVBP4.DSNDBD.XB9O8009.SHS001.I0001.A001
XB9O8011 DVBP4.DSNDBD.XB9O8011.SHS001.I0001.A001
XB9O8026 DVBP4.DSNDBD.XB9O8026.SHS001.I0001.A001
XB9O8028 DVBP4.DSNDBD.XB9O8028.SHS001.I0001.A001
XB9O8030 DVBP4.DSNDBD.XB9O8030.SHS001.I0001.A001
XB9O8031 DVBP4.DSNDBD.XB9O8031.SHS001.I0001.A001
XB9O8037 DVBP4.DSNDBD.XB9O8037.SHS001.I0001.A001
XB9O8039 DVBP4.DSNDBD.XB9O8039.SHS001.I0001.A001
XB9O8042 DVBP4.DSNDBD.XB9O8042.SHS001.I0001.A001
XB9O8046 DVBP4.DSNDBD.XB9O8046.SHS001.I0001.A001
XB9O8050 DVBP4.DSNDBD.XB9O8050.SHS001.I0001.A001
XB9O8059 DVBP4.DSNDBD.XB9O8059.SHS001.I0001.A001
XB9O8064 DVBP4.DSNDBD.XB9O8064.SHS001.I0001.A001
XB9O8069 DVBP4.DSNDBD.XB9O8069.SHS001.I0001.A001
XB9O8085 DVBP4.DSNDBD.XB9O8085.SHS001.I0001.A001
XB9O8098 DVBP4.DSNDBD.XB9O8098.SHS001.I0001.A001
XB9O8108 DVBP4.DSNDBD.XB9O8108.SHS001.I0001.A001
XB9O8109 DVBP4.DSNDBD.XB9O8109.SHS001.I0001.A001
XB9P2005 DVBP4.DSNDBD.XB9P2005.SHS001.I0001.A001
XB9P4004 DVBP4.DSNDBD.XB9P4004.SHS001.I0001.A001
XB9P4007 DVBP4.DSNDBD.XB9P4007.SHS001.I0001.A001
XB9P5001 DVBP4.DSNDBD.XB9P5001.SHS001.I0001.A001
XB9P5002 DVBP4.DSNDBD.XB9P5002.SHS001.I0001.A001
XB9P7001 DVBP4.DSNDBD.XB9P7001.SHS001.I0001.A001
noDb 363 0 0 all 671824 0 0 XB9QP002:
t g m k... t g m k...
noDb 363 17599234048 20026114048
all 671824 172254877978624 175287386112000
}¢--- A540769.WK.REXX(ELARORPI) cre=2014-08-19 mod=2014-08-19-14.38.34 A540769 ---
$#@
$*( check vsam Datasets and report if DB.sp is no longer in Db2
optionally, add xHUrba and xHArba
HUrba is only 32 bit which gets truncated|
$*)
$=wRBA = 0 $** with haRBA and huRRA, 0 = without (faster)
call sqlConnect dvbp
numeric digits(20)
$<>
$<#¢
with s as
(
select dbname db , name sp from sysibm.systablespace
union all select dbname db, indexSpace sp from sysibm.sysIndexes
)
select * from s
where not db in
( select db from s100447.telardrop
where kind='disp req' and nm in ('disp07', 'disp08#2')
)
order by db, sp
$!
call sql2St , dbs
$<>
say m.dbs.0 'spaces' m.dbs.222.db m.dbs.222.sp
do dx=1 to m.dbs.0
d1 = strip(m.dbs.dx.db)
s1 = strip(m.dbs.dx.sp)
m.sp2x.d1.s1 = dx
end
call csiOpen csi, 'DVBP*.DSNDBD.**' , copies('XHARBADS XHURBADS', $wRBA)
cNoDb = 0
aUse = 0
aAlc = 0
nUse = 0
nAlc = 0
do c=0 while csiNext(csi, nx)
if $wRBA then $@¢
$** say c2x(m.nx.Xharbads) c2x(m.nx.Xhurbads) m.nx
if m.nx.xhaRBAds == 'ffffffffffffffff'x ,
| m.nx.xhuRBAds == 'ffffffffffffffff'x then do
a1 = 0
u1 = 0
say 'bad rba' m.nx
end
else do
a1 = c2d(m.nx.xharbads)
u1 = c2d(m.nx.xhurbads)
end
aUse = aUse + u1
aAlc = aAlc + a1
$!
parse var m.nx with . '.' . '.' db '.' sp '.' .
$** say db'?'sp'==>'m.nx
if symbol('m.sp2x.db.sp') \== 'VAR' then do
$$- left(db, 8) left(sp, 8) left(m.nx, 44) copies(a1 u1, $wRBA)
cNoDb = cNoDb + 1
if $wRBA then $@¢
nUse = nUse + u1
nAlc = nAlc + a1
$!
end
if c // 10000 = 0 then
say 'noDb' cNoDb nUse nAlc 'all' c aUse aAlc db':'m.nx
end
say 'noDb' cNoDb nUse nAlc 'all' c aUse aAlc db':'m.nx
$$- 'noDb' cNoDb nUse nAlc 'all' c aUse aAlc db':'m.nx
$#out 20140819 14:29:38
DB2PLAN A00100C7 DVBP.DSNDBD.DB2PLAN.A00100C7.D0283978
DSNDB01 DSNSCT02 DVBP.DSNDBD.DSNDB01.DSNSCT02.I0001.A001
DSNDB01 SCT02 DVBP.DSNDBD.DSNDB01.SCT02.I0001.A001
DSNDB04 ORDERRTA DVBP.DSNDBD.DSNDB04.ORDERRTA.J0001.A001
DXB07 EXEPTION DVBP.DSNDBD.DXB07.EXEPTION.J0001.A001
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E5174199
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E5184328
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E9093468
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E9483641
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E9491715
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E9495407
XBZZZZZZ SIT003 DVBP.DSNDBD.XBZZZZZZ.SIT003.E9503088
XBAHD002 SHS001 DVBP1.DSNDBD.XBAHD002.SHS001.I0001.A001
XBAHD012 SHS001 DVBP1.DSNDBD.XBAHD012.SHS001.I0001.A001
XBAHD024 SHS001 DVBP1.DSNDBD.XBAHD024.SHS001.I0001.A001
XBAHM001 SHS001 DVBP1.DSNDBD.XBAHM001.SHS001.I0001.A001
XBAON002 SHS001 DVBP1.DSNDBD.XBAON002.SHS001.I0001.A001
XBDM7001 SPM01002 DVBP1.DSNDBD.XBDM7001.SPM01002.J0001.A007
XB9NY002 SHS001 DVBP1.DSNDBD.XB9NY002.SHS001.I0001.A001
XB9OA001 SHS001 DVBP1.DSNDBD.XB9OA001.SHS001.I0001.A001
XB9OB001 SHS001 DVBP1.DSNDBD.XB9OB001.SHS001.I0001.A001
XB9OC002 SHS001 DVBP1.DSNDBD.XB9OC002.SHS001.I0001.A001
XB9OD001 SHS001 DVBP1.DSNDBD.XB9OD001.SHS001.I0001.A001
XB9OH002 SHS001 DVBP1.DSNDBD.XB9OH002.SHS001.I0001.A001
XB9ON005 SHS001 DVBP1.DSNDBD.XB9ON005.SHS001.I0001.A001
XB9ON011 SHS001 DVBP1.DSNDBD.XB9ON011.SHS001.I0001.A001
XB9ON017 SHS001 DVBP1.DSNDBD.XB9ON017.SHS001.I0001.A001
XB9ON027 SHS001 DVBP1.DSNDBD.XB9ON027.SHS001.I0001.A001
XB9OO004 SHS001 DVBP1.DSNDBD.XB9OO004.SHS001.I0001.A001
XB9OO008 SHS001 DVBP1.DSNDBD.XB9OO008.SHS001.I0001.A001
XB9OO031 SHS001 DVBP1.DSNDBD.XB9OO031.SHS001.I0001.A001
XB9OO034 SHS001 DVBP1.DSNDBD.XB9OO034.SHS001.I0001.A001
XB9OO044 SHS001 DVBP1.DSNDBD.XB9OO044.SHS001.I0001.A001
XB9OO047 SHS001 DVBP1.DSNDBD.XB9OO047.SHS001.I0001.A001
XB9OO054 SHS001 DVBP1.DSNDBD.XB9OO054.SHS001.I0001.A001
XB9OO066 SHS001 DVBP1.DSNDBD.XB9OO066.SHS001.I0001.A001
XB9OO070 SHS001 DVBP1.DSNDBD.XB9OO070.SHS001.I0001.A001
XB9OO085 SHS001 DVBP1.DSNDBD.XB9OO085.SHS001.I0001.A001
XB9OO096 SHS001 DVBP1.DSNDBD.XB9OO096.SHS001.I0001.A001
XB9OO109 SHS001 DVBP1.DSNDBD.XB9OO109.SHS001.I0001.A001
XB9OO114 SHS001 DVBP1.DSNDBD.XB9OO114.SHS001.I0001.A001
XB9OO118 SHS001 DVBP1.DSNDBD.XB9OO118.SHS001.I0001.A001
XB9OO122 SHS001 DVBP1.DSNDBD.XB9OO122.SHS001.I0001.A001
XB9OO127 SHS001 DVBP1.DSNDBD.XB9OO127.SHS001.I0001.A001
XB9OO131 SHS001 DVBP1.DSNDBD.XB9OO131.SHS001.I0001.A001
XB9OO138 SHS001 DVBP1.DSNDBD.XB9OO138.SHS001.I0001.A001
XB9OO139 SHS001 DVBP1.DSNDBD.XB9OO139.SHS001.I0001.A001
XB9OO141 SHS001 DVBP1.DSNDBD.XB9OO141.SHS001.I0001.A001
XB9OO154 SHS001 DVBP1.DSNDBD.XB9OO154.SHS001.I0001.A001
XB9OO165 SHS001 DVBP1.DSNDBD.XB9OO165.SHS001.I0001.A001
XB9OO169 SHS001 DVBP1.DSNDBD.XB9OO169.SHS001.I0001.A001
XB9OO174 SHS001 DVBP1.DSNDBD.XB9OO174.SHS001.I0001.A001
XB9OO178 SHS001 DVBP1.DSNDBD.XB9OO178.SHS001.I0001.A001
XB9OO186 SHS001 DVBP1.DSNDBD.XB9OO186.SHS001.I0001.A001
XB9OO189 SHS001 DVBP1.DSNDBD.XB9OO189.SHS001.I0001.A001
XB9OO197 SHS001 DVBP1.DSNDBD.XB9OO197.SHS001.I0001.A001
XB9OO200 SHS001 DVBP1.DSNDBD.XB9OO200.SHS001.I0001.A001
XB9OO204 SHS001 DVBP1.DSNDBD.XB9OO204.SHS001.I0001.A001
XB9OP001 SHS001 DVBP1.DSNDBD.XB9OP001.SHS001.I0001.A001
XB9OP003 SHS001 DVBP1.DSNDBD.XB9OP003.SHS001.I0001.A001
XB9OP006 SHS001 DVBP1.DSNDBD.XB9OP006.SHS001.I0001.A001
XB9OP010 SHS001 DVBP1.DSNDBD.XB9OP010.SHS001.I0001.A001
XB9OP030 SHS001 DVBP1.DSNDBD.XB9OP030.SHS001.I0001.A001
XB9OP036 SHS001 DVBP1.DSNDBD.XB9OP036.SHS001.I0001.A001
XB9OP040 SHS001 DVBP1.DSNDBD.XB9OP040.SHS001.I0001.A001
XB9OP046 SHS001 DVBP1.DSNDBD.XB9OP046.SHS001.I0001.A001
XB9OP047 SHS001 DVBP1.DSNDBD.XB9OP047.SHS001.I0001.A001
XB9OP054 SHS001 DVBP1.DSNDBD.XB9OP054.SHS001.I0001.A001
XB9OP070 SHS001 DVBP1.DSNDBD.XB9OP070.SHS001.I0001.A001
XB9OP071 SHS001 DVBP1.DSNDBD.XB9OP071.SHS001.I0001.A001
XB9OP082 SHS001 DVBP1.DSNDBD.XB9OP082.SHS001.I0001.A001
XB9OP088 SHS001 DVBP1.DSNDBD.XB9OP088.SHS001.I0001.A001
XB9OP091 SHS001 DVBP1.DSNDBD.XB9OP091.SHS001.I0001.A001
XB9OS001 SHS001 DVBP1.DSNDBD.XB9OS001.SHS001.I0001.A001
XB9OS002 SHS001 DVBP1.DSNDBD.XB9OS002.SHS001.I0001.A001
XB9OX002 SHS001 DVBP1.DSNDBD.XB9OX002.SHS001.I0001.A001
XB9O7002 SHS001 DVBP1.DSNDBD.XB9O7002.SHS001.I0001.A001
XB9O7010 SHS001 DVBP1.DSNDBD.XB9O7010.SHS001.I0001.A001
XB9O8002 SHS001 DVBP1.DSNDBD.XB9O8002.SHS001.I0001.A001
XB9O8004 SHS001 DVBP1.DSNDBD.XB9O8004.SHS001.I0001.A001
XB9O8007 SHS001 DVBP1.DSNDBD.XB9O8007.SHS001.I0001.A001
XB9O8010 SHS001 DVBP1.DSNDBD.XB9O8010.SHS001.I0001.A001
XB9O8014 SHS001 DVBP1.DSNDBD.XB9O8014.SHS001.I0001.A001
XB9O8027 SHS001 DVBP1.DSNDBD.XB9O8027.SHS001.I0001.A001
XB9O8033 SHS001 DVBP1.DSNDBD.XB9O8033.SHS001.I0001.A001
XB9O8043 SHS001 DVBP1.DSNDBD.XB9O8043.SHS001.I0001.A001
XB9O8044 SHS001 DVBP1.DSNDBD.XB9O8044.SHS001.I0001.A001
XB9O8051 SHS001 DVBP1.DSNDBD.XB9O8051.SHS001.I0001.A001
XB9O8058 SHS001 DVBP1.DSNDBD.XB9O8058.SHS001.I0001.A001
XB9O8062 SHS001 DVBP1.DSNDBD.XB9O8062.SHS001.I0001.A001
XB9O8067 SHS001 DVBP1.DSNDBD.XB9O8067.SHS001.I0001.A001
XB9O8068 SHS001 DVBP1.DSNDBD.XB9O8068.SHS001.I0001.A001
XB9O8072 SHS001 DVBP1.DSNDBD.XB9O8072.SHS001.I0001.A001
XB9O8107 SHS001 DVBP1.DSNDBD.XB9O8107.SHS001.I0001.A001
XB9PB002 SHS001 DVBP1.DSNDBD.XB9PB002.SHS001.I0001.A001
XB9P2002 SHS001 DVBP1.DSNDBD.XB9P2002.SHS001.I0001.A001
XB9P3003 SHS001 DVBP1.DSNDBD.XB9P3003.SHS001.I0001.A001
XB9P4002 SHS001 DVBP1.DSNDBD.XB9P4002.SHS001.I0001.A001
XB9P4006 SHS001 DVBP1.DSNDBD.XB9P4006.SHS001.I0001.A001
XBAHD008 SHS001 DVBP2.DSNDBD.XBAHD008.SHS001.I0001.A001
XBAHD009 SHS001 DVBP2.DSNDBD.XBAHD009.SHS001.I0001.A001
XBAHD019 SHS001 DVBP2.DSNDBD.XBAHD019.SHS001.I0001.A001
XBAHD029 SHS001 DVBP2.DSNDBD.XBAHD029.SHS001.I0001.A001
XBAOQ001 SHS001 DVBP2.DSNDBD.XBAOQ001.SHS001.I0001.A001
XBAT8002 SHS001 DVBP2.DSNDBD.XBAT8002.SHS001.I0001.A001
XBB9H001 SHS001 DVBP2.DSNDBD.XBB9H001.SHS001.I0001.A001
XB9NR002 SHS001 DVBP2.DSNDBD.XB9NR002.SHS001.I0001.A001
XB9NS001 SHS001 DVBP2.DSNDBD.XB9NS001.SHS001.I0001.A001
XB9NZ001 SHS001 DVBP2.DSNDBD.XB9NZ001.SHS001.I0001.A001
XB9OB002 SHS001 DVBP2.DSNDBD.XB9OB002.SHS001.I0001.A001
XB9OF002 SHS001 DVBP2.DSNDBD.XB9OF002.SHS001.I0001.A001
XB9ON001 SHS001 DVBP2.DSNDBD.XB9ON001.SHS001.I0001.A001
XB9ON010 SHS001 DVBP2.DSNDBD.XB9ON010.SHS001.I0001.A001
XB9ON016 SHS001 DVBP2.DSNDBD.XB9ON016.SHS001.I0001.A001
XB9ON022 SHS001 DVBP2.DSNDBD.XB9ON022.SHS001.I0001.A001
XB9OO001 SHS001 DVBP2.DSNDBD.XB9OO001.SHS001.I0001.A001
XB9OO003 SHS001 DVBP2.DSNDBD.XB9OO003.SHS001.I0001.A001
XB9OO012 SHS001 DVBP2.DSNDBD.XB9OO012.SHS001.I0001.A001
XB9OO023 SHS001 DVBP2.DSNDBD.XB9OO023.SHS001.I0001.A001
XB9OO029 SHS001 DVBP2.DSNDBD.XB9OO029.SHS001.I0001.A001
XB9OO033 SHS001 DVBP2.DSNDBD.XB9OO033.SHS001.I0001.A001
XB9OO043 SHS001 DVBP2.DSNDBD.XB9OO043.SHS001.I0001.A001
XB9OO046 SHS001 DVBP2.DSNDBD.XB9OO046.SHS001.I0001.A001
XB9OO061 SHS001 DVBP2.DSNDBD.XB9OO061.SHS001.I0001.A001
XB9OO065 SHS001 DVBP2.DSNDBD.XB9OO065.SHS001.I0001.A001
XB9OO069 SHS001 DVBP2.DSNDBD.XB9OO069.SHS001.I0001.A001
XB9OO074 SHS001 DVBP2.DSNDBD.XB9OO074.SHS001.I0001.A001
XB9OO084 SHS001 DVBP2.DSNDBD.XB9OO084.SHS001.I0001.A001
XB9OO088 SHS001 DVBP2.DSNDBD.XB9OO088.SHS001.I0001.A001
XB9OO091 SHS001 DVBP2.DSNDBD.XB9OO091.SHS001.I0001.A001
XB9OO095 SHS001 DVBP2.DSNDBD.XB9OO095.SHS001.I0001.A001
XB9OO099 SHS001 DVBP2.DSNDBD.XB9OO099.SHS001.I0001.A001
XB9OO112 SHS001 DVBP2.DSNDBD.XB9OO112.SHS001.I0001.A001
XB9OO121 SHS001 DVBP2.DSNDBD.XB9OO121.SHS001.I0001.A001
XB9OO130 SHS001 DVBP2.DSNDBD.XB9OO130.SHS001.I0001.A001
XB9OO140 SHS001 DVBP2.DSNDBD.XB9OO140.SHS001.I0001.A001
XB9OO150 SHS001 DVBP2.DSNDBD.XB9OO150.SHS001.I0001.A001
XB9OO161 SHS001 DVBP2.DSNDBD.XB9OO161.SHS001.I0001.A001
XB9OO177 SHS001 DVBP2.DSNDBD.XB9OO177.SHS001.I0001.A001
XB9OO182 SHS001 DVBP2.DSNDBD.XB9OO182.SHS001.I0001.A001
XB9OO185 SHS001 DVBP2.DSNDBD.XB9OO185.SHS001.I0001.A001
XB9OO188 SHS001 DVBP2.DSNDBD.XB9OO188.SHS001.I0001.A001
XB9OO192 SHS001 DVBP2.DSNDBD.XB9OO192.SHS001.I0001.A001
XB9OO203 SHS001 DVBP2.DSNDBD.XB9OO203.SHS001.I0001.A001
XB9OP009 SHS001 DVBP2.DSNDBD.XB9OP009.SHS001.I0001.A001
XB9OP023 SHS001 DVBP2.DSNDBD.XB9OP023.SHS001.I0001.A001
XB9OP039 SHS001 DVBP2.DSNDBD.XB9OP039.SHS001.I0001.A001
XB9OP051 SHS001 DVBP2.DSNDBD.XB9OP051.SHS001.I0001.A001
XB9OP061 SHS001 DVBP2.DSNDBD.XB9OP061.SHS001.I0001.A001
XB9OP062 SHS001 DVBP2.DSNDBD.XB9OP062.SHS001.I0001.A001
XB9OP069 SHS001 DVBP2.DSNDBD.XB9OP069.SHS001.I0001.A001
XB9OP085 SHS001 DVBP2.DSNDBD.XB9OP085.SHS001.I0001.A001
XB9OP087 SHS001 DVBP2.DSNDBD.XB9OP087.SHS001.I0001.A001
XB9OP090 SHS001 DVBP2.DSNDBD.XB9OP090.SHS001.I0001.A001
XB9OP094 SHS001 DVBP2.DSNDBD.XB9OP094.SHS001.I0001.A001
XB9OR002 SHS001 DVBP2.DSNDBD.XB9OR002.SHS001.I0001.A001
XB9OV002 SHS001 DVBP2.DSNDBD.XB9OV002.SHS001.I0001.A001
XB9O7005 SHS001 DVBP2.DSNDBD.XB9O7005.SHS001.I0001.A001
XB9O7013 SHS001 DVBP2.DSNDBD.XB9O7013.SHS001.I0001.A001
XB9O8003 SHS001 DVBP2.DSNDBD.XB9O8003.SHS001.I0001.A001
XB9O8020 SHS001 DVBP2.DSNDBD.XB9O8020.SHS001.I0001.A001
XB9O8022 SHS001 DVBP2.DSNDBD.XB9O8022.SHS001.I0001.A001
XB9O8036 SHS001 DVBP2.DSNDBD.XB9O8036.SHS001.I0001.A001
XB9O8045 SHS001 DVBP2.DSNDBD.XB9O8045.SHS001.I0001.A001
XB9O8048 SHS001 DVBP2.DSNDBD.XB9O8048.SHS001.I0001.A001
XB9O8057 SHS001 DVBP2.DSNDBD.XB9O8057.SHS001.I0001.A001
XB9O8061 SHS001 DVBP2.DSNDBD.XB9O8061.SHS001.I0001.A001
XB9O8074 SHS001 DVBP2.DSNDBD.XB9O8074.SHS001.I0001.A001
XB9O8081 SHS001 DVBP2.DSNDBD.XB9O8081.SHS001.I0001.A001
XB9O8084 SHS001 DVBP2.DSNDBD.XB9O8084.SHS001.I0001.A001
XB9O8087 SHS001 DVBP2.DSNDBD.XB9O8087.SHS001.I0001.A001
XB9O8095 SHS001 DVBP2.DSNDBD.XB9O8095.SHS001.I0001.A001
XB9O8102 SHS001 DVBP2.DSNDBD.XB9O8102.SHS001.I0001.A001
XB9O8111 SHS001 DVBP2.DSNDBD.XB9O8111.SHS001.I0001.A001
XB9O8113 SHS001 DVBP2.DSNDBD.XB9O8113.SHS001.I0001.A001
XB9P2004 SHS001 DVBP2.DSNDBD.XB9P2004.SHS001.I0001.A001
XB9P3001 SHS001 DVBP2.DSNDBD.XB9P3001.SHS001.I0001.A001
XB9P8001 SHS001 DVBP2.DSNDBD.XB9P8001.SHS001.I0001.A001
XB9ZT001 SHS001 DVBP2.DSNDBD.XB9ZT001.SHS001.I0001.A001
XB9ZU002 SHS001 DVBP2.DSNDBD.XB9ZU002.SHS001.I0001.A001
XB9ZV001 SHS001 DVBP2.DSNDBD.XB9ZV001.SHS001.I0001.A001
XBAHD001 SHS001 DVBP3.DSNDBD.XBAHD001.SHS001.I0001.A001
XBAHD010 SHS001 DVBP3.DSNDBD.XBAHD010.SHS001.I0001.A001
XBAHD011 SHS001 DVBP3.DSNDBD.XBAHD011.SHS001.I0001.A001
XBAHD017 SHS001 DVBP3.DSNDBD.XBAHD017.SHS001.I0001.A001
XBAHD021 SHS001 DVBP3.DSNDBD.XBAHD021.SHS001.I0001.A001
XBAHD025 SHS001 DVBP3.DSNDBD.XBAHD025.SHS001.I0001.A001
XBAOQ002 SHS001 DVBP3.DSNDBD.XBAOQ002.SHS001.I0001.A001
XBAQC001 SHS001 DVBP3.DSNDBD.XBAQC001.SHS001.I0001.A001
XBAT8001 SHS001 DVBP3.DSNDBD.XBAT8001.SHS001.I0001.A001
XBB9G001 SHS001 DVBP3.DSNDBD.XBB9G001.SHS001.I0001.A001
XB217032 SIT002 DVBP3.DSNDBD.XB217032.SIT002.I0001.A001
XB217032 SPS001 DVBP3.DSNDBD.XB217032.SPS001.I0001.A001
XB9JC855 SHS001 DVBP3.DSNDBD.XB9JC855.SHS001.I0001.A001
XB9NS002 SHS001 DVBP3.DSNDBD.XB9NS002.SHS001.I0001.A001
XB9NS003 SHS001 DVBP3.DSNDBD.XB9NS003.SHS001.I0001.A001
XB9NS007 SHS001 DVBP3.DSNDBD.XB9NS007.SHS001.I0001.A001
XB9NS008 SHS001 DVBP3.DSNDBD.XB9NS008.SHS001.I0001.A001
XB9NU002 SHS001 DVBP3.DSNDBD.XB9NU002.SHS001.I0001.A001
XB9NV001 SHS001 DVBP3.DSNDBD.XB9NV001.SHS001.I0001.A001
XB9NY001 SHS001 DVBP3.DSNDBD.XB9NY001.SHS001.I0001.A001
XB9ON002 SHS001 DVBP3.DSNDBD.XB9ON002.SHS001.I0001.A001
XB9ON003 SHS001 DVBP3.DSNDBD.XB9ON003.SHS001.I0001.A001
XB9ON006 SHS001 DVBP3.DSNDBD.XB9ON006.SHS001.I0001.A001
XB9ON007 SHS001 DVBP3.DSNDBD.XB9ON007.SHS001.I0001.A001
XB9ON038 SHS001 DVBP3.DSNDBD.XB9ON038.SHS001.I0001.A001
XB9OO006 SHS001 DVBP3.DSNDBD.XB9OO006.SHS001.I0001.A001
XB9OO010 SHS001 DVBP3.DSNDBD.XB9OO010.SHS001.I0001.A001
XB9OO015 SHS001 DVBP3.DSNDBD.XB9OO015.SHS001.I0001.A001
XB9OO022 SHS001 DVBP3.DSNDBD.XB9OO022.SHS001.I0001.A001
XB9OO026 SHS001 DVBP3.DSNDBD.XB9OO026.SHS001.I0001.A001
XB9OO028 SHS001 DVBP3.DSNDBD.XB9OO028.SHS001.I0001.A001
XB9OO032 SHS001 DVBP3.DSNDBD.XB9OO032.SHS001.I0001.A001
XB9OO040 SHS001 DVBP3.DSNDBD.XB9OO040.SHS001.I0001.A001
XB9OO056 SHS001 DVBP3.DSNDBD.XB9OO056.SHS001.I0001.A001
XB9OO060 SHS001 DVBP3.DSNDBD.XB9OO060.SHS001.I0001.A001
XB9OO064 SHS001 DVBP3.DSNDBD.XB9OO064.SHS001.I0001.A001
XB9OO067 SHS001 DVBP3.DSNDBD.XB9OO067.SHS001.I0001.A001
XB9OO073 SHS001 DVBP3.DSNDBD.XB9OO073.SHS001.I0001.A001
XB9OO079 SHS001 DVBP3.DSNDBD.XB9OO079.SHS001.I0001.A001
XB9OO087 SHS001 DVBP3.DSNDBD.XB9OO087.SHS001.I0001.A001
XB9OO094 SHS001 DVBP3.DSNDBD.XB9OO094.SHS001.I0001.A001
XB9OO107 SHS001 DVBP3.DSNDBD.XB9OO107.SHS001.I0001.A001
XB9OO111 SHS001 DVBP3.DSNDBD.XB9OO111.SHS001.I0001.A001
XB9OO116 SHS001 DVBP3.DSNDBD.XB9OO116.SHS001.I0001.A001
XB9OO120 SHS001 DVBP3.DSNDBD.XB9OO120.SHS001.I0001.A001
XB9OO124 SHS001 DVBP3.DSNDBD.XB9OO124.SHS001.I0001.A001
XB9OO133 SHS001 DVBP3.DSNDBD.XB9OO133.SHS001.I0001.A001
XB9OO147 SHS001 DVBP3.DSNDBD.XB9OO147.SHS001.I0001.A001
XB9OO156 SHS001 DVBP3.DSNDBD.XB9OO156.SHS001.I0001.A001
XB9OO160 SHS001 DVBP3.DSNDBD.XB9OO160.SHS001.I0001.A001
XB9OO172 SHS001 DVBP3.DSNDBD.XB9OO172.SHS001.I0001.A001
XB9OO176 SHS001 DVBP3.DSNDBD.XB9OO176.SHS001.I0001.A001
XB9OO180 SHS001 DVBP3.DSNDBD.XB9OO180.SHS001.I0001.A001
XB9OO199 SHS001 DVBP3.DSNDBD.XB9OO199.SHS001.I0001.A001
XB9OO202 SHS001 DVBP3.DSNDBD.XB9OO202.SHS001.I0001.A001
XB9OO206 SHS001 DVBP3.DSNDBD.XB9OO206.SHS001.I0001.A001
XB9OP008 SHS001 DVBP3.DSNDBD.XB9OP008.SHS001.I0001.A001
XB9OP020 SHS001 DVBP3.DSNDBD.XB9OP020.SHS001.I0001.A001
XB9OP022 SHS001 DVBP3.DSNDBD.XB9OP022.SHS001.I0001.A001
XB9OP028 SHS001 DVBP3.DSNDBD.XB9OP028.SHS001.I0001.A001
XB9OP031 SHS001 DVBP3.DSNDBD.XB9OP031.SHS001.I0001.A001
XB9OP034 SHS001 DVBP3.DSNDBD.XB9OP034.SHS001.I0001.A001
XB9OP048 SHS001 DVBP3.DSNDBD.XB9OP048.SHS001.I0001.A001
XB9OP084 SHS001 DVBP3.DSNDBD.XB9OP084.SHS001.I0001.A001
XB9OP089 SHS001 DVBP3.DSNDBD.XB9OP089.SHS001.I0001.A001
XB9OP093 SHS001 DVBP3.DSNDBD.XB9OP093.SHS001.I0001.A001
XB9OQ002 SHS001 DVBP3.DSNDBD.XB9OQ002.SHS001.I0001.A001
XB9OR001 SHS001 DVBP3.DSNDBD.XB9OR001.SHS001.I0001.A001
XB9OU004 SHS001 DVBP3.DSNDBD.XB9OU004.SHS001.I0001.A001
XB9OV001 SHS001 DVBP3.DSNDBD.XB9OV001.SHS001.I0001.A001
XB9O6001 SHS001 DVBP3.DSNDBD.XB9O6001.SHS001.I0001.A001
XB9O8019 SHS001 DVBP3.DSNDBD.XB9O8019.SHS001.I0001.A001
XB9O8025 SHS001 DVBP3.DSNDBD.XB9O8025.SHS001.I0001.A001
XB9O8032 SHS001 DVBP3.DSNDBD.XB9O8032.SHS001.I0001.A001
XB9O8047 SHS001 DVBP3.DSNDBD.XB9O8047.SHS001.I0001.A001
XB9O8060 SHS001 DVBP3.DSNDBD.XB9O8060.SHS001.I0001.A001
XB9O8073 SHS001 DVBP3.DSNDBD.XB9O8073.SHS001.I0001.A001
XB9O8079 SHS001 DVBP3.DSNDBD.XB9O8079.SHS001.I0001.A001
XB9O8082 SHS001 DVBP3.DSNDBD.XB9O8082.SHS001.I0001.A001
XB9O8086 SHS001 DVBP3.DSNDBD.XB9O8086.SHS001.I0001.A001
XB9O8097 SHS001 DVBP3.DSNDBD.XB9O8097.SHS001.I0001.A001
XB9O8101 SHS001 DVBP3.DSNDBD.XB9O8101.SHS001.I0001.A001
XB9O8106 SHS001 DVBP3.DSNDBD.XB9O8106.SHS001.I0001.A001
XB9O8110 SHS001 DVBP3.DSNDBD.XB9O8110.SHS001.I0001.A001
XB9O8112 SHS001 DVBP3.DSNDBD.XB9O8112.SHS001.I0001.A001
XB9O9002 SHS001 DVBP3.DSNDBD.XB9O9002.SHS001.I0001.A001
XB9O9007 SHS001 DVBP3.DSNDBD.XB9O9007.SHS001.I0001.A001
XB9O9009 SHS001 DVBP3.DSNDBD.XB9O9009.SHS001.I0001.A001
XB9PB001 SHS001 DVBP3.DSNDBD.XB9PB001.SHS001.I0001.A001
XB9PI001 SHS001 DVBP3.DSNDBD.XB9PI001.SHS001.I0001.A001
XB9P2003 SHS001 DVBP3.DSNDBD.XB9P2003.SHS001.I0001.A001
XB9ZT002 SHS001 DVBP3.DSNDBD.XB9ZT002.SHS001.I0001.A001
XB9ZU001 SHS001 DVBP3.DSNDBD.XB9ZU001.SHS001.I0001.A001
XBAHD003 SHS001 DVBP4.DSNDBD.XBAHD003.SHS001.I0001.A001
XBAHD014 SHS001 DVBP4.DSNDBD.XBAHD014.SHS001.I0001.A001
XBAHR001 SHS001 DVBP4.DSNDBD.XBAHR001.SHS001.I0001.A001
XBAL7001 SHS001 DVBP4.DSNDBD.XBAL7001.SHS001.I0001.A001
XB9NR001 SHS001 DVBP4.DSNDBD.XB9NR001.SHS001.I0001.A001
XB9NZ002 SHS001 DVBP4.DSNDBD.XB9NZ002.SHS001.I0001.A001
XB9OF001 SHS001 DVBP4.DSNDBD.XB9OF001.SHS001.I0001.A001
XB9OJ002 SHS001 DVBP4.DSNDBD.XB9OJ002.SHS001.I0001.A001
XB9OM001 SHS001 DVBP4.DSNDBD.XB9OM001.SHS001.I0001.A001
XB9ON019 SHS001 DVBP4.DSNDBD.XB9ON019.SHS001.I0001.A001
XB9ON021 SHS001 DVBP4.DSNDBD.XB9ON021.SHS001.I0001.A001
XB9ON028 SHS001 DVBP4.DSNDBD.XB9ON028.SHS001.I0001.A001
XB9ON035 SHS001 DVBP4.DSNDBD.XB9ON035.SHS001.I0001.A001
XB9ON036 SHS001 DVBP4.DSNDBD.XB9ON036.SHS001.I0001.A001
XB9ON037 SHS001 DVBP4.DSNDBD.XB9ON037.SHS001.I0001.A001
XB9ON039 SHS001 DVBP4.DSNDBD.XB9ON039.SHS001.I0001.A001
XB9OO005 SHS001 DVBP4.DSNDBD.XB9OO005.SHS001.I0001.A001
XB9OO009 SHS001 DVBP4.DSNDBD.XB9OO009.SHS001.I0001.A001
XB9OO014 SHS001 DVBP4.DSNDBD.XB9OO014.SHS001.I0001.A001
XB9OO017 SHS001 DVBP4.DSNDBD.XB9OO017.SHS001.I0001.A001
XB9OO027 SHS001 DVBP4.DSNDBD.XB9OO027.SHS001.I0001.A001
XB9OO039 SHS001 DVBP4.DSNDBD.XB9OO039.SHS001.I0001.A001
XB9OO041 SHS001 DVBP4.DSNDBD.XB9OO041.SHS001.I0001.A001
XB9OO045 SHS001 DVBP4.DSNDBD.XB9OO045.SHS001.I0001.A001
XB9OO048 SHS001 DVBP4.DSNDBD.XB9OO048.SHS001.I0001.A001
XB9OO051 SHS001 DVBP4.DSNDBD.XB9OO051.SHS001.I0001.A001
XB9OO063 SHS001 DVBP4.DSNDBD.XB9OO063.SHS001.I0001.A001
XB9OO072 SHS001 DVBP4.DSNDBD.XB9OO072.SHS001.I0001.A001
XB9OO082 SHS001 DVBP4.DSNDBD.XB9OO082.SHS001.I0001.A001
XB9OO086 SHS001 DVBP4.DSNDBD.XB9OO086.SHS001.I0001.A001
XB9OO101 SHS001 DVBP4.DSNDBD.XB9OO101.SHS001.I0001.A001
XB9OO105 SHS001 DVBP4.DSNDBD.XB9OO105.SHS001.I0001.A001
XB9OO106 SHS001 DVBP4.DSNDBD.XB9OO106.SHS001.I0001.A001
XB9OO110 SHS001 DVBP4.DSNDBD.XB9OO110.SHS001.I0001.A001
XB9OO115 SHS001 DVBP4.DSNDBD.XB9OO115.SHS001.I0001.A001
XB9OO119 SHS001 DVBP4.DSNDBD.XB9OO119.SHS001.I0001.A001
XB9OO123 SHS001 DVBP4.DSNDBD.XB9OO123.SHS001.I0001.A001
XB9OO128 SHS001 DVBP4.DSNDBD.XB9OO128.SHS001.I0001.A001
XB9OO132 SHS001 DVBP4.DSNDBD.XB9OO132.SHS001.I0001.A001
XB9OO142 SHS001 DVBP4.DSNDBD.XB9OO142.SHS001.I0001.A001
XB9OO152 SHS001 DVBP4.DSNDBD.XB9OO152.SHS001.I0001.A001
XB9OO155 SHS001 DVBP4.DSNDBD.XB9OO155.SHS001.I0001.A001
XB9OO171 SHS001 DVBP4.DSNDBD.XB9OO171.SHS001.I0001.A001
XB9OO184 SHS001 DVBP4.DSNDBD.XB9OO184.SHS001.I0001.A001
XB9OO194 SHS001 DVBP4.DSNDBD.XB9OO194.SHS001.I0001.A001
XB9OO198 SHS001 DVBP4.DSNDBD.XB9OO198.SHS001.I0001.A001
XB9OO201 SHS001 DVBP4.DSNDBD.XB9OO201.SHS001.I0001.A001
XB9OO205 SHS001 DVBP4.DSNDBD.XB9OO205.SHS001.I0001.A001
XB9OP004 SHS001 DVBP4.DSNDBD.XB9OP004.SHS001.I0001.A001
XB9OP007 SHS001 DVBP4.DSNDBD.XB9OP007.SHS001.I0001.A001
XB9OP013 SHS001 DVBP4.DSNDBD.XB9OP013.SHS001.I0001.A001
XB9OP014 SHS001 DVBP4.DSNDBD.XB9OP014.SHS001.I0001.A001
XB9OP021 SHS001 DVBP4.DSNDBD.XB9OP021.SHS001.I0001.A001
XB9OP025 SHS001 DVBP4.DSNDBD.XB9OP025.SHS001.I0001.A001
XB9OP037 SHS001 DVBP4.DSNDBD.XB9OP037.SHS001.I0001.A001
XB9OP049 SHS001 DVBP4.DSNDBD.XB9OP049.SHS001.I0001.A001
XB9OP053 SHS001 DVBP4.DSNDBD.XB9OP053.SHS001.I0001.A001
XB9OP063 SHS001 DVBP4.DSNDBD.XB9OP063.SHS001.I0001.A001
XB9OP065 SHS001 DVBP4.DSNDBD.XB9OP065.SHS001.I0001.A001
XB9OP072 SHS001 DVBP4.DSNDBD.XB9OP072.SHS001.I0001.A001
XB9OP076 SHS001 DVBP4.DSNDBD.XB9OP076.SHS001.I0001.A001
XB9OP078 SHS001 DVBP4.DSNDBD.XB9OP078.SHS001.I0001.A001
XB9OP083 SHS001 DVBP4.DSNDBD.XB9OP083.SHS001.I0001.A001
XB9OT001 SHS001 DVBP4.DSNDBD.XB9OT001.SHS001.I0001.A001
XB9OT002 SHS001 DVBP4.DSNDBD.XB9OT002.SHS001.I0001.A001
XB9OU001 SHS001 DVBP4.DSNDBD.XB9OU001.SHS001.I0001.A001
XB9OZ001 SHS001 DVBP4.DSNDBD.XB9OZ001.SHS001.I0001.A001
XB9O7001 SHS001 DVBP4.DSNDBD.XB9O7001.SHS001.I0001.A001
XB9O7011 SHS001 DVBP4.DSNDBD.XB9O7011.SHS001.I0001.A001
XB9O8005 SHS001 DVBP4.DSNDBD.XB9O8005.SHS001.I0001.A001
XB9O8009 SHS001 DVBP4.DSNDBD.XB9O8009.SHS001.I0001.A001
XB9O8011 SHS001 DVBP4.DSNDBD.XB9O8011.SHS001.I0001.A001
XB9O8026 SHS001 DVBP4.DSNDBD.XB9O8026.SHS001.I0001.A001
XB9O8028 SHS001 DVBP4.DSNDBD.XB9O8028.SHS001.I0001.A001
XB9O8030 SHS001 DVBP4.DSNDBD.XB9O8030.SHS001.I0001.A001
XB9O8031 SHS001 DVBP4.DSNDBD.XB9O8031.SHS001.I0001.A001
XB9O8037 SHS001 DVBP4.DSNDBD.XB9O8037.SHS001.I0001.A001
XB9O8039 SHS001 DVBP4.DSNDBD.XB9O8039.SHS001.I0001.A001
XB9O8042 SHS001 DVBP4.DSNDBD.XB9O8042.SHS001.I0001.A001
XB9O8046 SHS001 DVBP4.DSNDBD.XB9O8046.SHS001.I0001.A001
XB9O8050 SHS001 DVBP4.DSNDBD.XB9O8050.SHS001.I0001.A001
XB9O8059 SHS001 DVBP4.DSNDBD.XB9O8059.SHS001.I0001.A001
XB9O8064 SHS001 DVBP4.DSNDBD.XB9O8064.SHS001.I0001.A001
XB9O8069 SHS001 DVBP4.DSNDBD.XB9O8069.SHS001.I0001.A001
XB9O8085 SHS001 DVBP4.DSNDBD.XB9O8085.SHS001.I0001.A001
XB9O8098 SHS001 DVBP4.DSNDBD.XB9O8098.SHS001.I0001.A001
XB9O8108 SHS001 DVBP4.DSNDBD.XB9O8108.SHS001.I0001.A001
XB9O8109 SHS001 DVBP4.DSNDBD.XB9O8109.SHS001.I0001.A001
XB9P2005 SHS001 DVBP4.DSNDBD.XB9P2005.SHS001.I0001.A001
XB9P4004 SHS001 DVBP4.DSNDBD.XB9P4004.SHS001.I0001.A001
XB9P4007 SHS001 DVBP4.DSNDBD.XB9P4007.SHS001.I0001.A001
XB9P5001 SHS001 DVBP4.DSNDBD.XB9P5001.SHS001.I0001.A001
XB9P5002 SHS001 DVBP4.DSNDBD.XB9P5002.SHS001.I0001.A001
XB9P7001 SHS001 DVBP4.DSNDBD.XB9P7001.SHS001.I0001.A001
noDb 368 0 0 all 671854 0 0 XB9QP002:
$#out 20140819 14:18:52
}¢--- A540769.WK.REXX(ELCOMALO) cre=2010-01-11 mod=2010-01-18-12.17.59 A540769 ---
$<~WK.REXX(ELCOMATB) $>.jclSub()
$@¢
$=c=0
$=date=D2010014
$@for li $@¢
parse upper value $li with c1 oTs c2 otb .
if c1 <> 'TS' | c2 <> 'TB' | otb = '' | ots = '' then
call err 'bad line' $li
$=c=-$c+1
$** if $c > 2 then leave $** für kurze Tests
$=jc=-'//*'
oTs = overlay('P', oTs, 7)
oTb = overlay('P', oTb, 4)
nTs = overlay('T', oTs, 7)'C4'
nTb = overlay('T', left(oTb, 6), 4)'EL' ,
|| substr(oTb, 7, length(oTb)-8)'C4'
$=oTs=-oTs
$=oSn=-substr(oTs, pos('.', oTs)+1)
$=oTb=-oTb
$=nTs=-nTs
$=nTb=-nTb
say $c 'old' ots ' in' oTb 'new' nts 'in' nTb
if $oSn = 'A860A' then do
say 'skipping' oTs
iterate
end
if $c = 1 then $@=¢
//A540769L JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
${jc}MAIN CLASS=LOG
$jc
$jc load
$jc **************************************************
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769L.LOAD'),
// REGION=0M
$jc DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DSN=DBTF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
$!
$@=¢
TEMPLATE TSREC$c DSN('A540769.TMPUL.$oSn.$date.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
$=pun=A540769.TMPUL.$oSn.$date.UNLPUN
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC$c
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE $nTb
$!
$=st=0
$;
$<$pun $@for pu $@¢
if pos('INTO', $pu) > 0 then do
if $st=0 then
$=st=1
else
call err 'second into' strip($pu)
end
else if abbrev(strip($pu), '(') then do
if $st \= 1 then
call err 'bad ( in' strip($pu)
$=st=2
if abbrev(strip($pu), '( "DSN_IDENTITY"') > 0 then do
say 'old???' $pu
if $oSn \= 'A863A' then
call err 'bad oSn' $oSn 'for' strip($pu)
$=pu =- '( "KS863001"' substr($pu, pos('(', $pu)+18)
say 'new???' $pu
end
end
else if abbrev(strip($pu), ')') then do
if $st = 2 then
$=st=3
else
call err 'bad ) in' strip($pu)
end
if $st >= 2 then
$$ $pu
if $st >= 3 then
leave
$!
$!
$!
$#out 20100114 16:45:45
$#out 20100114 16:45:02
//A540769L JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//*MAIN CLASS=LOG
//*
//* load
//* **************************************************
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769L.LOAD'),
// REGION=0M
//* DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DSN=DBTF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
TEMPLATE TSREC1 DSN('A540769.TMPUL.A831A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC1
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS831C4
( "KS831010"
POSITION( 00003:00022) CHAR(00020)
, "KS831020"
POSITION( 00023:00042) CHAR(00020)
, "KS831030"
POSITION( 00043:00046) CHAR(00004)
, "KS831040"
POSITION( 00047:00081) CHAR(00035)
, "KS831050"
POSITION( 00082:00086) CHAR(00005)
, "KS831060"
POSITION( 00087:00226) CHAR(00140)
, "KS831070"
POSITION( 00227:00228) CHAR(00002)
, "KS831080"
POSITION( 00229:00238) DATE EXTERNAL
, "KS831090"
POSITION( 00239:00248) DATE EXTERNAL
, "KS831100"
POSITION( 00249:00258) DATE EXTERNAL
, "KS831110"
POSITION( 00259:00268) DATE EXTERNAL
, "KS831120"
POSITION( 00269:00294) TIMESTAMP EXTERNAL
, "KS831130"
POSITION( 00295:00304) CHAR(00010)
, "KS831140"
POSITION( 00305:00330) TIMESTAMP EXTERNAL
, "KS831150"
POSITION( 00331:00333) CHAR(00003)
, "KS831160"
POSITION( 00334:00336) CHAR(00003)
, "KS831170"
POSITION( 00337:00339) CHAR(00003)
)
TEMPLATE TSREC2 DSN('A540769.TMPUL.A832A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC2
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS832C4
( "KS832010"
POSITION( 00003:00022) CHAR(00020)
, "KS832020"
POSITION( 00023:00042) CHAR(00020)
, "KS832030"
POSITION( 00043:00046) CHAR(00004)
, "KS832040"
POSITION( 00047:00050) INTEGER
, "KS832050"
POSITION( 00051:00190) CHAR(00140)
, "KS832060"
POSITION( 00191:00192) CHAR(00002)
, "KS832070"
POSITION( 00193:00202) DATE EXTERNAL
, "KS832080"
POSITION( 00203:00212) DATE EXTERNAL
, "KS832090"
POSITION( 00213:00222) DATE EXTERNAL
, "KS832100"
POSITION( 00223:00232) DATE EXTERNAL
, "KS832110"
POSITION( 00233:00258) TIMESTAMP EXTERNAL
, "KS832120"
POSITION( 00259:00268) CHAR(00010)
, "KS832130"
POSITION( 00269:00294) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC3 DSN('A540769.TMPUL.A833A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC3
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS833C4
( "KS833010"
POSITION( 00003:00022) CHAR(00020)
, "KS833020"
POSITION( 00023:00042) CHAR(00020)
, "KS833030"
POSITION( 00043:00046) INTEGER
, "KS833040"
POSITION( 00047:00050) CHAR(00004)
, "KS833050"
POSITION( 00051:00054) CHAR(00004)
, "KS833060"
POSITION( 00055:00074) CHAR(00020)
, "KS833070"
POSITION( 00075:00078) INTEGER
, "KS833080"
POSITION( 00079:00080) CHAR(00002)
, "KS833090"
POSITION( 00081:00090) DATE EXTERNAL
, "KS833100"
POSITION( 00091:00100) DATE EXTERNAL
, "KS833110"
POSITION( 00101:00110) DATE EXTERNAL
, "KS833120"
POSITION( 00111:00120) DATE EXTERNAL
, "KS833130"
POSITION( 00121:00146) TIMESTAMP EXTERNAL
, "KS833140"
POSITION( 00147:00156) CHAR(00010)
, "KS833150"
POSITION( 00157:00182) TIMESTAMP EXTERNAL
, "KS833160"
POSITION( 00183:00322) CHAR(00140)
)
TEMPLATE TSREC4 DSN('A540769.TMPUL.A835A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC4
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS835C4
( "KS835010"
POSITION( 00003:00022) CHAR(00020)
, "KS835020"
POSITION( 00023:00042) CHAR(00020)
, "KS835030"
POSITION( 00043:00062) CHAR(00020)
, "KS835040"
POSITION( 00063:00066) INTEGER
, "KS835050"
POSITION( 00067:00086) CHAR(00020)
, "KS835060"
POSITION( 00087:00090) CHAR(00004)
, "KS835070"
POSITION( 00091:00110) CHAR(00020)
, "KS835080"
POSITION( 00111:00130) CHAR(00020)
, "KS835090"
POSITION( 00131:00270) CHAR(00140)
, "KS835100"
POSITION( 00271:00272) CHAR(00002)
, "KS835110"
POSITION( 00273:00282) DATE EXTERNAL
, "KS835120"
POSITION( 00283:00292) DATE EXTERNAL
, "KS835130"
POSITION( 00293:00302) DATE EXTERNAL
, "KS835140"
POSITION( 00303:00312) DATE EXTERNAL
, "KS835150"
POSITION( 00313:00338) TIMESTAMP EXTERNAL
, "KS835160"
POSITION( 00339:00348) CHAR(00010)
, "KS835170"
POSITION( 00349:00374) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC5 DSN('A540769.TMPUL.A836A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC5
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS836C4
( "KS836010"
POSITION( 00003:00022) CHAR(00020)
, "KS836020"
POSITION( 00023:00026) CHAR(00004)
, "KS836030"
POSITION( 00027:00046) CHAR(00020)
, "KS836040"
POSITION( 00047:00066) CHAR(00020)
, "KS836050"
POSITION( 00067:00070) INTEGER
, "KS836060"
POSITION( 00071:00078) DECIMAL
, "KS836070"
POSITION( 00079:00082) INTEGER
, "KS836080"
POSITION( 00083:00083) CHAR(00001)
, "KS836090"
POSITION( 00084:00085) CHAR(00002)
, "KS836100"
POSITION( 00086:00095) DATE EXTERNAL
, "KS836110"
POSITION( 00096:00105) DATE EXTERNAL
, "KS836120"
POSITION( 00106:00115) DATE EXTERNAL
, "KS836130"
POSITION( 00116:00125) DATE EXTERNAL
, "KS836140"
POSITION( 00126:00151) TIMESTAMP EXTERNAL
, "KS836150"
POSITION( 00152:00161) CHAR(00010)
, "KS836160"
POSITION( 00162:00187) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC6 DSN('A540769.TMPUL.A837A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC6
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS837C4
( "KS837010"
POSITION( 00003:00022) CHAR(00020)
, "KS837020"
POSITION( 00023:00026) CHAR(00004)
, "KS837030"
POSITION( 00027:00030) CHAR(00004)
, "KS837040"
POSITION( 00031:00035) CHAR(00005)
, "KS837050"
POSITION( 00036:00037) CHAR(00002)
, "KS837060"
POSITION( 00038:00047) DATE EXTERNAL
, "KS837070"
POSITION( 00048:00057) DATE EXTERNAL
, "KS837080"
POSITION( 00058:00067) DATE EXTERNAL
, "KS837090"
POSITION( 00068:00077) DATE EXTERNAL
, "KS837100"
POSITION( 00078:00103) TIMESTAMP EXTERNAL
, "KS837110"
POSITION( 00104:00113) CHAR(00010)
, "KS837120"
POSITION( 00114:00139) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC7 DSN('A540769.TMPUL.A838A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC7
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS838C4
( "KS838010"
POSITION( 00003:00022) CHAR(00020)
, "KS838020"
POSITION( 00023:00042) CHAR(00020)
, "KS838030"
POSITION( 00043:00062) CHAR(00020)
, "KS838040"
POSITION( 00063:00066) INTEGER
, "KS838050"
POSITION( 00067:00086) CHAR(00020)
, "KS838060"
POSITION( 00087:00090) CHAR(00004)
, "KS838070"
POSITION( 00091:00094) INTEGER
, "KS838080"
POSITION( 00095:00104) CHAR(00010)
, "KS838090"
POSITION( 00105:00130) TIMESTAMP EXTERNAL
, "KS838100"
POSITION( 00131:00132) CHAR(00002)
, "KS838150"
POSITION( 00133:00158) TIMESTAMP EXTERNAL
, "KS838160"
POSITION( 00159:00168) CHAR(00010)
, "KS838170"
POSITION( 00169:00194) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC8 DSN('A540769.TMPUL.A839A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC8
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS839C4
( "KS839010"
POSITION( 00003:00022) CHAR(00020)
, "KS839020"
POSITION( 00023:00026) INTEGER
, "KS839030"
POSITION( 00027:00046) CHAR(00020)
, "KS839040"
POSITION( 00047:00066) CHAR(00020)
, "KS839050"
POSITION( 00067:00070) INTEGER
, "KS839060"
POSITION( 00071:00090) CHAR(00020)
, "KS839070"
POSITION( 00091:00116) TIMESTAMP EXTERNAL
, "KS839080"
POSITION( 00117:00126) CHAR(00010)
, "KS839090"
POSITION( 00127:00152) TIMESTAMP EXTERNAL
, "KS839100"
POSITION( 00153:00160) CHAR(00008)
, "KS839110"
POSITION( 00161:00414) CHAR(00254)
)
TEMPLATE TSREC9 DSN('A540769.TMPUL.A840A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC9
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS840C4
( "KS840001"
POSITION( 00003:00022) CHAR(00020)
, "KS840002"
POSITION( 00023:00042) CHAR(00020)
, "KS840003"
POSITION( 00043:00046) INTEGER
, "KS840004"
POSITION( 00047:00050) INTEGER
, "KS840005"
POSITION( 00051:00070) CHAR(00020)
, "KS840006"
POSITION( 00071:00090) CHAR(00020)
, "KS840007"
POSITION( 00091:00110) CHAR(00020)
, "KS840008"
POSITION( 00111:00114) CHAR(00004)
, "KS840009"
POSITION( 00115:00124) DATE EXTERNAL
, "KS840010"
POSITION( 00125:00134) DATE EXTERNAL
, "KS840011"
POSITION( 00135:00144) CHAR(00010)
, "KS840012"
POSITION( 00145:00284) CHAR(00140)
, "KS840013"
POSITION( 00285:00310) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC10 DSN('A540769.TMPUL.A841A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC10
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS841C4
( "KS841001"
POSITION( 00003:00028) TIMESTAMP EXTERNAL
, "KS841002"
POSITION( 00029:00048) CHAR(00020)
, "KS841003"
POSITION( 00049:00052) INTEGER
, "KS841004"
POSITION( 00053:00056) INTEGER
, "KS841005"
POSITION( 00057:00060) CHAR(00004)
, "KS841006"
POSITION( 00061:00070) CHAR(00010)
, "KS841009"
POSITION( 00071:00078) CHAR(00008)
, "KS841010"
POSITION( 00079:00086) CHAR(00008)
, "KS841007"
POSITION( 00087:00094) CHAR(00008)
, "KS841008"
POSITION( 00095:03996) VARCHAR
)
TEMPLATE TSREC11 DSN('A540769.TMPUL.A843A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC11
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS843C4
( "KS843010"
POSITION( 00003:00022) CHAR(00020)
, "KS843020"
POSITION( 00023:00026) CHAR(00004)
, "KS843030"
POSITION( 00027:00029) CHAR(00003)
, "KS843040"
POSITION( 00030:00049) CHAR(00020)
, "KS843050"
POSITION( 00050:00052) DECIMAL
, "KS843060"
POSITION( 00053:00132) CHAR(00080)
, "KS843070"
POSITION( 00133:00162) CHAR(00030)
, "KS843080"
POSITION( 00163:00188) TIMESTAMP EXTERNAL
, "KS843090"
POSITION( 00189:00198) CHAR(00010)
, "KS843100"
POSITION( 00199:00224) TIMESTAMP EXTERNAL
, "KS843110"
POSITION( 00225:00228) CHAR(00004)
, "KS843120"
POSITION( 00229:00232) INTEGER
, "KS843130"
POSITION( 00233:00236) INTEGER
)
TEMPLATE TSREC12 DSN('A540769.TMPUL.A845A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC12
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS845C4
( "KS845001"
POSITION( 00003:00009) CHAR(00007)
, "KS845002"
POSITION( 00010:00029) CHAR(00020)
, "KS845003"
POSITION( 00030:00049) CHAR(00020)
, "KS845004"
POSITION( 00050:00069) CHAR(00020)
, "KS845005"
POSITION( 00070:00079) DATE EXTERNAL
, "KS845006"
POSITION( 00080:00089) DATE EXTERNAL
, "KS845007"
POSITION( 00090:00115) TIMESTAMP EXTERNAL
, "KS845008"
POSITION( 00116:00125) CHAR(00010)
, "KS845009"
POSITION( 00126:00151) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC13 DSN('A540769.TMPUL.A846A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC13
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS846C4
( "KS846001"
POSITION( 00003:00006) INTEGER
, "KS846002"
POSITION( 00007:00026) CHAR(00020)
, "KS846003"
POSITION( 00027:00028) CHAR(00002)
, "KS846004"
POSITION( 00029:00054) TIMESTAMP EXTERNAL
, "KS846005"
POSITION( 00055:00064) CHAR(00010)
, "KS846006"
POSITION( 00065:00074) CHAR(00010)
, "KS846007"
POSITION( 00075:00084) DATE EXTERNAL
, "KS846008"
POSITION( 00085:00130) CHAR(00046)
, "KS846009"
POSITION( 00131:00134) INTEGER
, "KS846010"
POSITION( 00135:00160) TIMESTAMP EXTERNAL
, "KS846011"
POSITION( 00161:00170) CHAR(00010)
, "KS846012"
POSITION( 00171:00196) TIMESTAMP EXTERNAL
, "KS846013"
POSITION( 00197:00204) CHAR(00008)
, "KS846014"
POSITION( 00205:04104) VARCHAR
)
TEMPLATE TSREC14 DSN('A540769.TMPUL.A847A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC14
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS847C4
( "KS847001"
POSITION( 00003:00005) CHAR(00003)
, "KS847002"
POSITION( 00006:00009) CHAR(00004)
, "KS847003"
POSITION( 00010:00013) INTEGER
, "KS847004"
POSITION( 00014:00017) CHAR(00004)
, "KS847005"
POSITION( 00018:00027) DATE EXTERNAL
, "KS847006"
POSITION( 00028:00037) DATE EXTERNAL
, "KS847007"
POSITION( 00038:00063) TIMESTAMP EXTERNAL
, "KS847008"
POSITION( 00064:00073) CHAR(00010)
, "KS847009"
POSITION( 00074:00099) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC15 DSN('A540769.TMPUL.A848A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC15
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS848C4
( "KS848001"
POSITION( 00003:00005) CHAR(00003)
, "KS848002"
POSITION( 00006:00009) CHAR(00004)
, "KS848003"
POSITION( 00010:00013) INTEGER
, "KS848004"
POSITION( 00014:00023) DATE EXTERNAL
, "KS848005"
POSITION( 00024:00033) DATE EXTERNAL
, "KS848006"
POSITION( 00034:00043) CHAR(00010)
, "KS848007"
POSITION( 00044:00069) TIMESTAMP EXTERNAL
, "KS848008"
POSITION( 00070:00070) CHAR(00001)
, "KS848009"
POSITION( 00071:00074) INTEGER
)
TEMPLATE TSREC16 DSN('A540769.TMPUL.A849A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC16
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS849C4
( "KS849001"
POSITION( 00003:00022) CHAR(00020)
, "KS849002"
POSITION( 00023:00026) INTEGER
, "KS849003"
POSITION( 00027:00036) DATE EXTERNAL
, "KS849004"
POSITION( 00037:00046) DATE EXTERNAL
, "KS849005"
POSITION( 00047:00056) CHAR(00010)
, "KS849006"
POSITION( 00057:00082) TIMESTAMP EXTERNAL
, "KS849007"
POSITION( 00083:00086) INTEGER
)
TEMPLATE TSREC17 DSN('A540769.TMPUL.A850A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC17
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS850C4
( "KS850001"
POSITION( 00003:00012) CHAR(00010)
, "KS850002"
POSITION( 00013:00032) CHAR(00020)
, "KS850003"
POSITION( 00033:00052) CHAR(00020)
, "KS850004"
POSITION( 00053:00056) INTEGER
, "KS850005"
POSITION( 00057:00076) CHAR(00020)
, "KS850006"
POSITION( 00077:00078) CHAR(00002)
, "KS850007"
POSITION( 00079:00104) TIMESTAMP EXTERNAL
, "KS850008"
POSITION( 00105:00114) CHAR(00010)
, "KS850009"
POSITION( 00115:00140) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC18 DSN('A540769.TMPUL.A851A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC18
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS851C4
( "KS851001"
POSITION( 00003:00012) CHAR(00010)
, "KS851002"
POSITION( 00013:00032) CHAR(00020)
, "KS851003"
POSITION( 00033:00052) CHAR(00020)
, "KS851004"
POSITION( 00053:00056) INTEGER
, "KS851005"
POSITION( 00057:00076) CHAR(00020)
, "KS851006"
POSITION( 00077:00096) CHAR(00020)
, "KS851007"
POSITION( 00097:00106) DATE EXTERNAL
, "KS851008"
POSITION( 00107:00116) DATE EXTERNAL
, "KS851009"
POSITION( 00117:00142) TIMESTAMP EXTERNAL
, "KS851010"
POSITION( 00143:00152) CHAR(00010)
, "KS851011"
POSITION( 00153:00178) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC19 DSN('A540769.TMPUL.A852A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC19
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS852C4
( "KS852001"
POSITION( 00003:00028) TIMESTAMP EXTERNAL
, "KS852002"
POSITION( 00029:00038) CHAR(00010)
, "KS852003"
POSITION( 00039:00048) CHAR(00010)
, "KS852004"
POSITION( 00049:00056) CHAR(00008)
, "KS852005"
POSITION( 00057:00064) CHAR(00008)
, "KS852006"
POSITION( 00065:00164) CHAR(00100)
)
TEMPLATE TSREC20 DSN('A540769.TMPUL.A853A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC20
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS853C4
( "KS853001"
POSITION( 00003:00012) CHAR(00010)
, "KS853002"
POSITION( 00013:00016) INTEGER
, "KS853003"
POSITION( 00017:00036) CHAR(00020)
, "KS853004"
POSITION( 00037:00062) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC21 DSN('A540769.TMPUL.A854A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC21
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS854C4
( "KS854001"
POSITION( 00003:00034) CHAR(00032)
, "KS854002"
POSITION( 00035:00038) CHAR(00004)
, "KS854003"
POSITION( 00039:00048) DATE EXTERNAL
, "KS854004"
POSITION( 00049:00058) DATE EXTERNAL
, "KS854005"
POSITION( 00059:00084) TIMESTAMP EXTERNAL
, "KS854006"
POSITION( 00085:00094) CHAR(00010)
, "KS854007"
POSITION( 00095:00120) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC22 DSN('A540769.TMPUL.A855A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC22
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS855C4
( "KS855001"
POSITION( 00003:00007) CHAR(00005)
, "KS855002"
POSITION( 00008:00027) CHAR(00020)
, "KS855003"
POSITION( 00028:00037) DATE EXTERNAL
, "KS855004"
POSITION( 00038:00047) DATE EXTERNAL
, "KS855005"
POSITION( 00048:00073) TIMESTAMP EXTERNAL
, "KS855006"
POSITION( 00074:00083) CHAR(00010)
, "KS855007"
POSITION( 00084:00109) TIMESTAMP EXTERNAL
, "KS855008"
POSITION( 00110:00249) CHAR(00140)
)
TEMPLATE TSREC23 DSN('A540769.TMPUL.A856A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC23
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS856C4
( "KS856001"
POSITION( 00003:00005) CHAR(00003)
, "KS856002"
POSITION( 00006:00009) CHAR(00004)
, "KS856003"
POSITION( 00010:00013) INTEGER
, "KS856004"
POSITION( 00014:00017) CHAR(00004)
, "KS856005"
POSITION( 00018:00021) CHAR(00004)
, "KS856006"
POSITION( 00022:00026) CHAR(00005)
, "KS856007"
POSITION( 00027:00036) DATE EXTERNAL
, "KS856008"
POSITION( 00037:00046) DATE EXTERNAL
, "KS856009"
POSITION( 00047:00072) TIMESTAMP EXTERNAL
, "KS856010"
POSITION( 00073:00082) CHAR(00010)
, "KS856011"
POSITION( 00083:00108) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC24 DSN('A540769.TMPUL.A857A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC24
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS857C4
( "KS857001"
POSITION( 00003:00009) CHAR(00007)
, "KS857002"
POSITION( 00010:00010) CHAR(00001)
, "KS857003"
POSITION( 00011:00020) CHAR(00010)
, "KS857004"
POSITION( 00021:00046) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC25 DSN('A540769.TMPUL.A858A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC25
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS858C4
( "KS858001"
POSITION( 00003:00022) CHAR(00020)
, "KS858002"
POSITION( 00023:00026) INTEGER
, "KS858003"
POSITION( 00027:00046) CHAR(00020)
, "KS858004"
POSITION( 00047:00066) CHAR(00020)
, "KS858005"
POSITION( 00067:00068) CHAR(00002)
, "KS858006"
POSITION( 00069:00094) TIMESTAMP EXTERNAL
, "KS858007"
POSITION( 00095:00098) INTEGER
, "KS858008"
POSITION( 00099:00238) CHAR(00140)
, "KS858009"
POSITION( 00239:00248) DATE EXTERNAL
, "KS858010"
POSITION( 00249:00258) DATE EXTERNAL
, "KS858011"
POSITION( 00259:00268) DATE EXTERNAL
, "KS858012"
POSITION( 00269:00278) DATE EXTERNAL
, "KS858013"
POSITION( 00279:00304) TIMESTAMP EXTERNAL
, "KS858014"
POSITION( 00305:00314) CHAR(00010)
, "KS858015"
POSITION( 00315:00340) TIMESTAMP EXTERNAL
, "KS858016"
POSITION( 00341:00366) TIMESTAMP EXTERNAL
, "KS858020"
POSITION( 00367:00376) DATE EXTERNAL
, "KS858021"
POSITION( 00377:00380) INTEGER
, "KS858017"
POSITION( 00381:00388) CHAR(00008)
, "KS858018"
POSITION( 00389:00516) CHAR(00128)
, "KS858019"
POSITION( 00517:00532) CHAR(00016)
, "KS858025"
POSITION( 00533:00558) TIMESTAMP EXTERNAL
, "KS858026"
POSITION( 00559:00568) CHAR(00010)
, "KS858027"
POSITION( 00569:00572) INTEGER
, "KS858022"
POSITION( 00573:00580) CHAR(00008)
, "KS858023"
POSITION( 00581:00708) CHAR(00128)
, "KS858024"
POSITION( 00709:00724) CHAR(00016)
, "KS858028"
POSITION( 00725:00728) INTEGER
, "KS858029"
POSITION( 00729:00729) CHAR(00001)
, "KS858030"
POSITION( 00730:00755) TIMESTAMP EXTERNAL
, "KS858031"
POSITION( 00756:00765) CHAR(00010)
, "KS858032"
POSITION( 00766:00767) CHAR(00002)
, "KS858033"
POSITION( 00768:00768) CHAR(00001)
, "KS858034"
POSITION( 00769:00794) TIMESTAMP EXTERNAL
, "KS858035"
POSITION( 00795:00804) CHAR(00010)
, "KS858036"
POSITION( 00805:00806) CHAR(00002)
, "KS858037"
POSITION( 00807:00807) CHAR(00001)
, "KS858038"
POSITION( 00808:00813) CHAR(00006)
, "KS858039"
POSITION( 00814:00814) CHAR(00001)
, "KS858040"
POSITION( 00815:00822) CHAR(00008)
, "KS858041"
POSITION( 00823:00826) INTEGER
, "KS858042"
POSITION( 00827:00827) CHAR(00001)
)
TEMPLATE TSREC26 DSN('A540769.TMPUL.A859A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC26
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS859C4
( "KS859001"
POSITION( 00003:00022) CHAR(00020)
, "KS859002"
POSITION( 00023:00026) INTEGER
, "KS859003"
POSITION( 00027:00052) TIMESTAMP EXTERNAL
, "KS859004"
POSITION( 00053:00056) INTEGER
, "KS859005"
POSITION( 00057:00082) TIMESTAMP EXTERNAL
, "KS859006"
POSITION( 00083:00086) INTEGER
, "KS859007"
POSITION( 00087:00096) DATE EXTERNAL
, "KS859008"
POSITION( 00097:00106) DATE EXTERNAL
, "KS859009"
POSITION( 00107:00116) DATE EXTERNAL
, "KS859010"
POSITION( 00117:00126) DATE EXTERNAL
, "KS859011"
POSITION( 00127:00152) TIMESTAMP EXTERNAL
, "KS859012"
POSITION( 00153:00162) CHAR(00010)
, "KS859013"
POSITION( 00163:00188) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC28 DSN('A540769.TMPUL.A861A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC28
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS861C4
( "KS861001"
POSITION( 00003:00022) CHAR(00020)
, "KS861002"
POSITION( 00023:00048) TIMESTAMP EXTERNAL
, "KS861003"
POSITION( 00049:00052) INTEGER
, "KS861004"
POSITION( 00053:00056) INTEGER
, "KS861005"
POSITION( 00057:00057) CHAR(00001)
)
TEMPLATE TSREC29 DSN('A540769.TMPUL.A862A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC29
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS862C4
( "KS862001"
POSITION( 00003:00012) CHAR(00010)
, "KS862002"
POSITION( 00013:00016) INTEGER
, "KS862003"
POSITION( 00017:00036) CHAR(00020)
, "KS862004"
POSITION( 00037:00062) TIMESTAMP EXTERNAL
, "KS862005"
POSITION( 00063:00072) CHAR(00010)
, "KS862006"
POSITION( 00073:00098) TIMESTAMP EXTERNAL
)
TEMPLATE TSREC30 DSN('A540769.TMPUL.A863A.D2010014.UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
INDDN TSREC30
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1T.TELKS863C4
( "KS863001"
POSITION( 00003:00006) INTEGER
, "KS863002"
POSITION( 00007:00010) INTEGER
, "KS863003"
POSITION( 00011:00020) CHAR(00010)
, "KS863004"
POSITION( 00021:00021) CHAR(00001)
, "KS863005"
POSITION( 00022:00041) CHAR(00020)
, "KS863006"
POSITION( 00043:00072) CHAR(00030)
NULLIF(00042)=X'FF'
, "KS863007"
POSITION( 00073:00102) CHAR(00030)
, "KS863008"
POSITION( 00103:00132) CHAR(00030)
, "KS863009"
POSITION( 00133:00142) DATE EXTERNAL
, "KS863010"
POSITION( 00143:00152) DATE EXTERNAL
, "KS863011"
POSITION( 00153:00178) TIMESTAMP EXTERNAL
, "KS863012"
POSITION( 00179:00188) CHAR(00010)
, "KS863013"
POSITION( 00189:00214) TIMESTAMP EXTERNAL
)
$#out 20100114 16:41:30
$#out 20100114 16:44:25
$#out 20100114 16:43:05
}¢--- A540769.WK.REXX(ELCOMATB) cre=2010-01-11 mod=2010-01-11-13.50.34 A540769 ---
TS KS09A1A.A831A tb OA1A.TKS831A1
TS KS09A1A.A832A tb OA1A.TKS832A1
TS KS09A1A.A833A tb OA1A.TKS833A1
TS KS09A1A.A835A tb OA1A.TKS835A1
TS KS09A1A.A836A tb OA1A.TKS836A1
TS KS09A1A.A837A tb OA1A.TKS837A1
TS KS09A1A.A838A tb OA1A.TKS838A1
TS KS09A1A.A839A tb OA1A.TKS839A1
TS KS09A1A.A840A tb OA1A.TKS840A1
TS KS09A1A.A841A tb OA1A.TKS841A1
TS KS09A1A.A843A tb OA1A.TKS843A1
TS KS09A1A.A845A tb OA1A.TKS845A1
TS KS09A1A.A846A tb OA1A.TKS846A1
TS KS09A1A.A847A tb OA1A.TKS847A1
TS KS09A1A.A848A tb OA1A.TKS848A1
TS KS09A1A.A849A tb OA1A.TKS849A1
TS KS09A1A.A850A tb OA1A.TKS850A1
TS KS09A1A.A851A tb OA1A.TKS851A1
TS KS09A1A.A852A tb OA1A.TKS852A1
TS KS09A1A.A853A tb OA1A.TKS853A1
TS KS09A1A.A854A tb OA1A.TKS854A1
TS KS09A1A.A855A tb OA1A.TKS855A1
TS KS09A1A.A856A tb OA1A.TKS856A1
TS KS09A1A.A857A tb OA1A.TKS857A1
TS KS09A1A.A858A tb OA1A.TKS858A1
TS KS09A1A.A859A tb OA1A.TKS859A1
TS KS09A1A.A860A tb OA1A.TKS860A1
TS KS09A1A.A861A tb OA1A.TKS861A1
TS KS09A1A.A862A tb OA1A.TKS862A1
TS KS09A1A.A863A tb OA1A.TKS863A1
}¢--- A540769.WK.REXX(ELCOMAUN) cre=2010-01-11 mod=2010-01-11-14.30.50 A540769 ---
$<~WK.REXX(ELCOMATB) $>.jclSub()
$@¢
$=c=0
$@for li $@¢
parse upper value $li with c1 oTs c2 otb .
if c1 <> 'TS' | c2 <> 'TB' | otb = '' | ots = '' then
call err 'bad line' $li
nTs = oTs'C4'
nTb = left(oTb, 6)'EL'substr(oTb, 7, length(oTb)-8)'C4'
$=c=-$c+1
say $c 'old' ots ' in' oTb
say $c 'new' nts 'in' nTb
$=jc=-'//*'
$=oTs=-oTs
$=oTb=-oTb
if $c = 1 then $@=¢
//A540769U JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
${jc}MAIN CLASS=LOG
$jc
$jc **************************************************
$jc UNLOAD COPY
$jc **************************************************
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBAF,'A540769.UNLOAC'),
// REGION=0M
$jc DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
TEMPLATE TSREC DSN('A540769.TMPUL.&SN..D&DATE..UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
TEMPLATE TSPUN DSN('A540769.TMPUL.&SN..D&DATE..UNLPUN')
DATACLAS (NULL12) MGMTCLAS(COM#E005)
SPACE (10,250) CYL
$!
$@=¢
UNLOAD DATA FROM TABLE $oTb
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
$!
$!
$!
$#out 20100111 14:30:47
$#out 20100111 14:30:09
$#out 20100111 14:28:50
//A540769U JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//*MAIN CLASS=LOG
//*
//* **************************************************
//* UNLOAD COPY
//* **************************************************
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBAF,'A540769U.UNLOA'),
// REGION=0M
//* DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
TEMPLATE TSREC DSN('A540769.TMPUL.&SN..D&DATE..UNLOAD')
DATACLAS (NULL30) MGMTCLAS(COM#E005)
SPACE (1000,1250) CYL
TEMPLATE TSPUN DSN('A540769.TMPUL.&SN..D&DATE..UNLPUN')
DATACLAS (NULL12) MGMTCLAS(COM#E005)
SPACE (10,250) CYL
UNLOAD DATA FROM TABLE KS09A1A.A831A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A832A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A833A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A835A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A836A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A837A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A838A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A839A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A840A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A841A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A843A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A845A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A846A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A847A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A848A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A849A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A850A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A851A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A852A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A853A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A854A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A855A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A856A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A857A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A858A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A859A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A860A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A861A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A862A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
UNLOAD DATA FROM TABLE KS09A1A.A863A
PUNCHDDN TSPUN UNLDDN TSREC
SHRLEVEL CHANGE ISOLATION UR
$#out
}¢--- A540769.WK.REXX(EMAC) cre=2009-08-12 mod=2009-08-12-17.42.05 A540769 -----
/* rexx ****************************************************************
wsh
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
parse upper arg arg
if arg = 'E' then do
abc = 'parmVar abc . end sdf'
call adrIsp 'edit dataset(wk.rexx(ddd)) macro(emac)' ,
'parm(abc)', '*'
say 'edit rc='rc
exit
end
call errReset 'h'
if \ (adrEdit('macro (mArgs) ', '*') == 0) then
say 'macro rc' rc
else do
say macro '('mArgs')'
if wordPos('END', translate(mArgs)) > 0 then do
call adrEdit 'end', '*'
say 'macro eMac isrEdit end rc='rc
end
end
exit
if mArgs \== '' then
return 0 mArgs
parse arg fun rest
os = errOS()
if 0 then do /* for special tests */
.output$mc$lineOut('hello walti')
x = .output
say .output$mc$class()
say x$mc$class()
x = file('&out')
call jWrite x, 'hallo walti'
call jClose x
exit
end
if 0 then do
call tstSort
call envIni
call tstFile
call tstTotal
exit
end
if 0 then do
do 2
call tstAll
end
exit
end
if 0 then do
call compIni
call tstScanWin
exit
call envIni
call tstFile
call tstFileList
call tstTotal
exit
call tstAll
call envIni
call tstTotal
exit
end
call compIni
/* if os == 'TSO' then
call oSqlIni
*/ if fun = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done fun rest
if done then
return
end
fun = translate(fun)
if fun = '' then
fun = 'S'
if fun = 'S' | fun = 'D' then /* batch interface */
if os == 'TSO' then
exit wshBatchTSO(fun)
else if os == 'LINUX' then
exit wshBatch(fun, '<-%' file('&in'), '>-%' file('&out'))
else
call err 'implemnt wshBatch' os
if wordPos(fun, 'R E S D') > 0 then /* interpreter */
exit wshInter('-'fun rest)
if wordPos(fun, '-R -E -S -D') > 0 then
exit wshInter(fun rest)
if \ abbrev(fun, 'T') then
call err 'bad fun' fun 'in arg' arg
if fun <> 'T' then do /* list of tests */
c = call fun rest
end
else do
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if c = '' then
c = call 'tstAct;'
else if wx > 2 then
c = c 'call tstTotal;'
end
say 'wsh interpreting' c
interpret c
exit 0
/*--- actual test case ----------------------------------------------*/
tstAct: procedure expose m.
call classOut m.class.class, m.class.class
return 0
endProcedure tstAct
/*--- batch: compile shell or data from inp and
run it to output out -----------------------------------*/
wshBatch: procedure expose m.
parse upper arg ty, inp, out
i = cat(inp)
cmp = comp(i)
if pos('D', ty) || pos('d', ty) > 0 then
ty = 'd'
else
ty = 's'
r = compile(cmp, ty)
if out \== '' then
call envPush out
call oRun r
if out \== '' then
call envPop
return 0
endProcedure wshBatch
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
do forever
w1 = translate(word(inp, 1))
if abbrev(w1, '-') then do
mode = substr(w1, 2)
inp = subWord(inp, 2)
if mode = '' then
return 0
end
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = 'R' then
interpret inp
else if mode = 'E' then
interpret 'say' inp
else if mode = 'S' | mode = 'D' then do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
else
say 'mode' mode 'not implemented yet'
end
say 'enter' mode 'expression, - for end, -r or -e for Rexx' ,
'-s or -d for WSH'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
i = cat("-WSH")
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '> -out'
else
out = ''
call wshBatch ty, '< -wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if \ (adrEdit('macro (mArgs) NOPROCESS', '*') == 0) then
return 0
if mArgs \== '' then
return 0 mArgs
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
if dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then
return 0
call adrIsp 'control errors return'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
dst = ''
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
if pc = 0 then
call adrEdit "(dst) = lineNum .zDest"
else
dst = rLa
end
else if pc = 12 then do
if adrEdit("find first '$***out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
li = overlay(date(s) time(), li, 20)
call adrEdit "line_before" dst "= (li)"
rFi = 1
rLa = dst-1
end
end
if dst = '' then
msg = 'bitte Bereich mit q oder qq auswaehlen ???' rc ,
'oder $***out Zeile einfuegen'
else if rLa < rFi then
msg = 'firstLine' rFi 'before last' rLa
else
msg = ''
if msg \== '' then do
say msg
return 1
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
i = jOpen(jBuf(), m.j.cWri)
o = jBuf()
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
if pos('D', mArgs) > 0 then
ty = 'd'
else
ty = 's'
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, ty)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call envPush '>%' o
call oRun r
call envPop
lab = wshEditInsLinSt(dst+1, , o'.BUF')
call wshEditLocate dst-7
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
oo = outDest('=')
call outDest 'i', outDest()';'outDest('s', mCut(ggStem, 0))
call errSay 'compErr' ggTxt
call outDest 'i', oo
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin), 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst+1, , so'.BUF')
call outDest 's', mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst+1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, type, st
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call jOut 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call jOut 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call jOut '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call jOut 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*<<tstSort
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSort */
/*<<tstSortAscii
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSortAscii */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*<<tstMatch
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, +
:M.STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call jOut 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call jOut 'sqlVars' sv
call jOut sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call jOut 'sqlVarsNull' sqlVarsNull(stst, A B C)
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call jOut 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call jOut 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
/*<<tstSqlO
### start tst tstSqlO #############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
REQD=Y col=123 case=--- col5=anonym
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE .
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE .
SYSTABLEPART_HI T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE .
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
tstSqlO */
call tst t, "tstSqlO"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call jOut 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call jOut fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call jOut oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
/*<<tstSqlEnv
### start tst tstSqlEnv ###########################################
REQD=Y COL2=123 case=--- COL5=anonym
sql fmtFldRw sl<15
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE .
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE .
SYSTABLEPART_HI T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE .
sql fmtFldSquashRW
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
sqlLn sl=
COL1 T DBNAME COL4 .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_ T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
sqlLn ---
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
tstSqlEnv */
call tst t, "tstSqlEnv"
call sqlConnect 'DBAF'
call envBarBegin
call jOut 'select d.*, 123, current timestamp "jetzt und heute",'
call jOut 'case when 1=0 then 1 else null end caseNull,'
call jOut "'anonym'"
call jOut 'from sysibm.sysdummy1 d'
call envBar
call sql 13
call envBarLast
do while envRead(abc)
call jOut 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call envBarEnd
call jOut 'sql fmtFldRw sl<15'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call envBarEnd
call jOut 'sql fmtFldSquashRW'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldSquashRW
call envBarEnd
call jOut 'sqlLn sl='
call envBarBegin
call jOut 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13, , ,'sl='
call envBarEnd
call jOut 'sqlLn ---'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13
call envBarEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompStmt
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstTotal
return
endProcedure tstComp
tstCompRun: procedure expose m.
parse arg class cnt
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
cmp = comp(jClose(src))
call jOut 'compile' class',' (sx-2) 'lines:' arg(2)
r = compile(cmp, class)
say "compiled: >>>>" r "<<<<" m.r.code
call jOut "run without input"
call mCut 'T.IN', 0
call oRun r
if cnt == 3 then do
call jOut "run with 3 inputs"
call mAdd 'T.IN', "eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
m.t.inIx = 0
call oRun r
end
return
endProcedure tstCompRun
tstCompDataConst: procedure expose m.
/*<<tstCompDataConst
### start tst tstCompDataConst ####################################
compile d, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
tstCompDataConst */
call tst t, 'tstCompDataConst'
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
call tstEnd t
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*<<tstCompDataVars
### start tst tstCompDataVars #####################################
compile d, 4 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1| .
tstCompDataVars */
call tst t, 'tstCompDataVars'
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }| '
call tstEnd t
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*<<tstCompShell
### start tst tstCompShell ########################################
compile s, 9 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX JOUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 END
tstCompShell */
call tst t, 'tstCompShell'
call tstCompRun 's' ,
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call jOut rexx jout l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call jOut l8 one ' ,
, 'call jOut l9 end'
call tstEnd t
return
endProcedure tstCompDataVars
tstCompPrimary: procedure expose m.
/*<<tstCompPrimary
### start tst tstCompPrimary ######################################
compile d, 11 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx 3*5 = 15
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
run with 3 inputs
Strings $"$""$" $'$''$'
rexx 3*5 = 15
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
tstCompPrimary */
call tst t, 'tstCompPrimary'
call envRemove 'v2'
call tstCompRun 'd' 3 ,
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx 3*5 = $( 3 * 5 $)',
, 'data $-¢ line three',
, 'line four $! bis hier',
, 'shell $-{ $$ line five',
, '$$ line six $} bis hier',
, '$= v1 = value Eins $=rr=undefined',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v$( 1 * 1 + 0 $) }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr'
call tstEnd t
return
endProcedure tstCompPrimary
tstCompStmt: procedure expose m.
/*<<tstCompStmt1
### start tst tstCompStmt1 ########################################
compile s, 8 lines: $= v1 = value eins $= v2 % 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ .
vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
tstCompStmt1 */
call tst t, 'tstCompStmt1'
call envPut 'oRun', oRunner('call jOut "oRun ouput" (1*1)')
call envRemove 'v2'
call tstCompRun 's' ,
, '$= v1 = value eins $= v2 % 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@{$$ zwei $$ drei ',
, ' $@{ $} $@{ $@{ $$vier $} $} $} $$fuenf',
, '$$elf $@¢ zwoelf dreiZ ',
, ' $@¢ $! $@¢ $@¢ vierZ $! $! $! $$fuenfZ',
, '$% "lang v1" $v1 "v2" ${v2}*9',
, '$@run $oRun'
call tstEnd t
/*<<tstCompStmt2
### start tst tstCompStmt2 ########################################
compile s, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
tstCompStmt2 */
call tst t, 'tstCompStmt2'
call tstCompRun 's' 3 ,
, '$@for qq $$ loop qq $qq'
call tstEnd t
return
endProcedure tstCompStmt
tstCompDataIO: procedure expose m.
/*<<tstCompDataHereData
### start tst tstCompDataHereData #################################
compile d, 13 lines: herdata $<<stop .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
tstCompDataHereData */
call tst t, 'tstCompDataHereData'
call tstCompRun 'd' ,
, ' herdata $<<stop ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata',
, ' herdata ¢ $<<¢stop ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata ¢',
, ' herdata { $<<{st',
, 'call jOut heredata 1 $x',
, '$$heredata 2 $y',
, 'st $$ nach heredata {'
call tstEnd t
/*<<tstCompDataIO
### start tst tstCompDataIO #######################################
compile d, 5 lines: input 1 $<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
tstCompDataIO */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = dsn tstFB('::F37', 0)
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
call tst t, 'tstCompDataIO'
call tstCompRun 'd' ,
, ' input 1 $<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $<'extFD,
, ' und schluiss.'
call tstEnd t
return
endProcedure tstCompDataIO
tstCompPipe: procedure expose m.
/*<<tstCompPipe1
### start tst tstCompPipe1 ########################################
compile s, 1 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
tstCompPipe1 */
call tst t, 'tstCompPipe1'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"'
call tstEnd t
/*<<tstCompPipe2
### start tst tstCompPipe2 ########################################
compile s, 2 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
tstCompPipe2 */
call tst t, 'tstCompPipe2'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| call envPreSuf "¢2 ", " 2!"'
call tstEnd t
/*<<tstCompPipe3
### start tst tstCompPipe3 ########################################
compile s, 3 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
tstCompPipe3 */
call tst t, 'tstCompPipe3'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| call envPreSuf "¢2 ", " 2!"',
, ' $| call envPreSuf "<3 ", " 3>"'
call tstEnd t
/*<<tstCompPipe4
### start tst tstCompPipe4 ########################################
compile s, 7 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
tstCompPipe4 */
call tst t, 'tstCompPipe4'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| $@{ call envPreSuf "¢20 ", " 20!"',
, ' $| call envPreSuf "¢21 ", " 21!"',
, ' $| $@{ call envPreSuf "¢221 ", " 221!"',
, ' $| call envPreSuf "¢222 ", " 222!"',
, '$} $} ',
, ' $| call envPreSuf "<3 ", " 3>"'
call tstEnd t
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*<<tstCompRedir
### start tst tstCompRedir ########################################
compile s, 6 lines: $>#eins $@for vv $$<$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call tst t, 'tstCompRedir'
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstCompRun 's' 3 ,
, ' $>#eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-{$<#eins$}$; ',
, ' $@for ww $$b${ww}y ',
, ' $> $dsn 'tstFB('::v', 0),
, '$| call envPreSuf "a", "z" $<# eins',
, '$;$$ output piped zwei $-{$<$dsn$} '
call tstEnd t
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*<<tstCompCompShell
### start tst tstCompCompShell ####################################
compile s, 5 lines: $$compiling shell $; $= rrr = $-cmpShell $<<aaa
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
tstCompCompShell */
call tst t, 'tstCompCompShell'
call tstCompRun 's' 3 ,
, "$$compiling shell $; $= rrr = $-cmpShell $<<aaa",
, "call jOut run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
/*<<tstCompCompData
### start tst tstCompCompData #####################################
compile s, 5 lines: $$compiling data $; $= rrr = $-cmpData $<<aaa
run without input
compiling data
running einmal
call jOut run 1*1*1 compiled einmal
running zweimal
call jOut run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call jOut run 1*1*1 compiled einmal
running zweimal
call jOut run 1*1*1 compiled zweimal
tstCompCompData */
call tst t, 'tstCompCompData'
call tstCompRun 's' 3 ,
, "$$compiling data $; $= rrr = $-cmpData $<<aaa",
, "call jOut run 1*1*1 compiled $cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
return
endProcedure tstCompComp
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call envIni
CALL TstEnv
CALL TstEnvCat
call tstEnvBar
call tstEnvVars
call tstTotal
call tstEnvLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*<<tstTstSayEins
### start tst tstTstSayEins #######################################
test eins einzige testZeile
tstTstSayEins */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x
if m.x.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x
if m.x.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x
if m.x.err <> 3 then
call err '+++ tstTstSay errs' m.x.err 'expected' 3
/*<<tstTstSayDrei
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
tstTstSayDrei */
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
tstM */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*<<tstMap
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 nicht gefunden
tstMap */
/*<<tstMapInline1
inline1 eins
inline1 drei
tstMapInline1 */
/*<<tstMapInline2
inline2 eins
tstMapInline2 */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'nicht gefunden')
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*<<tstMapVia
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K*)
mapVia(m, K*) M.A
mapVia(m, K*) valAt m.a
mapVia(m, K*) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K*aB)
mapVia(m, K*aB) M.A.aB
mapVia(m, K*aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K**)
mapVia(m, K**) M.valAt m.a
mapVia(m, K**) valAt m.valAt m.a
mapVia(m, K**F) valAt m.valAt m.a.F
tstMapVia */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
m.a = v
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
call tstOut t, 'mapVia(m, K**F) ' mapVia(m, 'K**F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.4 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.3 :class union
. choice u stem 8
. .1 refTo @CLASS.11 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.1 :class union
. choice v = v
. .2 refTo @CLASS.12 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.7 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.6 :class union
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.13 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.15 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.14 :class union
. choice s .CLASS refTo @CLASS.6 done :class @CLASS.6
. .5 refTo @CLASS.16 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.8 :class union
. choice u stem 2
. .1 refTo @CLASS.5 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.7 done :class @CLASS.7
. .6 refTo @CLASS.17 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.8 done :class @CLASS.8
. .7 refTo @CLASS.18 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.8 done :class @CLASS.8
. .8 refTo @CLASS.19 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.10 :class union
. choice u stem 2
. .1 refTo @CLASS.5 done :class @CLASS.5
. .2 refTo @CLASS.9 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
tstClass2 */
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
/* call out 'nach pop' *** ???wktest */
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
tstClass */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n tstClassTf12 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12, s u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,
,'*** err: basicClass v end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"')
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t 1/0
endProcedure tstClassOut
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 n =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 n =className= TstOElf
C4 n =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
tstO */
call tst t, 'tstO'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWSay.jOpen(<obj s of JRWSay>, open<Arg)
*** err: jWrite(<obj s of JRWSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei jIn 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei jIn 1 vv=readAdrVV Schluss
tstJSay */
call tst t, 'tstJSay'
call jIni
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWSay')
call mAdd t'.TRANS', s '<obj s of JRWSay>'
call jOpen s, 'open<Arg'
call jWrite s, 'write s vor open'
call jOpen s
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call jOut 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call jOut 'out zwei jIn' jIn(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call jOut 'out drei jIn' jIn(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*<<tstJ
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 jIn() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 jIn() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 jIn() tst in line 3 drei .schluss..
#jIn eof 4#
jIn() 3 reads vv VV
*** err: already opened jOpen(<buf b>, <)
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
tstJ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call jOut 'out eins'
do lx=1 by 1 while jIn(var)
call jOut lx 'jIn()' m.var
end
call jOut 'jIn()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call jOut 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*<<tstJ2
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
call tst t, "tstJ2"
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteR b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteR b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b, res)
call jOut 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteR c, res
end
call jOpen jClose(c), '<'
do while jRead(c, ccc)
call jOut 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call jOuR ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*<<tstCat
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
tstCat */
call tst t, "tstCat"
i = cat('%' jBuf('line 1', 'line 2'), '%' jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
/*<<tstEnv
### start tst tstEnv ##############################################
before envPush
after envPop
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
tstEnv */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call jOut 'before envPush'
b = jBuf("b line eins", "b zwei |")
call envPush '<%' b, '>%' c
call jOut 'before writeNow 1 b --> c'
call envwriteNow
call jOut 'nach writeNow 1 b --> c'
call envPop
call jOut 'after envPop'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call envPush '>>%' c
call jOut 'after push c only'
call envwriteNow
call envPop
call envPush '<%' c
call jOut 'before writeNow 2 c --> std'
call envwriteNow
call jOut 'nach writeNow 2 c --> std'
call envPop
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
/*<<tstEnvCat
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
tstEnvCat */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call envPush '<+%' b0, '<+%' b1, '<+%' b2, '<%' c2,'>>%' c1
call jOut 'before writeNow 1 b* --> c*'
call envwriteNow
call jOut 'after writeNow 1 b* --> c*'
call envPop
call jOut 'c1 contents'
call envPush '<%' c1
call envwriteNow
call envPop
call envPush '<%' c2
call jOut 'c2 contents'
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstEnvCat
tstEnvBar: procedure expose m.
/*<<tstEnvBar
### start tst tstEnvBar ###########################################
.+0 vor envBarBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach envBarLast
¢7 +6 nach envBar 7!
¢7 +2 nach envBar 7!
¢7 +4 nach nested envBarLast 7!
¢7 (4 +3 nach nested envBarBegin 4) 7!
¢7 (4 (3 +1 nach envBarBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor envBar 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested envBarLast 4) 7!
¢7 +4 nach preSuf vor nested envBarEnd 7!
¢7 +5 nach nested envBarEnd vor envBar 7!
¢7 +6 nach writeNow vor envBarLast 7!
.+7 nach writeNow vor envBarEnd
.+8 nach envBarEnd
tstEnvBar */
call tst t, 'tstEnvBar'
call jOut '+0 vor envBarBegin'
call envBarBegin
call jOut '+1 nach envBarBegin'
call envwriteNow
call jOut '+1 nach writeNow vor envBar'
call envBar
call jOut '+2 nach envBar'
call envBarBegin
call jOut '+3 nach nested envBarBegin'
call envPreSuf '(3 ', ' 3)'
call jOut '+3 nach preSuf vor nested envBarLast'
call envBarLast
call jOut '+4 nach nested envBarLast'
call envPreSuf '(4 ', ' 4)'
call jOut '+4 nach preSuf vor nested envBarEnd'
call envBarEnd
call jOut '+5 nach nested envBarEnd vor envBar'
call envBar
call jOut '+6 nach envBar'
call envwriteNow
say 'jOut +6 nach writeNow vor envBarLast'
call jOut '+6 nach writeNow vor envBarLast'
call envBarLast
call jOut '+7 nach envBarLast'
call envPreSuf '¢7 ', ' 7!'
call jOut '+7 nach writeNow vor envBarEnd'
call envBarEnd
call jOut '+8 nach envBarEnd'
call tstEnd t
return
endProcedure tstEnvBar
tstEnvVars: procedure expose m.
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
put1 = envPut('v1', 'value eins')
call tstOut t, 'put v1' put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1*FLD')
call envPush '># theBuf'
call jOut 'one to theBur'
call jOut 'two to theBuf'
call envPop
call envPush '<# theBuf'
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstEnvVars
tstEnvLazy: procedure expose m.
/*<<tstEnvLazy
### start tst tstEnvLazy ##########################################
a1 vor envBarBegin loop lazy 0 writeNow *** <class TstEnvLazyBuf>
bufOpen <%
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow jIn inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow jIn inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstEnvLazyRdr>
RdrOpen <%
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor envBarBegin loop lazy 1 writeAll *** <class TstEnvLazyBuf>
a5 vor 2 writeAll jIn inIx 0
a2 vor writeAll jBuf
bufOpen <%
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll jIn inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstEnvLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <%
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
tstEnvLazy */
call tst t, "tstEnvLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstEnvLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstEnvLazyBuf>'
call jOut 'a1 vor envBarBegin loop lazy' lz w '***' ty
call envBarBegin
call jOut 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstEnvLazyBuf')
interpret 'call env'w '"<%" b'
call jOut 'a3 vor' w 'jIn inIx' m.t.inIx
interpret 'call env'w
call jOut 'a4 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'a5 vor 2' w 'jIn inIx' m.t.inIx
interpret 'call env'w
call jOut 'a6 vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstEnvLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call jOut "jRead lazyRdr"; return jIn(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstEnvLazyRdr>'
r = oNew('TstEnvLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call jOut 'b1 vor barBegin lazy' lz w '***' ty
call envBarBegin
if lz then
call mAdd t'.TRANS', m.j.jOut '<barBegin out>'
call jOut 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call env'w 'm.j.cRead || m.j.cObj r'
call jOut 'b3 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'b4 vor' w
interpret 'call env'w
call jOut 'b5 vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstEnvLazy
tstEnvClass: procedure expose m.
/*<<tstEnvClass
### start tst tstEnvClass #########################################
a0 vor envBarBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
writeR o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor envBarBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
writeR o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
t10 = classNew('n TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n TstEnvClass20 u v, f f24 v, f F25 v')
call jOut 'a0 vor envBarBegin loop lazy' lz w '***' ty
call envBarBegin
call jOut 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteR b, o1
call jWrite b, 'writeR o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteR b, oc
call jOut 'a2 vor' w 'b'
interpret 'call env'w '"<%"' jClose(b)
call jOut 'a3 vor' w
interpret 'call env'w
call jOut 'a4 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'a5 vor' w
interpret 'call env'w
call jOut 'a6 vor barEnd'
call envBarEnd
call jOut 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstEnvClass
tstFile: procedure expose m.
/*<<tstFile
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
tstFile */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call envPush '>' tstPdsMbr(pd2, 'eins')
call jOut tstFB('out > eins 1') /* simulate fixBlock on linux */
call jOut tstFB('out > eins 2 schluss.')
call envPop
call envPush '>' tstPdsMbr(pd2, 'zwei')
call jOut tstFB('out > zwei mit einer einzigen Zeile')
call envPop
b = jBuf("buf eins", "buf zwei", "buf drei")
call envPush '<' tstPdsMbr(pd2, 'eins'), '<%' b,
,'<%' jBuf(),
,'<' tstPdsMbr(pd2, 'zwei'),
,'<' tstPdsMbr(pds, 'wr0'),
,'<' tstPdsMbr(pds, 'wr1')
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
if num > 100 then
call jReset jClose(io), tstPdsMbr(dsn, 'wr'num)
call jOpen jClose(io), m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead'
if jRead(io, vv) then
call err x'+1 jRead'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
tstFileList */
/*<<tstFileListTSO
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
tstFileListTSO */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins', 'eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei', 'zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei', 'drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
/*<<tstFmt
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
tstFmt */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call envPush m.j.cWri || m.j.cObj b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call envPop
call fmtFWriteAll fmtFreset(abc), m.j.cRead || m.j.cObj b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, m.j.cRead || m.j.cObj b
call tstEnd t
/*<<tstFmtCSV
### start tst tstFmtCSV ###########################################
, a2i, b3b, d4, fl5, ex6
-5+, -5, b, d4-5+d, null2, null2
-4, -4, b3b-4, d4-4+, -11114, -11114e4
-, -3, b3b-, d4-3, -.113, -.113e-3
-2+, -2, b3b, d4-, -.12, -.12e2
-1, -1, b3, d4, -.1, -.1e-1
0, 0, b, d, null1, null1
1+, 1, b3, d4, .1, .1e-1
2++, 2, b3b, d42, .12, .12e2
3, 3, b3b3, d43+, .113, .113e-3
4+, 4, b3b4+, d44+d, 11114, 11114e4
5++, 5, b, d45+d4, null2, null2
6, 6, b3, d46+d4+, .111116, .111116e6
7+, 7, b3b, d47+d4++, .1111117, .7e-7
tstFmtCSV */
call tst t, 'tstFmtCSV'
call envBarBegin
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -5, + 7
call envBarLast
call fmtFCsvAll
call envBarEnd
call tstEnd t
return
endProcedure tstFmt
tstScan: procedure expose m.
/*<<tstScan.1
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
tstScan.1 */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.2
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
tstScan.2 */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.3
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
tstScan.3 */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*<<tstScan.4
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
tstScan.4 */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*<<tstScan.5
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*<<tstScanRead
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
tstScanRead */
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*<<tstScanReadMitSpaceLn
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
tstScanReadMitSpaceLn */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b))
do forever
if scanName(s) then call jOut 'name' m.s.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*<<tstScanJRead
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call jOut x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call jOut 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*<<tstScanWin
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
tstScanWin */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*<<tstScanWinRead
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*<<tstScanSqlId
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
tstScanSqlId */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlDelimited
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
tstScanSqlDelimited */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlQualified
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
tstScanSqlQualified */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNum
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
tstScanSqlNum */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNumUnit
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
tstScanSqlNumUnit */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouptut migrated compares
tstCIO inpunt and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.tst.act = m
m.tst.tests = m.tst.tests+1
m.m.trans.0 = 0
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
if m.tst.ini.j \== 1 then do
call outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.jIn
m.m.oldJOut = m.j.jOut
m.j.jIn = m
m.j.jOut = m
end
else do
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
call envPush '<-%' m, '>-%' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
m.tst.act = ''
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.jIn = m.m.oldJin
m.j.jOut = m.m.oldJOut
end
else do
if m.j.jIn \== m | m.j.jOut \== m then
call tstErr m, m.j.jIn '\==' m '|' m.j.jOut '\==' m
call envPop
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
end
end
if m.m.out.0 \= m.cmp.0 then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
if m.m.err > 0 then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '/*<<'name
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say name '*/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'jOut:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1), subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteR: procedure expose m.
parse arg m, var
if symbol('m.class.o2c.var') \== 'VAR' then
call tstOut t, m.var
else do
oo = outDest('=')
call outDest 'i', 'call tstOut "'m'", msg'
call classOut , var, 'tstR: '
call outDest 'i', oo
end
return
endProcedure tstWriteR
tstRead: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
drop m.class.o2c.arg
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstRead
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
end
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream$mc$new('~/tmp/tst/'suf)$mc$qualify /* full path */
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
if m.tst.act == '' then
call err ggTxt
m.tstErrHandler.0 = 0
oo = outDest('=')
call outDest 's', tstErrHandler
call errSay ggTxt
call outDest 'i', oo
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m.tst.act, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jRead return tstRead(m, var)",
, "jWrite call tstOut m, line",
, "jWriteR call tstWriteR m, var"
end
if m.tst.ini.e \== 1 & m.env.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v,'
end
t = classNew('n tstData* u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call jOuR o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ jIn(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call jout substr(li, 3)
do until \ jIn(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call jout substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, optRdr, wiTi
b = env2buf(optRdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call jOut fmtFTitle(m)
do sx=1 to m.st.0
call jOut fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf 'di' nDi 'ex' eMi'-'eMa
*/ if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo
*/ return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.jIn)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call jOut fmtFldTitle(fo)
do while jIn(ii)
call jOut fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.jIn
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call jOut fmtFldTitle(fo)
do ix = 1 to m.st.0
call jOut fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call envIni
call scanReadIni
cc = classNew('n Compiler u')
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.scan = jOpen(scanRead(src))
return compReset(nn, src)
endProcedure comp
compReset: procedure expose m.
parse arg m, src
call scanReadReset m.m.scan, src, , ,'$*'
m.m.chDol = '$'
m.m.chSpa = ' '
m.m.chNotWord = '${}=%:' || m.m.chSpa
m.m.stack = 0
return m
endProceduere compReset
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp \== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, type
if type == 's' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = compShell(m)
end
else if type == 'd' then do
what = "data";
expec = "sExpression or block";
src = compData(m, 0)
end
else do
call err "bad type" type
end
if \ scanAtEnd(m.m.scan) then
call scanErr m.m.scan, expec "expected: compile" what ,
" stopped before end of input"
call jClose m.m.scan
r = oRunner(src)
return r
endProcedure compile
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
exprs = compPushStem(m)
do forever
aftEol = 0
do forever
text = "";
do forever
if scanVerify(s, m.m.chDol, 'm') then
text = text || m.s.tok
if \ compComment(m) then
leave
end
nd = compExpr(m, 'd')
befEol = scanReadNL(s)
if nd <> '' | (aftEol & befEol) ,
| verify(text, m.m.chSpa) > 0 then do
if text \== '' then
text = quote(text)
if text \== '' & nd \= '' then
text = text '|| '
call mAdd exprs, 'e' compNull2EE(text || nd)
end
if \ befEol then
leave
aftEol = 1
end
one = compStmt(m)
if one == '' then
one = compRedirIO(m, 0)
if one == '' then
leave
call mAdd exprs, 's' one
end
if m.exprs.0 < 1 then do
if makeExpr then
res = '""'
else
res = ';'
end
else do
do x=1 to m.exprs.0 while left(m.exprs.x, 1) = 'e'
end
res = ''
if makeExpr & x > m.exprs.0 then do
res = substr(m.exprs.1, 3)
do x=2 to m.exprs.0
res = res substr(m.exprs.x, 3)
end
end
else do
do x=1 to m.exprs.0
if left(m.exprs.x, 1) = 'e' then
res = res 'call jOut'
res = res substr(m.exprs.x, 3)';'
end
if makeExpr then
res = "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
end
call compPop m, exprs
return res
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res one
if \ scanLit(m.m.scan, '$;') then
return strip(res)
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type
res = ''
if type == 'w' then
charsNot = m.m.chNotWord
else
charsNot = m.m.chDol
s = m.m.scan
if pos(type, 'sw') > 0 then
call compSpComment m
do forever
txt = ''
do forever
if scanVerify(s, charsNot, 'm') then
txt = txt || m.s.tok
if \ compComment(m) then
leave
end
pr = compPrimary(m)
if pr = '' & pos(type, 'sw') > 0 then
txt = strip(txt, 't')
if txt \== '' then
res = res '||' quote(txt)
if pr = '' then do
if pos(type, 'sw') > 0 then
call compSpComment m
if res == '' then
return ''
return substr(res, 5)
end
res = res '||' pr
end
return ''
endProcedure compExpr
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp \== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then
return m.s.tok
if scanLit(s, '(') then do
one = compCheckNN(m, compLang(m, 0), 'rexx expexted after $(')
if \ scanLit(s, '$)') then
call scanErr s, 'closing $) missing after $(...'
return '('one')'
end
if scanLit(s, '-¢') then do
res = compData(m, 1)
if \scanLit(s, '$!') then
call scanErr s, 'closing $! missing after $-¢ data'
return res
end
if scanLit(s, '-{') then do
res = compShell(m)
if \scanLit(s, '$}') then
call scanErr s, 'closing $} missing after $-{ shell'
return "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
if scanLit(s, '-cmpShell', '-cmpData') then do
return 'compile(comp(env2Buf()),' ,
'"'substr('ds', 1+(m.s.tok == '-cmpShell'), 1)'")'
end
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = 'envIsDefined'
else if scanLit(s, '>') then
f = 'envRead'
else
f = 'envGet'
nm = compExpr(m, 'w')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'('nm')'
end
if scanName(s) then
return 'envGet('quote(m.s.tok)')'
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = compStmts(m)
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected afte $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts 'call envBar;' stmtLast
stmtLast = one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('envBar;', stmts)+5) ,
'call envBarLast;' stmtLast 'call envBarEnd;'
if ios \== '' then do
if stmtLast == '' then
stmtLast = 'call envWriteAll;'
stmtLast = 'call envPush 'substr(ios, 3)';' stmtLast ,
'call envPop;'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
if \ scanLit(s, '$&', '$<<', '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
call scanVerify s, '+-%#¢{'
opt = opt || m.s.tok
/* ???? call compSpComment m */
if left(opt, 2) \== '<<' then do
if verify(opt, '¢{', 'm') > 0 ,
| (left(opt, 1) == '&' & pos('%', opt) > 0) then
call scanErr s, 'inconsistent io redirection option' opt
ex = compCheckNN(m, compExpr(m, 's'),
, 'expression expected after $'opt)
end
else do
if verify(opt, '-%#', 'm') > 0 then
call scanErr s, 'inconsistent io redirection option' opt
if \ scanName(s) then
call scanErr s, 'stopper expected in heredata after $'opt
stopper = m.s.tok
call scanVerify s, m.m.chSpa
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after $'opt||stopper
buf = jOpen(jBuf(), m.j.cWri)
do while \ scanLit(s, stopper)
call jWrite buf, m.s.src
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after $'opt||stopper
end
call jClose buf
if verify(opt, '¢{', 'm') > 0 then do
if pos('¢', opt) > 0 then
ex = compile(comp(buf), 'd')
else
ex = compile(comp(buf), 's')
if makeExpr then
return "'<%' envRun("quote(ex)")"
else
return "call oRun" quote(ex)";"
end
opt = '<%'
ex = quote(buf)
end
if makeExpr then
return "'"opt"'" ex
else if left(opt, 1) = '>' then
call scanErr s, 'cannot write ioRedir $'opt
else
return "call envWriteAll '"opt"'" ex
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
res = ''
do forever
one = compStmt(m)
if one == '' then
one = compLang(m, 1)
if one == '' then
return res
res = res strip(one)
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = compCheckNN(m, compExpr(m, 'w'), "variable name")
if scanLit(s, "=") then
vl = compExpr(m, 's')
else if scanLit(s, "%") then
vl = compCheckNN(m, compLang(m, 0),
, 'java expression after $= .. %')
else
call scanErr s, '= or % expected after $= name'
return 'call envPut' nm',' vl';'
end
else if scanLit(s, '$@{') then do
call compSpNlComment m
one = compShell(m)
if \ scanLit(s, "$}") then
call scanErr s, "closing $} missing for $@{ shell"
return "do;" one "end;"
end
else if scanLit(s, '$@¢') then do
call compSpNlComment m
one = compData(m, 0)
if \ scanLit(s, "$!") then
call scanErr s, "closing $! missing for $@! data"
return "do;" one "end;"
end
else if scanLit(s, '$$') then do
return 'call jOut' compExpr(m, 's')';'
end
else if scanLit(s, '$%') then do
return 'call jOut' compCheckNN(m, compLang(m, 0),
, 'language expression after $%')';'
end
else if scanLit(s, '$@for') then do
v = compCheckNN(m, compExpr(m, 'w') ,
, "variable name after $@for")
call compSpNlComment m
return 'do while envRead('v');',
compCheckNN(m, compStmt(m),
, "statement after $@for variable") 'end;'
end
else if scanLit(s, '$@run') then do
return 'call oRun' compCheckNN(m, compExpr(m, 's'),
, 'expression after $@run') ';'
end
return ''
endProcedure compStmt
/*--- compile a language clause
multi=0 a single line for a rexx expression
multi=1 mulitple lines for rexx statements
(with rexx line contiunation) -----------------------*/
compLang: procedure expose m.
parse arg m, multi
s = m.m.scan
res = ''
do forever
if scanVerify(s, m.m.chDol, 'm') then do
res = res || m.s.tok
end
else do
one = compPrimary(m)
if one \== '' then
res = res || one
else if compComment(m) then
res = res || ' '
else if \multi then
return res
else if \ scanReadNl(s) then do
if res == '' then
return res
else
return strip(res)';'
end
else do
res = strip(res)
if right(res, 1) = ',' then
res = strip(left(res, length(res)-1))
else
res = res';'
end
end
end
endProcedure compLang
/*--- convert stmts to an expression yielding the output ------------*/
compStmts2ExprBuf: procedure expose m.
parse arg stmts
rr = oRunner(stmts)
return "envRun('"rr"')"
endProcedure compStmts2ExprBuf
/*--- convert '' to an empty expression ------------------------------*/
compNull2EE: procedure
parse arg e
if e = '' then
return '""'
return e
endProcedure compNull2EE
/*--- if va == '' then issue an error with msg -----------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return 0
return 1
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
found = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
found = 1
else if compComment(m) then
found = 1
else
return found
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy env begin ******************************************************
***********************************************************************/
env: procedure expose m.
m = oBasicNew("Env")
m.m.toClose = ''
m.m.in = ''
m.m.out = ''
m.m.ios.0 = 0
return m
endProcedure env
envClose: procedure expose m.
parse arg m, finishLazy
isLazy = m.m.out == 'ENV.lazyNoOut'
if finishLazy \== '' then do
if \ isLazy & finishLazy == 1 then
call err 'not lazy'
call oMutate m, 'Env'
m.e.out = 'ENV.wasLazy'
end
else if isLazy then
return m
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m
endProcedure envClose
envAddIO: procedure expose m.
parse arg m, opt spec
opt = jOpt(opt)
k = left(opt, 1)
if k == m.j.cApp then
k = m.j.cWri
else if pos(k, m.j.cRead || m.j.cWri) < 1 then
call err 'envAddIO bad opt' opt
do kx=1 to m.m.ios.0 while m.m.ios.kx \== k
end
if kx > m.m.ios.0 then
call mCut mAdd(m'.IOS', k), 0
call mAdd m'.IOS.'kx, opt spec
return m
endProcedure envAddIO
envLazy: procedure expose m.
parse arg e
m.e.jReading = 0
m.e.jWriting = 0
m.e.lazyRdr = jClose(m.e.out)
m.e.out = 'ENV.lazyNoOut'
call oMutate e, 'EnvLazy'
return e
endProcedure envLazy
/*--- return openOption and reader for opt rdr or jIn ---------------*/
envOptRdr: procedure expose m.
parse arg opt rdr
if opt = '' then
return m.j.cRead || m.j.cNoOC || m.j.cObj m.j.jIn
else if rdr = '' then
return m.j.cRead catMake(m.j.cRead opt)
else
return opt catMake(opt rdr)
endProcedure envOptRdr
/*--- write all from rdr (rsp jIn) to jOut, possibly lazy -----------*/
envWriteAll: procedure expose m.
if arg() > 1 then call err '?????????'
parse arg optRdr
call jWriteAll m.j.jOut, envOptRdr(optRdr)
return
endProcedure envWriteAll
/*--- write all from rdr (rsp jIn) to jOut, not lazy ----------------*/
envWriteNow: procedure expose m.
if arg() > 1 then call err '?????????'
parse arg optRdr
call jWriteNow m.j.jOut, envOptRdr(optRdr)
return
endProcedure envWriteNow
envRead2Buf:
call err 'use env2Buf' /*???wkTest***/
/*--- write all from rdr (rsp jIn) to a new jBuf --------------------*/
env2Buf: procedure expose m.
parse arg optRdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, envOptRdr(optRdr)
return jClose(b)
endProcedure env2Buf
envPreSuf: procedure expose m.
parse arg le, ri
do while jIn(v)
call jOut le || m.v || ri
end
return
endProcedure envPreSuf
envCatStr: procedure expose m.
parse arg mi, fo
res = ''
do while jIn(v)
res = res || mi || fmt(m.v)
end
return substr(res, length(mi))
endProcedure envCatStr
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envRead: procedure expose m.
parse arg na
return jIn('ENV.VARS.'na)
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na)
envPut: procedure expose m.
parse arg na, va
return mapPut(env.vars, na, va)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
envIni: procedure expose m.
if m.env.ini == 1 then
return
m.env.ini = 1
call catIni
call classNew "n Env u JRW"
call classNew "n EnvLazy u Cat", "m",
, "jOpen call jOpen m.m.lazyRdr, opt; m.m.jReading = 1",
, "jRead call envPushEnv m;res = jRead(m.m.lazyRdr, var);",
"call envPop; return res",
, "jReset call envClose m, r",
, "jClose call envClose m, 1"
call mapReset env.vars
call jReset oMutate("ENV.lazyNoOut", "JRWErr")
m.env.0 = 0
call envPush /* by default pushes jIn and jOut */
return
endProcedure envIni
envPush: procedure expose m.
e = env()
do ax=1 to arg()
call envAddIo e, arg(ax)
end
do ix=1 to m.e.ios.0
if m.e.ios.ix.0 = 1 then do
rw = catMake(m.e.ios.ix.1)
opt = word(m.e.ios.ix.1, 1)
end
else do
rw = cat()
do fx=1 to m.e.ios.ix.0
call catWriteAll rw, m.e.ios.ix.fx
end
opt = m.e.ios.ix
end
if pos(m.j.cNoOC, opt) < 1 then do
call jOpen rw, opt
m.e.toClose = m.e.toClose rw
end
if m.e.ios.ix = m.j.cRead then
m.e.in = rw
else if m.e.ios.ix = m.j.cWri then
m.e.out = rw
else
call err 'envPush bad io' m.e.ios.ix 'for' m.e.ios.ix.1
end
return envPushEnv(e)
endProcedure envPush
envPushEnv: procedure expose m.
parse arg e
call mAdd env, e
if m.e.in == '' then
m.e.in = m.j.jIn
else
m.j.jIn = m.e.in
if m.e.out == '' then
m.e.out = m.j.jOut
else
m.j.jOut = m.e.out
return e
endProcedure envPushEnv
/*--- activate the last env from stack
and return outputbuffer from current env --------------------*/
envPop: procedure expose m.
ex = m.env.0
if ex <= 1 then
call err 'envPop on empty stack' ex
o = m.env.ex
oo = m.o.out
ex = ex - 1
m.env.0 = ex
e = m.env.ex
m.j.jIn = m.e.in
m.j.jOut = m.e.out
if objClass(oo, '') == class4Name('Cat') & m.oo.RWs.0 > 0 then
return envLazy(o)
call envClose o
return m.o.out
endProcedure envPop
envBarBegin: procedure expose m.
call envPush '>%' Cat()
return
endProcedure envBarBegin
envBar: procedure expose m.
call envPush '<%' envPop(), '>%' Cat()
return
endProcedure envBar
envBarLast: procedure expose m.
call envPush '<%' envPop()
return
endProcedure envBarLast
envBarEnd: procedure expose m.
call envPop
return
endProcedure envBarEnd
/*--- return the output buffer of oRunner m -------------------------*/
envRun: procedure expose m.
parse arg m
call envPush '>%' jBuf()
call oRun m
return envPop()
endProcedure envRun
/* copy env end *******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a reader or writer --------------------------------------*/
catMake: procedure expose m.
parse arg opt spec
if pos(m.j.cObj, opt) > 0 then
return spec
else if pos(m.j.cVar, opt) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, m.j.cObj, m.j.cVar) envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', opt) > 0 then
return file('&'spec)
else
return file(spec)
endProcedure catMake
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', jOpt(m.j.cObj) m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
ix = m.m.catIx
if pos(m.j.cNoOC, word(m.m.RWs.ix, 1)) < 1 then
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if pos(m.j.cRead, oo) > 0 then do
m.m.catIx = 0
m.m.catRd = catNextRdr(m)
m.m.jReading = 1
end
else if abbrev(oo, m.j.cWri) | abbrev(oo, m.j.cApp) then do
if abbrev(oo, m.j.cWri) then
m.m.RWs.0 = 0
m.m.catIx = -7
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 ,
& pos(m.j.cNoOC, word(m.m.RWs.cx, 1)) < 1 then
call jClose m.m.catRd
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
return jOpen(catMake(m.m.RWs.cx),
, m.j.cRead||substr(word(m.m.RWs.cx, 1), 2))
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jRead(m.m.catRd, var) then
return 1
m.m.catRd = catNextRdr(m)
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteR: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteR m.m.catWr, var
return
endProcedure catWriteR
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catIx >= 0 then
call err 'catWriteAll('m',' arg(2)') but opened,',
'catIx='m.m.catIx
if m.m.catWr \== '' then do
call mAdd m'.RWS', jOpt(m.j.cObj) jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
if words(arg(ax)) = 1 then
call mAdd m'.RWS', jOpt() arg(ax)
else
call mAdd m'.RWS', jOpt(word(arg(ax),1)) subword(arg(ax),2)
end
return
endProcedure catWriteAll
/*--- create a reader/writer for an external file --------------------*/
file: procedure expose m.
parse arg sp
return oNew('File', sp)
endProcedure file
fileWriteR: procedure expose m.
parse arg m, var
if symbol('m.class.o2c.var') == 'VAR' then do
ty = m.class.o2c.var
if m.ty \== 'v' then
call err 'fileWriteR with var' var 'class' ty
end
call jWrite m, m.var
return
endProcedure fileWriteR
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/writer for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jRead return catRead(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteR call catWriteR m, var; return",
, "jWriteAll call catWriteAll m, optRdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream$mc$new(nm)
m.m.stream$mc$init(m.m.stream$mc$qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if pos(m.j.cRead, opt) > 0 then do
res = m.m.stream$mc$open(read shareread)
m.m.jReading = 1
end
else do
if pos(opt, m.j.cApp) > 0 then
res = m.m.stream$mc$open(write append)
else if pos(opt, m.j.cWri) > 0 then
res = m.m.stream$mc$open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt m.m.stream$mc$qualify
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream$mc$close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream$mc$qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream$mc$lineIn
if res == '' then
if m.m.stream$mc$state \== 'READY' then
return 0
m.var = res
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream$mc$lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m.m \== value('m.'m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteR call fileWriteR m, var",
, "filePath return m.m.stream~qualify",
, "fileIsFile return sysIsFile(m.m.stream~qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream~qualify)" ,
, "fileChild return file(m.m.stream~qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream~qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset return fileLinuxListReset(m, arg, arg2)",
, "jOpen return fileLinuxListOpen(m, opt)",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if pos(m.j.cRead, opt) > 0 then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
/* ???wkTest fehlermeld funktioniert so nicht, ist sie noetig?
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'") */
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if pos(opt, m.j.cApp) > 0 then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
if pos(opt, m.j.cWri) > 0 then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteR: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteR('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteR
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteR call fileTsoWriteR m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream~qualify",
, "fileIsFile return sysIsFile(m.m.stream~qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream~qualify)" ,
, "fileChild return file(m.m.stream~qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream~qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
call sqlIni
call envIni
call oDecMethods oNewClass("SqlType", "JRW"),
, "jOpen call sqlOpen substr(m, 8); m.m.jReading = 1",
, "jClose call sqlClose substr(m, 8)",
, "jRead return sqlFetch(substr(m, 8), var)"
call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
return
endProcedure sqlOini
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.jOut, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.jOut, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.jOut, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXECall(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse upper arg dd, disp, dsn, rest, nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end *******************************************************/
/* copy sleep begin ***************************************************/
parse arg s
if s = '' then
call sleep 5
else
call sleep s
return
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep end *****************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag ^== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') ^= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi ^== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na ^== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return ' ' alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteR: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteR'
if \ m.m.jWriting then
return err('jWriteR('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteR
jWriteAll: procedure expose m.
parse arg m, optRdr
if words(optRdr) <= 1 then
optRdr = m.j.cRead optRdr
interpret objMet(m, 'jWriteAll')
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, optRdr
if words(optRdr) <= 1 then
optRdr = m.j.cRead optRdr
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
if pos(m.j.cNoOC, opt) < 1 then
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if pos(m.j.cNoOC, opt) < 1 then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, opt rdr
if pos(m.j.cNoOC, opt) < 1 then
call jOpen rdr, jOpt(opt)
do while jRead(rdr, line)
call jWriteR m, line
end
if pos(m.j.cNoOC, opt) < 1 then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
call err 'still open jReset('m',' arg')' / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
if pos(m.j.cNoOC, opt) > 0 then
return m
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- analyze an option in oOpt and oVal -----------------------------*/
jOptWkTest: wkTest ??? deimplemented procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) \== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone \== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jOpt: procedure expose m.
parse arg src .
if abbrev(src, '>>') then
return m.j.cApp || substr(src, 3)
else if pos(left(src, 1), m.j.cRead||m.j.cWri||m.j.cApp) < 1 then
return m.j.cDum || src
else
return src
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '}'
m.j.cObj = '%'
m.j.cVar = '#'
m.j.cDum = '/'
m.j.cNoOC = '-'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' arg')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteR" am "jWriteR('m',' var')'" ,
, "jWriteAll call jWriteNowImpl m, optRdr",
, "jWriteNow call jWriteNowImpl m, optRdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose"
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', optRdr'",
, "jWriteNow" er "jWriteNow 'm', 'optRdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWSay u JRW', 'm',
, "jWrite say line",
, "jWriteR call classOut , var, 'jOuR: '",
, "jOpen if pos('<', opt) > 0 then",
"call err 'can only write JRWSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.jIn = oBasicNew('JRWEof')
m.j.jOut = jOpen(oNew('JRWSay'))
call outDest 'i', 'call jOut msg'
call classNew "n JBuf u JRW, f .BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jWrite a = mAdd(m'.BUF', line); drop m.class.o2c.a",
, "jWriteR call oCopy var, m'.BUF.'mInc(m'.BUF.0')"
return
endProcedure jIni
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg line
call jWrite m.j.jOut, line
return
endProcedure jOut
jOuR: procedure expose m.
parse arg arg
call jWriteR m.j.jOut, arg
return
endProcedure jOut
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
opt = jOpt(opt)
if abbrev(opt, m.j.cRead) then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if abbrev(opt, m.j.cWri) then
m.m.buf.0 = 0
else if \ abbrev(opt, m.j.cApp) then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufRead
jBufWrite: procedure expose m.
parse arg m, line
call oCopy line, m'.BUF.'mInc(m'.BUF.0')
return 1
endProcedure jBufRead
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class and may call its methods
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
if cl == m.class.classV then
drop m.class.o2c.m
else
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('no class found for object' obj)
endProcedure objClass
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass) 'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then do
c = m.class.o2c.obj
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
end
call objMetClaM obj, me
return 'M="'m'";'ggCode
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
if ggCla == m.class.classV then
drop m.class.o2c.t
else
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m, m.class.classV), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
t = classNew('n ORun* u', 'm oRun' code)
return oNew(m.t.name)
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/* copy o end *******************************************************/
/* copy class begin *****************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.)
is done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v value
class expression (ce) allow the following syntax
ce = name | 'v' | 'r' ce? | ('n' | 'f' | 'c') name ce
| 's' ce | 'm' name code | 'u' (ce (',' ce)*)?
'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('v')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
p = classPermanent(t, pos('\', opts) < 1)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if p == t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'v') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm \== '' then
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(t, a, pr, p1)
return x
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = '' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ****************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') \== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') \== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA \== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a \== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(ERNO001) cre=2009-08-17 mod=2009-08-17-14.21.50 A540769 ---
/* rexx
rexx hat eine Limit von 250 Zeichen für Namen inkl Stems
m.a.i und m.a.ix expandieren beide auf dasselbe mit Laenge 250
aber m.a.ix stürzt ab, wahrscheinlich prüft rexx die Laenge
nach der Expansion von a und vor der von ix ||||
***********************************************************************/
a = left('',246,'B')
i=1
ix=i
say m.a.i
say m.a.ix
exit
}¢--- A540769.WK.REXX(ERR) cre=2016-10-26 mod=2016-10-26-09.51.12 A540769 ------
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- set rc for ispf: ------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
---------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err_ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/* pop error handler -----------------------------------------------*/
errHandlerCall:
interpret m.err_handler
m.err_handlerReturned = 0
return ''
endProcedure errHandlerCall
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
ggNx = m.err_nest + 1
m.err_nest = ggNx
m.err_nest.ggNx = ggTxt
if ggNx \== 1 & ggNx \== 2 then do ggNx=ggNx by -1 to 1
say ' error nesting.'ggNx '==>' m.err_nest.ggNx
end
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then do
m.err_handlerReturned = 1
ggRet = errHandlerCall()
ggDoR = m.err_handlerReturned
m.err_handlerReturned = 1
if ggDoR then do
m.err_nest = m.err_nest - 1
return ggRet
end
end
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
m.err_nest = m.err_nest - 1
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit ----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err_cleanup = '\?'code || m.err_cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos('\?'code'\?', m.err_cleanup)
if cx > 0 then
m.err_cleanup = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if m.tso_ddAll <> '' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay | \ m.err_sayOut then
call saySt st
if m.err_sayOut & \ ( m.err_saySay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNl
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1)':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
}¢--- A540769.WK.REXX(ERR0) cre=2014-05-14 mod=2014-05-14-10.49.02 A540769 -----
/* copy err0 begin *** simple error handling **************************/
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
say 'error in' s3':' ggTxt
say 'errorhandler exiting with exit(12)'
exit 12
endSubroutine err
/* copy err0 end *** simple error handling **************************/
}¢--- A540769.WK.REXX(ER910) cre=2009-08-21 mod=2009-08-21-18.03.31 A540769 ----
/* rexx ****************************************************************
rexx exec sql gives sql error for set path
***********************************************************************/
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
address dsnRexx "connect DBAF"
say 'connect sqlCode' sqlMsg()
call sql "set current sqlid = 's100447'"
call sql 'drop view a540769.er910Pa9'
call sql "set :var = current timestamp"
say 'set var' sqlCode 'var=' var
address dsnRexx "execSql set path = 'SYSIBM'"
say "set path = 'SYSIBM' sqlCode" sqlCode sqlMsg()
address dsnRexx "execSql set path = SYSIBM"
say "set path = SYSIBM sqlCode" sqlCode sqlMsg()
address dsnRexx "execSql set path = ""SYSIBM"""
say "set path = ""SYSIBM"" sqlCode" sqlCode sqlMsg()
call sql "set path = 'SYSIBM','SYSPROC'"
call sql "set path = 'SYSIBM , SYSPROC'"
path = 'set path = SYSIBM, "A540769", "SYSPROC", OA1P, "ganz bloed"'
call sql "execute immediate :path"
call sql 'create view a540769.er910Pa9' ,
'as select * from sysibm.sysDummy1'
call sql 'commit'
address dsnRexx "disconnect"
say 'disconnect sqlCode' sqlCode
exit
sql:
parse arg ggSqlStmt
address dsnRexx "execSql" ggSqlStmt
say sqlMsg()
return
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
}¢--- A540769.WK.REXX(EXARGS) cre=2009-05-28 mod=2014-12-03-16.57.56 A540769 ---
/* rexx ****************************************************************
example rexx arguments:
say number of arguments and each argument
***********************************************************************/
parse arg a1, a2
say 'rexx RZ4/A540769.wk.rexx(exArgs) at' ,
time() 'on' sysvar(sysnode) 'user' userid()
say 'with' arg() 'arguments:' a1',' a2
do ax=1 to arg()
say ' arg' ax 'len' length(arg(ax)) '<'arg(ax)'>'
end
return
spx = 0
lx = 0
do px=1 while spx < 10
parse external l1
if l1 == '' then do
spx = spx+1
if spx > 10 then
leave
iterate
end
if spx <> 0 then do
say spx '* empty lines'
spx = 0
end
lx = lx + 1
say px 'external l1:' l1'|'
end
say lx 'non empty external lines'
if arg() < 1 then do
say '***call exArgs with 4 arguments'
call exArgs 'arg 1', 'a2', 'a3', 'und arg4' ziemlich lang 'oder?'
say '***returned from exArgs with 4 arguments'
end
say 'rexx exArgs exit'
exit
}¢--- A540769.WK.REXX(EXASS) cre=2015-10-05 mod=2015-10-05-18.50.54 A540769 ----
/* rexx
*/
c0 = sysvar('syscpu')
say c0 c0 'start'
c1 = c0
call mkStr eins, 300 , 1000
c0 = sysvar('syscpu')
say c0 (c1-c0) 'make'
c1 = c0
call copyA eins, zwei.e.f.g.h, 1000
c0 = sysvar('syscpu')
say c0 (c0-c1) 'copyA'
c1 = c0
call copyV eins, drei.e.f.g.h, 1000
c0 = sysvar('syscpu')
say c0 (c0-c1) 'copyV'
c1 = c0
exit
mkStr: procedure expose m.
parse arg m, len, cnt
abc = 'abcdefgehijklmnopqrstuvwxyz'
abc = copies(abc, 1 + cnt % length(abc))
do i=1 to cnt
s = i
do j=1 while length(s) < len
s = s substr(abc, j, 1) s
end
m.m.i = left(s, len)
end
m.m.0 = cnt
return
endProcedure mkStr
copyV: procedure expose m.
parse arg s, t, cnt
do i=1 to cnt
do j=1 to m.s.0
m.t.j = m.s.j
end
end
return
endProcedure copyV
copyA: procedure expose m.
parse arg s, t, cnt
do i=1 to cnt
do j=1 to m.s.0
m.t.j = s'.'j
end
end
return
endProcedure copyV
}¢--- A540769.WK.REXX(EXCONSOL) cre=2016-03-07 mod=2016-03-07-13.40.27 A540769 ---
/* rexx */
trace ?r
address tso console activate
address console '-dp42 dis group'
address tso console deactivate
}¢--- A540769.WK.REXX(EXCPCALL) cre=2015-12-18 mod=2015-12-18-21.47.00 A540769 ---
/* REXX ---------------------------------------------------------------
alloziert dsn.db2.exec und die dsn.db2.* ispf libararies
und macht ispf select excp
18.12.15 Walter benutzt libs dsn.db2.*
---------------------------------------------------------------------*/
parse arg aCmd, aAppl
c = 'select cmd('aCmd')'
if aAppl <> '' then
c = c 'newAppl('aAppl') passlib'
call adrIsp 'control errors return'
call adrTso "ALTLIB ACT APPL(EXEC) DA('dsn.db2.exec')"
if adrIsp("LIBDEF ISPPLIB dataset ID('dsn.db2.panels') STACK" ,
, 20) <> 0 then
call adrIsp "LIBDEF ISPPLIB DATASET ID('dsn.db2.panel') STACK"
call adrIsp "select cmd(excp) NEWAPPL(FD49) PASSLIB"
call adrIsp "LIBDEF ISPPLIB"
call adrTSO "ALTLIB DEACT APPL(EXEC)"
exit
/*--- address ispf with error checking -------------------------------*/
adrTso:
parse arg ggCmd, ggRet
address tso ggCmd
if rc = 0 | rc = ggRet then
return rc
say 'rc='rc 'for address ispecec' ggCmd
exit
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggCmd, ggRet
zerrLm = ''
address ispexec ggCmd
if rc = 0 | rc = ggRet then
return rc
say 'rc='rc zerrLm 'for address ispecec' ggCmd
exit
}¢--- A540769.WK.REXX(EXCSM) cre=2013-05-17 mod=2014-01-20-15.33.05 A540769 ----
/* rexx ----------------------------------------------------------------
csm examples |||||||| include neue incs ||||||
functions:
inAppc: get cidvar um convId zu holen, sind wir unter csmAppc?
sub rz? : submit localt/oder remote job
stAppc : start a this rexx locally under csmAppc, continue
del rz dsn: delete dsn
dsList rz mask?: datset liste
mbrList rz pds? mask=?: member Liste
mbrList rz pds? mask=?: member Liste
copy rz pds? mbr?: read into stem and show lines
sql rz dbSys: send an sql using csmASql
???? exe rz cmd: execute rexx on remote rz
----------------------------------------------------------------------*/
call errReset hi
parse arg mArg
/* mArg = 'del rz1 DSN.ABUB.AAA.DBTF.ERRX.D14013.T135604' */
if mArg = '' then
address isrEdit 'macro (mArg)'
if mArg = '' & 1 then do
mArg = "csmCopy 'rz4/A540769.wk.rexx(exCsm)', " ,
"'rz1/A540769.tmp.nnnn(qrst)'"
mArg = "csmCopy 'rz4/A540769.tmp.seq', " ,
"'rz1/A540769.tmp.nnnn(q)'"
mArg = "csmCopy 'A540769.wk.rexx', " ,
"'rz1/A540769.tmp.ttt'"
end
if mArg = '' then
exit errHelp('no input')
else if pos('?', mArg) > 0 then
exit help()
m.workLevel = 0
exit work(mArg)
work: procedure expose m.
parse arg mProc mArgs
if mProc = '' then
return
wLevel = m.workLevel + 1
m.workLevel = wLevel
rc = '?'
result = '?'
say 'exCsm' wLevel 'calling' mProc mArgs
interpret 'call' mProc mArgs
say 'exCsm' wLevel 'rc='rc 'result='result 'after call' mProc
return 0
endProcedure work
/*--- get cvidvar: conversation id -----------------------------------*/
inAppc: procedure expose m.
parse arg silent cont
if silent \== 0 & silent \==1 then
parse arg cont
cvId = '???'
call csmAppc 'get cvidvar(convId)', '*'
m.inAppc = wordPos(rc, 0 25) > 0
if silent \== 1 then do
say 'get cvidvar rc='rc '--->inAppc='m.inAppc
say 'appc_cvid ='appc_cvid
say ' cvid ='cvid
do y=0 to appc_msg.0
say 'appc_msg.'y' ='appc_msg.y
end
say 'appc_state_c ='appc_state_c
say 'appc_state_f ='appc_state_f
say 'appc_ddName ='appc_ddName
say 'appc_llu ='appc_llu
say 'appc_plu ='appc_plu
end
call work cont
return m.inAppc
endProcedure inAppc
/*--- submit local oder remote ---------------------------------------*/
sub: procedure expose m.
parse arg rz
jn = userid()'S'
say 'submitting job' jn 'to' rz
I.1 = '//'jn 'JOB (CP00,KE50),NOTIFY=&SYSUID'
I.2 = '//*MAIN CLASS=LOG0 ' time()
I.3 = '//* from' sysvar(sysnode) 'at' time() 'submit to' rz
I.4 = '//S1 EXEC PGM=IEFBR14'
if rz = '' | rz = sysvar(sysNode) then
call adrTso 'alloc dd(sub) sysout writer(intRdr)'
else /* mit freeClose braeuchte es keine Free */
call adrCsm 'allocate system('rz') sysout(T) writer(intRdr)',
'ddName(sub)'
/* call tsoOpen 'sub', 'w' */
call writeDD 'sub', i., 4
call tsoClose 'sub'
call adrTso 'free dd(sub)' /* csmExec free macht dasselbe */
return
endProcedure sub
/*--- start a rexx locally under csmAppc -----------------------------*/
stAppc: procedure expose m.
parse arg cont
return csmAppc("start pgm(csmexec)",
"Parm('Select Cmd(''%exCsm" cont"'')')", '*')
return
endProcedure stAppc
/*-- dataset list ----------------------------------------------------*/
dsList: procedure expose m.
parse arg rz dir
if dir = '' then
dir = userid()
if pos('*', dir) < 1 then
dir = dir'.**'
lc = adrCsm('dslist system('rz') dsnMask('dir') short')
say 'dsList' rz dir 'rc='lc 'stemSize='stemSize
do sx=1 to stemsize
if sx > 10 then
sx = min(2*(sx-1), stemSize)
say sx dsName.sx strip('vol='volume.sx','volume2.sx) ,
'sys='sysName.sx
end
return 0
endProcedure dsList
/*-- member list ----------------------------------------------------*/
mbrList: procedure expose m.
parse arg rz lib msk
if lib = '' then
lib = A540769.WK.REXX
if msk = '' then
msk = '*'
lc = adrCsm("mbrList system("rz") dataset('"lib"') member("msk")",
"index(' ') short")
say 'mbrList' rz lib'('msk')' 'rc='lc 'mbr_name.0='mbr_name.0
do sx=1 to mbr_name.0
if sx > 10 then
sx = min(2*(sx-1), mbr_name.0)
say sx mbr_Name.sx
end
return 0
endProcedure dsList
/*-- member list ----------------------------------------------------*/
copy: procedure expose m.
parse arg fr to
if lib = '' then do
lib = A540769.WK.REXX
mbr = 'exCsm'
end
call adrCsm "allocate system("rz") dataset('"lib"')" ,
"ddName(cpy) disp(shr) dsinfo"
say 'alloc' rc 'subsys... _dataset' ,
'dsorg('subsys_dsOrg')' ,
'mgmtClas('subsys_mgmtClas')' ,
'dsnType('subsys_rDsnType')' ,
'dataClas('subsys_dataClas')' ,
'recFM('strip(translate('1 2 3', subsys_recFm, '123'))')',
'lRecl('subsys_lRecl')' ,
'space('subsys_spacePri',' subsys_spaceSec')' ,
subsys_spacUnit || left('S', subsys_spacUnit == 'CYLINDER')
c = "copy inDD(cpy)"
if mbr <> '' then
c = c "member("mbr")"
lc = adrCsm(c 'stemout(st)', '*')
say c 'rc='lc 'st.0='st.0
call adrCsm "free ddName(cpy)"
do sx=1 to st.0
if sx > 10 then
sx = min(2*(sx-1), st.0)
say sx':' strip(st.sx, 't')
end
return 0
endProcedure dsList
del: procedure expose m.
parse arg rz dsn
say 'delete '''dsn''' in' rz
mb = dsnGetMbr(dsn)
if mb \== '' then do
mb = 'member('mb')'
call err 'csm deletes library, although member is specified|||'
end
call adrCsm "allocate system("rz") dataset('"dsnSetMbr(dsn)"')" ,
mb "disp(del) ddname(del1)"
say 'allocated with disp(del)'
call readDD del1, i., '*'
say 'read' i.0 'records 1:' strip(i.1)
i0 = i.0
say ' 'i0':' strip(i.i0)
call tsoClose del1
call adrTso 'free dd(del1)'
say 'tso free done'
return
endProcedure del
/*--- send an sql to csmASql and fetch result ------------------------*/
sql: procedure expose m.
parse upper arg rz dbSys
sql_query = 'select current server "srv", current member "mbr"' ,
', current timestamp',
'from sysibm.sysDummy1'
sql_host = rz
sql_db2ssid = dbSys
call csmAppc "START PGM(CSMASQL)"
say 'csmASql rc='rc 'sqlCode' sqlCode 'sql_message.0='sql_message.0
Do I = 1 To SQL_Message.0
Say SQL_Message.I
End
say 'sqlCode='sqlCode 'sqlErrm='sqlErrm
say 'sqlD='sqlD 'sqlRow#='sqlRow#
say 'sql_option='sql_option ,
'sql_cvid='sql_cvid 'sqlcvid='c2x(sqlcvid)
/* describe result */
Do I = 1 To Sqld
Say Right(I,2) 'sqlda_*.'i 'name='strip(Sqlda_Name.I),
'rexxname='strip(Sqlda_Rexxname.I),
'type='strip(Sqlda_Type.I),
'types='space(Sqlda_Types.I, 1),
'len='sqlda_Len.I
End
/* content of result */
Do I = 1 To Sqlrow#
Say 'Indicator:'I C2x(Sqlindicator.i)
Do J = 1 To Sqld
Say Left(J' 'Sqlda_Name.J,23) ,
sqlda_rexxName.j'.'i'='Value(Sqlda_Rexxname.J'.'I)
End
End
return
endProcedure sql
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01 ------------------------------------*/
exe: procedure expose m.
parse arg rz cmd.1
cmd.0 = 1
if 1 then do
call adrTso 'free dd(rmtSys)' ,'*'
call adrTso 'free dd(rmtsPrt)','*'
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
if cmd.1 = '' then do
cmd.1 = '%exArgs eins zwei from' sysvar(sysnode) 'to' rz'|'
cmd.2 = '%exArgs zwei laaaangeeeeeeeeeeeeeeeeeeeeeeee-'
cmd.3 = left('',70,'f')'-'
cmd.4 = left('',70, 'g')'|'
cmd.5 = '%exArgs drei fertig schlus|'
cmd.0 = 5
end
call dsnAlloc 'dd(DDCPARM) dummy'
f = dsnAlloc('dd(tsin) new ::f')
f = dsnAlloc('dd(printout) new ::f')
call writeDD tsin, cmd.
call writeDDClose tsin
call adrCms 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrTso "ex 'SM.RZ1.P0.CSM.COMMON.EXEC(TPSYSIKJ)'",
"'"rz";"csm";600'", '*'
say 'exe after remote ex tpSysiKJ rc='rc
call readDD 'printout', p.
say 'read printout' p.0 'lines'
do px=1 to p.0
say p.px
end
call tsoFree 'DDCPARM tsin printout'
call adrTso 'free dd(rmtSys rmtsPrt rmtsIn sysproc)'
say 'exe after free rc='rc 'result='result
return
endProcedure exe
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
exDi: procedure expose m.
parse arg rz cmd.1
if cmd.1 = '' then
cmd.1 = '%exArgs eins zwei from' sysvar(sysnode) 'to' rz'|'
timeout = 11
if 0 then do
call adrTso 'free dd(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call adrCsm 'allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
cmd.1 = '%exArgs' cmd 'from' sysvar(sysnode) 'to' rz'|'
call writeDD rmTsIn, cmd., 1
call writeDDClose rmtsin
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call csmAppc "start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
call csmAppcRcSay ggTsoCmd
call readDD 'rmTsPrt', p.
say p.0
do px=1 to p.0
say p.px
end
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtSys rmtsIn sysproc)'
return
endProcedure exdi
/*--- start dlg2 locally under csmAppc -------------------------------*/
dlg1: procedure expose m.
parse arg rz
call csmAppc "START PGM(CSMEXEC)",
"Parm('Select Cmd(''%exCsm dlg2 ''''" rz "'''''')')"
return
endProcedure dlg1
/*--- dialog with a rexx (under tso) in another rz
this is only possible under csmAppc| -----------------------*/
dlg2: procedure expose m.
parse arg rz cmd
timeout = 81
if 1 then do
call adrTso 'free dd(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a'), '*'
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call adrCsm 'allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrCms 'allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
cmd.1 = "%exCsm dlg3 '" cmd "from" sysvar(sysnode) "to" rz"|'"
call writeDD rmTsIn, cmd., 1
call writeDDClose rmtsin
call adrCsm 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrCms 'allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrCsm 'allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrtso "csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) timeout("timeOut")", '*'
say 'alloc rc='rc appc_rc 'rea' appc_reason 'cvid' appc_cvid
pId = appc_cvid
call csmAppcRcSay ggTsoCmd
buf = 'erstes send' time() 'von dlg2'
call csmAppc "send CVID(X'"pId"') buffer(buf) TYPE(2)", '*'
call csmAppcRcSay ggTsoCmd
buf = 'zweites send' time() 'von dlg2 soso'
call csmAppc "send CVID(X'"pId"') buffer(buf) TYPE(3)", '*'
call csmAppcRcSay ggTsoCmd
call csmAppc "receive cvid(x'"pId"') buffer(BUF)", '*'
call csmAppcRcSay ggTsoCmd
say 'buf' length(buf)':' buf
call csmAppc "DEALLOC CVID(X'"pId"') TYPE(3)", '*'
call csmAppcRcSay ggTsoCmd
call readDD 'rmTsPrt', p.
say p.0
do px=1 to p.0
say p.px
end
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtSys rmtsIn sysproc)'
return
endProcedure dlg2
dlg3: procedure expose m.
parse arg args
say 'dlg3('args')'
call csmAppc 'GET CVIDVAR(var)', '*'
call csmAppcRcSay ggTsoCmd
say ' appc_DD='appc_ddName 'llu='appc_llu 'plu='appc_plu
pId = appc_cvid
call csmAppc "receive cvid(x'"pId"') buffer(BUF)"
call csmAppcRcSay ggTsoCmd
say 'buf' length(buf)':' buf
call csmAppc "receive cvid(x'"pId"') buffer(BUF)"
call csmAppcRcSay ggTsoCmd
say 'buf' length(buf)':' buf
buf = 'antwort von dlg3' args 'um' time() 'an dlg2 auf:' buf
call csmAppc "send CVID(X'"pId"') buffer(buf) TYPE(3)", '*'
call csmAppcRcSay ggTsoCmd
return
endProcedure dlg3
/*--- start sqlUOW2 locally in csmAppc -------------------------------*/
sqlUOW1: procedure expose m.
parse arg rz dbSys .
call csmAppc "START PGM(CSMEXEC)",
"Parm('Select Cmd(''%exCsm sqlUow2 ''''"rz dbsys"'''''')')"
return
endProcedure sqlUow1
/*--- do muliple sql in a single transaction
this works only in a csmAppc Environment| -----------------*/
sqlUOW2: procedure expose m.
parse arg rz dbSys .
drop sql_cvid
sql_option = 'R'
/* send an sql to csmASql and fetch result */
call sendSql rz, dbSYs,
, 'declare global temporary table session.dgt',
'(id int, name char(20))'
if m.inAppc then /* otherwise sqlCvid is invalid */
sql_cvid = sqlCvid
call sendSql rz, dbSYs,
, "insert into session.dgt values(17, 'inserted17')"
call sendSql rz, dbSYs,
, "select * from session.dgt"
return
endProcedure squUOW2
exit
????????????????????????????
parse arg mm vv
say csmSub mm vv
mark = 'csmExec'
if mm <> mark then do
c = "csmExec select cmd('csmSub" mark mm vv"')"
say c
call adrTso c
exit
end
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg aFr, aTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
fr = csmSysDsn(aFr)
frMbr = dsnGetMbr(fr)
frDD = tsoDD('csmFr*', 'a')
to = csmSysDsn(aTo)
toMbr = dsnGetMbr(to, '=')
toDD = tsoDD('csmTo*', 'a')
call csmAlloc dsnSetMbr(fr) frDD 'shr'
if frMbr == '' & m.tso_ddDsOrg.frDD == 'PO' then
if toMbr \== '=' then
call err 'csmCopy from' fr'(*) to ps' to
else
frMbr = '*'
if frMbr == '' & (toMbr \== '' & toMbr \== '=') then
psOrLib = 'dsorg(po) dsntype(library)'
else if frMbr \== '' & toMbr == '' then
psOrLib = 'dsorg(ps)'
else
psOrLib = ''
call csmAlloc dsnSetMbr(to) toDD 'shr ::D'frDD psOrLib
c = 'indd('frDD') outDD('toDD')'
if frMbr \== '*' then do
if frMbr \== '' then
c = c 'member('frMbr')'
if toMbr \== '' & toMbr \== '=' then
c = c 'newName('toMbr')'
call adrCsm 'copy' c
end
else do
call adrCsm "mbrList ddName("frDD") index(' ') short"
say '???copying' mbr_mem# 'members'
do mx=1 to mbr_mem#
say mx '????copy' c 'member('mbr_name.mx')'
call adrCsm 'copy' c 'member('mbr_name.mx')'
end
end
call tsoFree frDD toDD
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
upper dd disp
m.tso_dd.dd = csmSysDsn(dsn)
parse var m.tso_dd.dd sys '/' dsn
if disp = '' then
disp = 'shr'
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts( , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
say '???uCount ==>' rest
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
say '???recfm ==>' rest
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
say '???cylinders ==>' rest
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
say '???cyl ==>' rest
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_ddDsOrg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc m.tso_dd.dd dd 'CAT' rest ':'nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsn')')
if stemsize <> 1 then
call err 'cmsLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
'dataClas('dataClas.1')' ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
say '???csmLike' rz'/'dsn '==>' r
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX'
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
timeout = 11
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
call outtrap m.tso_trap.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dd.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'O' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'A' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dd.dd = ''
else do
c = c "DSN('"na"')"
m.tso_dd.dd = na
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.tso_trap.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.tso_dd.dd"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt tso_trap
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dd.dsn
if lastPos('/', m.tso_dd.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dd.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
if \ hasOrg & pos('(', dsn) > 0 then do
hasOrg = 1
atts = atts 'dsorg(po) dsntype(library)'
end
if hasOrg then do
cx = pos(' DSORG(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsnOrg ==>' res
end
cx = pos(' DSNTYPE(', ' 'translate(res))
if cx > 0 then do
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
say '???? del dsntype ==>' res
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
tstUtc2d: procedure expose m.
numeric digits 33
say c2d('ffffff'x)
say utc2d('ffffff'x)
say utc2d('01000000'x) 256*256*256
say utc2d('01000001'x)
say utc2d('020000FF'x) 256*256*256*2+255
say utc2d('03020000EF'x) 256*256*256*770+239
return
endProcedure tstUtc2d
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(EXCSMED) cre=2015-11-13 mod=2015-11-14-07.29.21 A540769 ---
$#@
call adrCsm 'edit dataset(wk.rexx) member(wsh) system(rzz)',
'macro(exArgs)', 4
say rc
}¢--- A540769.WK.REXX(EXCSM2) cre=2014-01-09 mod=2014-01-09-15.13.10 A540769 ---
$#@
say 'anfang'
call exArgs 'eins', 'zwei'
call csmExRx RZ1, A540769.wk.rexx, qq , 'exArgs wie geht es dir'
do qx=1 to m.qq.0
say qx strip(m.qq.qx, t)
end
$#out 20140109 15:12:57
}¢--- A540769.WK.REXX(EXDATE) cre=2011-06-08 mod=2011-06-08-12.24.22 A540769 ---
/* rexx ****************************************************************
rexx function date, kann '1 Apr 1956' in 'n' Datumm umwandeln
aber die Syntax muss ganz genau stimmen
***********************************************************************/
call tD date()
call tD '1 Apr 1956'
call tD ' 1 Apr 1956'
call tD '1 apr 1956'
call tD '1 Apr 1956'
call tD '30 Apr 1956 '
call tD '30 Apr 1956'
call tD '30 Apr 1956'
call tD '30 Apr 56'
call tD '30 Apr 56'
call tD '30 Apr 0056'
exit
tD: procedure
parse arg da
signal on syntax name errReturn
say left("'"da"'", 16) "==>" date('s', da ,'n')
return
errReturn:
say left("'"da"'", 16) "bad date"
return
}¢--- A540769.WK.REXX(EXDB2LOG) cre=2012-07-24 mod=2015-10-19-15.55.02 A540769 ---
/* REXX
¨¨____________________________________________________________________
¨¨
¨¨ EXDB2LOG
¨¨ --------
¨¨ read mastlog output and insert the messages into tadm6* tables
¨¨
¨¨ PARMS EXDB2LOG <PARM1>
¨¨ PARM1 = DB2 SUBSYSTEM
¨¨
¨¨ LOCATION DSN.DB2.EXEC ab 4.0
¨¨ TSO.rz?.P0.USER.EXEC bis 3.1
¨¨
¨¨ HISTORY:
¨¨ 19.10.2015 V4.3 srchLi for deadlock/timeout search, cleanup
¨¨ put '' in group without err if mbr unknown
¨¨ 7.10.2015 V4.2 added support for jes2
¨¨ 2.10.2015 V4.1 for timeout also use DSNT500I and store
¨¨ these even without deadlock/timeout
¨¨ 20.10.2014 V4.0 logE2 => logEx
¨¨ 06.10.2014 V4.0 direkt aus Beta/eJes Extract DSNs lesen
¨¨ member/Datum aus IAT6140 usw.
¨¨ keine doppelte Ausgabe von Beta/eJes Logs
¨¨ 09.04.2014 V3.1 Ergebnis zusätzlich ins DSN
¨¨ 24.09.2012 V3.0 rewrite masterlog
¨¨ 18.04.2012 V2.2 rz8 und rzz integriert
¨¨ 17.04.2012 V2.1 truncate collids longer 18
¨¨ 28.03.2008 V2.0 ABNORMAL EOT (G.KERN,A914227)
¨¨ 27.03.2008 V1.1 UNCOMMITED UOW (G.KERN,A914227)
¨¨ 27.03.2008 V1.2 CHECKPOINTS (G.KERN,A914227)
¨¨ 27.03.2008 V1.3 LOCK ESCALATION (G.KERN,A914227)
¨¨ 30.01.2008 V1.0 GRUNDVERSION (G.KERN,A914227)
¨¨
¨¨_____________________________________________________________________
*/
call errReset 'h'
PARSE UPPER arg SSID rest
if 1 then do /* prod settings */
m.debug = 0
m.tstRZ4 = 0
m.writeAblfPre = 'DSN.ABLF.LOGEX.'sysvar(sysnode)
end
else if 0 then do /* test settings */
m.debug = 0
m.tstRZ4 = 1
m.writeAblfPre = 'A540769.LOGEX.ABLF'
end
else if 0 then do /* old settings */
m.debug = 1
m.insertLocal = 1
m.writeABLF = 1
end
say "exDb2Log("ssid rest") version v4.3 vom 19.10.15"
if ssid == 1 then
return doFun1()
else if ssid == 2 then
return doFun2(rest)
else if ssid == 3 then
return doFun3()
else if 0 then
return workOld(ssid)
else do
o.1 = date('s') time() sysVar(sysNode) mvsvar('symdef', 'jobname') ,
'exDb2Log workOld deActivated'
call writeDsn 'mod dsn.ablf.logDeImp ::f', o., 1
say 'exDb2Log workOld deActivated'
return 0
end
endMainCode
/*--- write timestamp to dd parmNew ----------------------------------*/
doFun1: procedure expose m.
parse arg betaExt .
call ini 1
call readDD parmOld, i., '*'
call tsoClose parmOld
ix = i.0
say 'parmOld' ix strip(i.ix, 't')
w1 = word(i.ix, 1)
if i.0 = 0 then
old = '2014-01-01-00.00.00'
else if translate(w1, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad to tst in parmOld 1:' i.ix
else if substr(w1, 15, 2) >= 15 then
old = overlay(right(substr(w1, 15, 2)-15, 2,0), w1, 15)
else if substr(w1, 12, 2) >= 1 then
old = overlay(right(substr(w1, 12, 2)-1, 2,0) ,
|| '.'right(substr(w1, 15, 2)+45, 2,0), w1, 12)
else
old = left(w1, 11)'00.00.00'
new = translate('1234-56-78', date('s'), '12345678') ,
|| '-'translate(time(), '.', ':')
if new <= old then
call err 'new' new '<=' old 'old'
o.1 = new old
call writeDD parmNew, o., 1
call tsoClose parmNew
say 'parmNew' strip(o.1, 't')
if substr(old, 6, 2) > 2 then
betaS = overlay(right(substr(old, 6, 2)-2, 2,0), old, 6)
else
betaS = overlay(left(old, 4)-1,
|| '-'right(substr(old, 6, 2)+10, 2,0), old, 1)
if substr(betaS, 9, 2) > 28 then
betaS = overlay(28, betaS, 9)
betaS = translate('78.56.1234', left(betaS, 10), '1234-56-78')
say 'betaStart' betaS 'betaExt' betaExt
o.1 = 'REPORT'
o.2 = ' SDATE('betaS')'
o.3 = ' STIME(00:00:00)'
o.4 = ' PDATE(TODAY)'
o.5 = ' PTIME(23:59:59)'
o.6 = ' JOBNAME(D***MSTR)'
call writeDD betaRePa, o., 6
call tsoClose betaRePa
a.1 = ' 00:00:00 ' /* idiotisches Rexx stuerzt ab auf leerem
konatiniertem Dataset | */
call writeDD 'betaExt', a., 1
call tsoClose 'betaExt'
call writeDD 'eJesExt', a., 1
call tsoClose 'eJesExt'
say 'written idiotic dummy row on betaExt and eJesExt'
call eJesJobExtDD 'D%%%MSTR', 'JESMSGLG'
return 0
endProcedure doFun1
/*--- select jobs from betaRep ---------------------------------------*/
doFun2: procedure expose m.
parse arg betaExt .
call ini 1
say 'fun2' betaExt
call parmNewRead
new = m.parm_new
old = m.parm_old
call readDD betaRep, b., '*'
call tsoClose betaRep
say 'dd betaRep' b.0 'lines'
do bx=1 to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' then do
bx = bx + 1
if substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' then
leave
end
if pos('NO JOBS MATCHED SELECTION', b.bx) > 0 then do
say 'no jobs in Beta report:' b.bx
return 4
end
end
if bx > b.0 then
call err 'no title found in betaRep'
say b.bx
cJ = 2
cI = 11
cE = pos(' END DATE ', b.bx)
eE = cE + 10
cF = pos(' END TIME ', b.bx) + 1
eF = cF+8
m.o.0 = 0
if cE < 20 | cF < 20 then
call err 'bad end time/date in beta title' b.bx
cS = pos(' SUB DATE ', b.bx)
eS = cS + 10
cT = pos(' SUB TIME ', b.bx) + 1
eT = cT+8
m.o.0 = 0
m.f.0 = 0
if cS < 20 | cT < 20 then
call err 'bad end time/date in beta title' b.bx
jx = 0
jy = 0
do bx=bx to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' ,
| abbrev(substr(b.bx, 2), '-----') ,
| abbrev(substr(b.bx, 2), '=====') ,
| substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' ,
| abbrev(substr(b.bx, 2), 'PROGRAM B92BFJBR ') then
iterate
if pos(' JOB(S) MATCHED SELECTI', b.bx) > 0 then do
jz = word(substr(b.bx, 2), 1)
iterate
end
say b.bx
parse var b.bx 2 vJ 10 11 vI 19 ,
=(cS) vS =(eS) =(cT) vT =(eT) ,
=(cE) vE =(eE) =(cF) vF =(eF)
if translate(vE, '999999999', '012345678') \== '99.99.9999' then
call err 'bad end date' vE 'in line' bx':' b.bx
if translate(vF, '999999999', '012345678') \= '99:99:99' then
call err 'bad end time' vF 'in line' bx':' b.bx
vG = translate('1234-56-78', vE, '78.56.1234') ,
|| '-'translate(vF, '.', ':')
jx = jx + 1
if vG << old then
iterate
jy = jy + 1
say ' selected' vJ vI', ended' vG '>>=' old 'old'
call mAdd f, 'BFIND' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' OPERATOR(OR)' ,
, ' OPTIONS(FIRST)' ,
, ' SCOPE(BOTH)' ,
, ' MESSAGE(LONG)' ,
, ' RELOAD(YES)' ,
, ' MIXEDMODE(NO)' ,
, ' SLINE(0)' ,
, ' PLINE(0)' ,
, ' STRING1(DATE)'
call mAdd o, 'PRINT' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' MASK(MM/DD/YY)' ,
, ' AUTOSEL(NO)' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' MESSAGE(LONG)' ,
, ' SCOPE(BOTH)' ,
, ' DISPOSITION(MOD)' ,
, ' DATASET('betaExt')'
end
if jx <> jz then
call err jx 'jobs read not' jz 'as beta says'
say jy 'jobs selected from' jz 'in list'
call writeDD betaExPa, 'M.O.'
call tsoClose betaExPa
call writeDD betaFiPa, 'M.F.'
call tsoClose betaFiPa
return 4 * (jy = 0)
endProcedure doFun2
/*--- read concatenated master logs and write load files -------------*/
doFun3: procedure expose m.
call ini 1
call parmNewRead
call readMstrLog
call writeAblfAll m.writeAblfPre
return 0
endProcedure doFun3
/*--- read parmNew, extract new and old timestamp --------------------*/
parmNewRead: procedure expose m.
call readDD parmNew, n., '*'
call tsoClose parmNew
parse var n.1 new old .
say 'parmNew' new old
if n.0 < 1 then
call err 'empty parmNew'
else if translate(new, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad new in parmNew:' new
else if translate(old, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad old in parmNew:' old
else if new <= old then
call err 'new <= old' new old
m.parm_new = new
m.parm_old = old
return
endProcedure parmNewRead
/*_____________________________________________________________________
¨¨
¨¨ read the whole master log
¨¨ and analyse each interesting msg
¨¨_____________________________________________________________________
*/
readMstrLog:
call logMsgBegin rd
m.to.0 = 0
m.uow.0 = 0
m.LoEs.0 = 0
m.ReEot.0 = 0
do mx=1
mid = logMsg(rd)
if mid == '' then do
say 'readMstrLog end:' readNxPos(rd)
call readNxEnd rd
return
end
else if m.info.tst <<= m.info.doneUntil then
nop /* already done yesterday or eJes <-> beta92 */
else if mid == 'DSNT375I' then
call anaTimeoutDeadlock rd, info, 'D'
else if mid == 'DSNT376I' then
call anaTimeoutDeadlock rd, info, 'T'
else if mid == 'DSNT500I' | mid == 'DSNT501I' then
call anaResourceNotAvailable rd, info, mid
else if mid == 'DSNJ031I' then
call anaUncommittedUOW rd, info, 'U'
else if mid == 'DSNR035I' then
call anaUncommittedUOW rd, info, 'C'
else if mid == 'DSNI031I' then
call anaLockEscalation rd, info, 'E'
else if mid == 'DSN3201I' then
call anaReadEot rd, info, 'A'
end
endProcedure readMstrLog
logMsgBegin: procedure expose m.
parse arg rd
call readNxBegin rd, '-', 'DDIN1'
do until m.li <> ' 00:00:00' & m.li <> ''
li = readNx(rd)
end
m.info.doneUntil = m.parm_old
m.info.head = left('? ^ # no no', 300, '}')
m.info.jobKey = ''
m.mOld = ''
m.rd.curIsMsg = 1
m.cLogMsg = 0
m.cCont = 0
m.cContCx = 0
m.cTONF = 0
m.cTONFX = 0
m.cTOFo = 0
m.cTOFoX = 0
return
endProcedure logMsgBegin
/*_____________________________________________________________________
¨¨
¨¨ get next logMsg and put parts of msg into rd.cc.1, rd.cc.2 ....
¨¨ at end return '' otherwise messageID (or ? if space)
¨¨_____________________________________________________________________
*/
logMsg: procedure expose m.
parse arg rd
m.cLogMsg = m.cLogMsg+1
li = readNxCur(rd)
if li == '' then do
say 'logMsg end:' readNxPos(rd)
if m.info.jobKey \== '' then
call logMstrEnd rd
return ''
end
line = m.li
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
return logMstrBegin(rd, line)
end
else if substr(strip(line), 1, 39) ,
== 'J E S 2 J O B L O G -- S Y S T E M ' then do
m.rd.jes2 = 1
m.info.j2Id = ''
return logMstrBegin(rd, line)
end
if m.rd.jes2 then do
if translate(substr(line, 1, 9), '999999999', '012345678') ,
\== '99.99.99 ' then do
if line = '------ JES2 JOB STATISTICS ------' then do
m.info.mid = '----stat'
/* achtung (unknown) hat space mehr | */
do cx=1 until li == '' | substr(m.li, 11, 3) = ' ' ,
| substr(m.li, 14, 1) <> ' ' ,
| substr(m.li, 15, 3) = ' '
m.rd.cc.cx = m.li
li = readNx(rd)
end
m.rd.cc.0 = cx
return m.info.mid
end
else
call err 'bad time in jes2 line' readNxPos(rd)
end
m.info.time = word(line, 1)
w2 = substr(line, 10, 8)
if w2 \== m.info.j2Id then do
if w2 = '' then
say 'jes2 empty id ???' readNxPos(rd)
else if m.info.j2Id \== '' then
call err 'jes2 id mismach' m.info.j2Id ,
'<>' readNxPos(rd)
else if pos(' ', w2) > 0 then
call err 'bad jes2 id' w2 'in' readNxPos(rd)
else
m.info.j2Id = w2
end
if substr(line, 18, 1) \== ' ' then
call err 'bad jes2 line' readNxPos(rd)
else if substr(line, 18, 6) == ' ---- ' then do
if word(line, 8) \== '----' then
call err 'bad jes2 ---- line' readNxPos(r)
call anaCurDate info, subword(substr(line, 24), 2, 3)
m.info.mid = '----date'
end
else do
m.info.mid = word(line, 3)
end
m.info.tst = m.info.date'-'m.info.time
call logMsgContJes2 rd, line
end
else do
if translate(substr(line, 1, 10), '999999999', '012345678') ,
\== ' 99:99:99 ' then
call err 'bad time in jes3 line' readNxPos(rd)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if substr(line, 10, 14) == ' ---- IAT6853 ' then do
if substr(line, 24, 20) \== 'THE CURRENT DATE IS ' then
call err 'bad IAT6853' readNxPos(rd)
call anaCurDate info, subword(substr(line, 44), 2, 3)
m.info.mid = 'IAT6853'
end
else do
m.info.mid = word(line, 2)
end
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
call logMsgContJes3 rd, line
end
if m.info.mid = '' then
return '?'
else
return m.info.mid
endProcedure logMsg
logMsgContJes2: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
if translate(right(line, 5), 000000000,123456789)== ' 000' then do
mSeq = right(line, 3)
m.mOld = mSeq subWord(m.mOld, 1, 49)
m.rd.cc.1 = substr(line, 19, length(line)-23)
end
else do
mSeq = ''
m.rd.cc.1 = substr(line, 19)
end
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
else if mSeq \== '' & left(m.li, 19) = ' 'mSeq then do
cx = cx + 1
m.rd.cc.cx = substr(m.li, 19)
end
else if translate(left(m.li, 19), 000000000, 123456789) ,
= ' 000' then do /* out of sequence look next */
/* ??? ix = wordPos(substr(m.li, 4, 3), m.mOld)
if symbol('m.igno.ix') == 'VAR' then
m.igno.ix = m.igno.ix + 1
else
m.igno.ix = 1
if ix < 1 then
say 'ignoring after' m.info.mid'#'mSeq readNxPos(rd)
??? */ end
else if m.li = ' 00:00:00' then do
end /* ignore marker from fun1 */
else
leave
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes2
logMsgContJes3: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
m.rd.cc.1 = substr(line, 10)
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
if \ abbrev(m.li, m.info.head) then do
if translate(substr(m.li, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then
leave
if translate(substr(m.info.head 2, 9) ,
, '999999999', '012345678') \== '99:99:99 ' then
leave
ds =((( substr(m.li, 2, 2) * 60) ,
+ substr(m.li, 5, 2) * 60) ,
+ substr(m.li, 8, 2)) ,
-((( substr(m.info.head, 2, 2) * 60) ,
+ substr(m.info.head, 5, 2) * 60) ,
+ substr(m.info.head, 8, 2))
if ds < 0 | ds > 3 then
leave
end
if substr(m.li, 10, 14) == ' ---- IAT6853 ' then
leave
vx = verify(m.li, ' ', 'N', 10)
if vx = 11 | vx = 12 then do
w2 = word(m.li, 2)
if (length(w2) == 7 | length(w2) == 8) ,
& verify(w2, m.ut_ucNum) = 0 then
if wordPos(left(w2, 3), 'IAT ACF DSN IEF IXL') > 0 then
leave
end
cx = cx + 1
m.rd.cc.cx = substr(m.li, 10)
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes3
logMstrEnd: procedure expose m.
parse arg rd
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
if m.rd.jes2 then
j = 'jes2'
else
j = 'jes3'
say j m.info.job jKy 'to' m.info.tst p
/* ????
ii = ''
o ix=0 to 99
if symbol('m.igno.ix') == 'VAR' then
ii = ii ix'='m.igno.ix
end
say ii
??? */
say 'logMsg='m.cLogMsg 'cont='m.cCont 'contCx='m.cContCx,
'toNf='m.cTONf 'toNFX='m.cTONfX 'toFo='m.cTOFo 'toFoX='m.ctoFoX
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' | jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
return
endProcedure logMstrEnd
logMstrBegin: procedure expose m.
parse arg rd, line
if m.info.jobKey \== '' then
call logMstrEnd rd
m.info.dateTst = ''
do until m.li <> ''
li = readNx(rd)
end
do lx=1 to 50
mid = logMsg(rd)
if mid = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if mid == 'IEF403I' then do
j1 = word(m.rd.cc.1, 2)
s1 = word(m.rd.cc.1, words(m.rd.cc.1))
end
else if mid == 'DSNY024I'then do
m2 = substr(word(m.rd.cc.1, 2), 2)
leave
end
else if abbrev(mid, 'DSN') then do
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
call errHandlerPushRet ''
m.info.dbSys = iiMbr2DbSys(m2)
call errHandlerPop ''
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
m.to.mstrBegin = m.to.0 + 1
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return mid
endProcedure logMstrBegin
/*_____________________________________________________________________
¨¨
¨¨ if this is not a dsn message return ''
¨¨ otherwise, check it, collect infos into info and return id
¨¨_____________________________________________________________________
*/
isDsnMsg: procedure expose m.
parse arg line, info
if m.modeNew? then do
if translate(substr(line, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then do
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
call err 'bad line' line
s1 = ''
m2 = ''
if m.info.jobKey \== '' then do
call sayJobEnd info
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' ,
| jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
end
m.info.dateTst = ''
do lx=1 to 50
ln = readNx(rd)
if ln = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if translate(substr(m.ln, 2, 9), '999999999',
, '012345678') \== '99:99:99 ' then do
say 'bad start of mstrLog after' line
say ' @' readNxPos(rd)
return isDsnMsg(m.ln, info)
end
if word(m.ln, 2) == 'IEF403I' then do
j1 = word(m.ln, 3)
s1 = word(m.ln, words(m.ln))
end
else do
d2 = isDsnMsg(m.ln, info)
if d2 = 'DSNY024I' then do
m2 = substr(word(m.ln, 3), 2)
leave
end
else if d2 \== '' then
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
call errHandlerPushRet ''
m.info.dbSys = iiMbr2DbSys(m2)
call errHandlerPop
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return ''
end
mid = word(line, 2)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
return ''
end
end
else do
mid = word(line, 4)
parse var line m.info.dbMb m.info.date m.info.time .
call errHandlerPushRet ''
m.info.dbSys = iiMbr2DbSys(m.info.dbMb)
call errHandlerPop
if \ abbrev(mid, 'DSN') | wordIndex(line, 4) <> 29 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 5) = 'IAT6853' then
call anaCurDate info, substr(line,18), word(line,2)
m.info.wxTime = 3
m.info.cxTime = 19
return ''
end
m.info.head = left(line,27)
end
/* diese Prüfung ist falsch, manche displays zeigen --------------
Infos aus anderen membern an, z.B. -dis indoubt ......
aMbr = word(line, 5)
if abbrev(aMbr, '-') then
if '-'m.info.dbMb \== aMbr then
call err 'dbMember mismatch:' m.info.dbMb ,
'<>' readNxPos(rd) -----------------------------*/
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
return mid
endProcedure isDsnMsg
sayJobEnd: procedure expose m.
parse arg info
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
say 'job' m.info.job jKy 'to' m.info.tst p
return
endProcedure say JobEnd
/*_____________________________________________________________________
¨¨
¨¨ analyse current date in iat6853 message
¨¨ and check that it equals the header
¨¨_____________________________________________________________________
*/
anaCurDate: procedure expose m.
parse arg info, d1, compD
d2 = word(d1, 1) ,
translate(left(word(d1, 2), 1)),
|| translate(substr(word(d1, 2), 2),
, m.ut_AlfLC, m.ut_uc) ,
word(d1, 3)
do while abbrev(d2, 0) /* date does not accept leading zeroes ||||| */
d2 = substr(d2, 2)
end
d3 = date('s', d2)
m.info.date = translate('1234-56-78', d3, '12345678')
m.info.dateTst = m.info.date'-'translate(m.info.time,'.',':')
if compD \== '' then
if m.info.date <> compD then
call err 'date mismatch' compD '<>' d3 readNxPos(rd)
return
endProcedure anaCurDate
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSN3201I event type A - ABNORMAL EOT AUS INPUT-DS LESEN
¨¨____________________________________________________________________
*/
anaReadEot: procedure expose m.
parse arg rd, info, pEvTy
m.ReEot.0 = m.ReEot.0 +1
ux = 'REEOT.'m.ReEot.0 /*zähler */
m.ux.A = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.corr = ''
m.ux.Jobname = ''
m.ux.conn = ''
m.ux.AuthID = '' /* AuthID = User column in db2 Table */
m.ux.AsID = ''
m.ux.tcb = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
jx = pos(' JOBNAME=', m.rd.cc.lx)
if cx > 0 then do
if jx < cx then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16)))
else
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16,
, jx-cx-16)))
end
if jx > 0 then
m.ux.Jobname = cut18(word(strip(substr(m.rd.cc.lx,jx+9)),1))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then do
m.ux.conn = cut18(word(substr(m.rd.cc.lx,cx+15), 1))
end
cx = pos(' USER=', m.rd.cc.lx)
if cx > 0 then do
m.ux.AuthID = word(substr(m.rd.cc.lx,cx+6), 1)
end
cx = pos(' ASID=', m.rd.cc.lx)
if cx > 0 then
m.ux.AsID = word(substr(m.rd.cc.lx,cx+6), 1)
cx = pos(' TCB=', m.rd.cc.lx)
if cx > 0 then
m.ux.tcb = strip(substr(m.rd.cc.lx,cx+5))
/* if m.ux.tcb <> '' then
leave ????? */
end
return
endProcedure anaReadEot
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSNI031I event type E - LOCK ESCALATION
¨¨____________________________________________________________________
*/
anaLockEscalation: procedure expose m.
parse arg rd, info, pEvTy
m.LoEs.0 = m.LoEs.0 +1
ux = 'LOES.'m.LoEs.0 /*zähler */
m.ux.E = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.plan = ''
m.ux.package = ''
m.ux.CollID = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.resource = ''
m.ux.LckSt = ''
m.ux.Statement = ''
do lx=1 to m.rd.cc.0
cx = pos(' RESOURCE NAME = ', m.rd.cc.lx)
if cx > 0 then
m.ux.resource = strip(word(m.rd.cc.lx, 4))
cx = pos(' LOCK STATE = ', m.rd.cc.lx)
if cx > 0 then
m.ux.LckSt = strip(word(m.rd.cc.lx, 4))
cx = pos(' PLAN NAME : PACKAGE NAME = ',m.rd.cc.lx)
if cx > 0 then do
PlanPack = substr(m.rd.cc.lx,cx+28)
cx = pos(':',planpack)
m.ux.plan = strip(left(planPack, cx-1))
m.ux.package = cut18(strip(substr(planPack,cx+1)))
end
cx = pos(' COLLECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.CollID = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' STATEMENT NUMBER = ', m.rd.cc.lx)
if cx > 0 then
m.ux.Statement= strip(substr(m.rd.cc.lx,cx+20))
cx = pos(' CORRELATION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+18)))
cx = pos(' CONNECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
/* if m.ux.conn <> '' then
leave ???????? */
end
return
endProcedure anaLockEscalation
sayObj: procedure expose m.
parse arg ff, o
say o':' cl
do fx=1 to m.ff.0
f1 = m.ff.fx
say left(f1, 20) m.o.f1
end
return
endProcedure sayObj
/*____________________________________________________________________
¨¨
¨¨ analye uncommit UOW msg: DSNJ031I / event type U and C
¨¨____________________________________________________________________
*/
anaUncommittedUOW: procedure expose m.
parse arg rd, info, pEvTy
m.uow.0 = m.uow.0 +1
ux = 'UOW.'m.uow.0 /* zähler */
m.ux.UC = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.logRecs = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.plan = ''
m.ux.authid = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CHECKPOINTS -', m.rd.cc.lx) /* for checkP */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 2))
cx = pos(' LOG RECORDS -', m.rd.cc.lx) /* for UOW */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 3))
cx = pos(' CORRELATION NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(word(substr(m.rd.cc.lx,cx+19),1))
cx = pos(' CONNECTION ID =', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' PLAN NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.plan = strip(substr(m.rd.cc.lx,cx+13))
cx = pos(' AUTHID =', m.rd.cc.lx)
if cx > 0 then
m.ux.authid = strip(substr(m.rd.cc.lx,cx+9))
/* if m.ux.authid <> '' then
leave ???????????? */
end
return
endProcedure anaUncommittedUOW
/*____________________________________________________________________
¨¨
¨¨ analye timeout, deadlock msg: DSNT375I, DSNT376I
¨¨____________________________________________________________________
*/
anaTimeoutDeadlock: procedure expose m.
parse arg rd, info, pEvTy
totx = newTimeout(info, pEvTy)
vs = 'V'
do lx=1 to m.rd.cc.0
if pos(' ONE HOLDER ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'T' then
call err 'holder for evTy' pEvTy':'m.rd.cc.lx ,
readNxPos(r)
else if vs <> 'V' then
call err 'several holders:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
if pos(' IS DEADLOCKED ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'D' then
call err 'is deadLocked for evTy' ,
pEvTy':'m.rd.cc.lx readNxPos(r)
else if vs <> 'V' then
call err 'several is deadLocked:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
cx = pos(' PLAN=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.plan = word(substr(m.rd.cc.lx, cx+6,8), 1)
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.corr = cut18(strip(substr(m.rd.cc.lx, cx+16)))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.conn = cut18(strip(substr(m.rd.cc.lx, cx+15)))
cx = pos(' ON MEMBER ', m.rd.cc.lx)
if cx > 0 then do
if vs <> 'H' then
call err 'on member in vs' vs':'m.rd.cc.lx readNxPos(rd)
else
m.toTx.vs.dbMb = word(substr(m.rd.cc.lx, cx+11, 8), 1)
end
end
return
endProcedure anaTimeOut
/*____________________________________________________________________
¨¨
¨¨ make and initialise a new timeout/deadlock row
¨¨____________________________________________________________________
*/
newTimeout: procedure expose m.
parse arg info, pEvTy
toTy = 'TO.'m.to.0
m.to.0 = m.to.0 + 1
toTx = 'TO.'m.to.0
call clearFlds totx, ffTimeO
m.toTx.tst = m.info.tst
m.toTx.evTy = pEvTy
m.toTx.v.dbMb = m.info.dbMb
m.toTx.dbSys = m.info.dbSys
if m.to.0 <= m.to.mstrBegin then
m.toTx.srchLi = ''
else if m.toTy.name = '' then
m.toTx.srchLi = toTy
else
m.toTx.srchLi = m.toTy.srchLi
return toTx
endProcedure newTimeout
/*____________________________________________________________________
¨¨
¨¨ analyse resourceNotAvailable msg DSNT501I and DSNT500I
¨¨____________________________________________________________________
*/
anaResourceNotAvailable: procedure expose m.
parse arg rd, info, mid
tCor = ''
tCon = ''
tRea = ''
tTyp = ''
tNam = ''
do lx = 1 to m.rd.cc.0 /* loop line of dsnt501i */
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
tCor = word(substr(m.rd.cc.lx,cx+16),1)
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
tCon = strip(substr(m.rd.cc.lx,cx+15))
cx = pos(' REASON ', m.rd.cc.lx)
if cx > 0 then
tRea = word(substr(m.rd.cc.lx,cx+8,20),1)
cx = pos(' TYPE ', m.rd.cc.lx)
if cx > 0 then
tTyp = word(substr(m.rd.cc.lx,cx+6,20),1)
cx = pos(' NAME ', m.rd.cc.lx)
if cx > 0 then
tNam = strip(substr(m.rd.cc.lx,cx+6))
end /* loop line of dsnt501i */
/* search preceeding timeOut/deadLock*/
toTx = 'TO.'m.to.0
if tCor = '' | tCon = '' then do
if m.toTx.name \== '' then
toTx = ''
end
else do
/* attention, sometimes we have 1000 s of resource not available
and this search would get really slow
==> use searchLi chain, chaining together TimeOuts
WITHOUT resource name */
mb = m.info.dbMb
tsN = m.info.tst
numeric digits 20
tsB = timeDays2Tst(timestamp2Days(tsN) - 30/86400)
numeric digits 9
do qx=0 while toTx \== ''
if qx > 10000 then do
say 'loopiiiiiiiiiiing' qx toTx
end
else if m.toTx.tst << tsB then do
toTx = ''
leave
end
else if m.toTx.v.corr == tCor & m.toTx.v.conn == tCon ,
& m.toTx.name == '' then
leave
toTx = m.toTx.srchLi
end
if toTx == '' then do
m.ctoNF = m.ctoNF + 1
m.ctoNFX = m.ctoNFx + qx
end
else do
m.ctoFo = m.ctoFo + 1
m.ctoFoX = m.ctoFox + qx
end
end
/* new feature: store these also
evType depending on reason, but some have several */
if toTx == '' then do
if wordPos(tRea, '00C200FA 00C20031 00C900C0 00E70010') >0 then
toTx = newTimeout(info, 'T')
else
toTx = newTimeout(info, '')
m.toTx.v.corr = tCor
m.toTx.v.conn = tCon
end
/* resource an timeout/deadlock anhängen */
m.toTx.type = tTyp
m.toTx.name = space(tNam, 1)
m.toTx.reason = tRea
if tTyp <> '' then
call resourceType info, toTx'.'type, toTx'.'name
return
endProcedure anaResourceNotAvailable
/*____________________________________________________________________
¨¨
¨¨ give the name of the resourcetype and dbid/obid
¨¨____________________________________________________________________
*/
resourceType: procedure expose m.
parse arg info, tp, nm
cd = m.tp
if symbol('m.resourceType.cd') <> 'VAR' then do
say '<'cd'>' c2x(cd)
say readNxPos(rd)
call err 'unknown resource type' cd
end
m.tp = m.resourceType.cd
parms = m.resourceTypeParms.cd
names = m.nm
if pos('DI.OI', parms) > 0 then do /* find dbid and obid */
px = 0
nx = 0
do until px = 0
py = pos('.', parms, px + 1)
ny = pos('.', names, nx + 1)
if (py=0) <> (ny=0) then
call err 'resource parms' parms 'mismatch name' names
if py = 0 then do
p1 = substr(parms, px+1)
n1 = substr(names, nx+1)
end
else do
p1 = substr(parms, px+1, py-px-1)
n1 = substr(names, nx+1, ny-nx-1)
end
n.p1 = n1
px = py
nx = ny
end
/* dbid und obid uebersetzen */
m.nm = strip(getDbidObid(m.info.dbSys, n.di, n.oi) names)
end
return cd
endProcedure resourceType
ini: procedure expose m.
parse arg m.modeNew
call resourceTypeIni
call sqlIni
call errAddCleanup "if m.sql_dbSys <> '' then do;" ,
"say 'rollback';call sqlExec Rollback; call sqlDisconnect; end"
if m.modeNew then
f1 = 'TST DBSYS'
else
f1 = 'TST'
call iniFlds ffTimeO, f1 'V.DBMB EVTY V.PLAN V.CORR V.CONN' ,
'H.PLAN H.CORR H.CONN' ,
'REASON TYPE NAME'
call iniFlds ffUow, f1 'DBMB UC PLAN CORR CONN AUTHID LOGRECS'
call iniFlds ffLockE, f1 'DBMB E PLAN PACKAGE COLLID' ,
'CORR CONN RESOURCE LCKST STATEMENT'
call iniFlds ffEOT, f1 'DBMB A CORR JOBNAME CONN AUTHID ASID TCB'
return
endProcedure ini
iniFlds: procedure expose m.
parse arg ff, flds
do fx=1 to words(flds)
m.ff.fx = word(flds, fx)
end
m.ff.0 = words(flds)
return
endProcedure iniFlds
clearFlds: procedure expose m.
parse arg o, ff
do fx=1 to m.ff.0
f1 = m.ff.fx
m.o.f1 = ''
end
return o
endProcedure clearlds
resourceTypeIni: procedure expose m.
/* the old definitions for backward compability */
call rtDef '00000100', 'DB'
call rtDef '00000200', 'TS'
call rtDef '00000201', 'IX-SPACE'
call rtDef '00000202', 'TS'
call rtDef '00000210', 'PARTITION'
call rtDef '00000220', 'DATASET'
call rtDef '00000230', 'TEMP FILE'
call rtDef '00000300', 'TEMP FILE'
call rtDef '00000300', 'PAGE'
call rtDef '00000301', 'IX-MINIPAGE'
call rtDef '00000302', 'TS-PAGE'
call rtDef '00000303', 'IX-PAGE'
call rtDef '00000304', 'TS-RID'
call rtDef '00000D01', 'DBID/OBID'
call rtDef '00000800', 'PLAN'
call rtDef '00000801', 'PACKAGE'
call rtDef '00002000', 'TS CS-CLAIM CLASS'
call rtDef '00002001', 'TS RR-CLAIM CLASS'
call rtDef '00002002', 'TS WRITE-CLAIM CLASS'
call rtDef '00002003', 'IX CS-CLAIM CLASS'
call rtDef '00002004', 'IX RR-CLAIM CLASS'
call rtDef '00002005', 'IX WRITE-CLAIM CLASS'
call rtDef '00002006', 'TS PART CS-CLAIM CLASS'
call rtDef '00002007', 'TS PART RR-CLAIM CLASS'
call rtDef '00002008', 'TS PART WRITE-CLAIM CLASS'
call rtDef '00002009', 'IX PART CS-CLAIM CLASS'
call rtDef '00002010', 'IX PART RR-CLAIM CLASS'
call rtDef '00002011', 'IX PART WRITE-CLAIM CLASS'
/* the complete Db2V10 resource type table */
call rtDef '00000100', 'Database', 'DB'
call rtDef '00000200', 'Table space', 'DB.SP'
call rtDef '00000201', 'Index space', 'DB.SP'
call rtDef '00000202', 'Table space RD.DB.TS'
call rtDef '00000205', 'Compression Dictionary', 'DB.SP'
call rtDef '00000210', 'Partition', 'DB.SP.PT'
call rtDef '00000220', 'Data set', 'DSN'
call rtDef '00000230', 'Temporary file', 'SZ'
call rtDef '00000240', 'Database procedure', 'DBP'
call rtDef '00000300', 'Page', 'DB.SP.PG'
call rtDef '00000301', 'Index minipage', 'DB.SP.PG.MP'
call rtDef '00000302', 'Table space page', 'DB.SP.PG'
call rtDef '00000303', 'Index space page', 'DB.SP.PG'
call rtDef '00000304', 'Table space RID', 'DB.SP.RID'
call rtDef '00000305', 'Index access/table space RID', 'DB.SP.RID'
call rtDef '00000306', 'Index access/table space page', 'DB.SP.PG'
call rtDef '00000307', 'Index space EOF', 'DB.SP.01'
call rtDef '00000400', 'ICF catalog', 'IC'
call rtDef '00000401', 'Authorization function'
call rtDef '00000402', 'Security Server',
, 'SAF/RACF return/reason codes'
call rtDef '00000500', 'Storage group', 'SG'
call rtDef '00000602', 'EDM DBD Space'
call rtDef '00000603', 'EDM DYNAMIC STATEMENT Space'
call rtDef '00000604', 'EDM skeleton storage'
call rtDef '00000605', 'EDM above-the-bar storage'
call rtDef '00000606', 'EDM below-the-bar storage'
call rtDef '00000700', 'Buffer pool space', 'BP'
call rtDef '00000701', 'Group buffer pool', 'GBP'
call rtDef '00000800', 'Plan', 'PL'
call rtDef '00000801', 'Package', 'COLLECTION.PACKAGE.CONTOKEN'
call rtDef '00000802', 'BINDLOCK01 through BINDLOCK20',
, 'BINDLOCK01 through BINDLOCK20'
call rtDef '00000900', '32KB data area'
call rtDef '00000901', 'Sort storage'
call rtDef '00000903', 'Hash anchor', 'DB.SP.PG.AI'
call rtDef '00000904', 'RIDLIST storage'
call rtDef '00000905', 'IRLM storage'
call rtDef '00000906', 'DB2', 'MEMBER'
call rtDef '00000907', 'LOB storage'
call rtDef '00000908', 'Basic Floating Point Extensions Facility'
call rtDef '00000909', 'Extended Time-of-Day (TOD) Clock'
call rtDef '0000090A', 'XML storage'
call rtDef '00000A00', 'Table', 'RD.CR.TB'
call rtDef '00000A10', 'Alias', 'RELDEP.OWNER.ALIAS.RD.CR.AL'
call rtDef '00000A11', 'Distinct type', 'SC.DT'
call rtDef '00000A12', 'User-defined function', 'SC.SN'
call rtDef '00000A13', 'Stored procedure', 'SC.SN'
call rtDef '00000A14', 'Sequence'
call rtDef '00000A16', 'Role'
call rtDef '00000A17', 'Trigger'
call rtDef '00000B00', 'View', 'RD.CR.VW'
call rtDef '00000C00', 'Index', 'RD.CR.IX'
call rtDef '00000C01', 'Index', 'CR.IX'
call rtDef '00000D00', 'DBID/OBID', 'RD.DI.OI'
call rtDef '00000D01', 'DBID/OBID', 'DI.OI'
call rtDef '00000D02', 'OBID', 'OI'
call rtDef '00000E00', 'SU limit exceeded', 'CN'
call rtDef '00000F00', 'Auxiliary column',
,'DI.OI.ROWID.COLN or DI.OI.DOCID.COLN'
call rtDef '00000F01', 'LOB lock', 'DIX.PIX.ROWID.VRSN'
call rtDef '00000F81', 'XML lock', 'DIX.PIX.DOCID'
call rtDef '00001000', 'DDF', 'LOCATION or SUBSYSTEM ID'
call rtDef '00001001', 'System conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001002', 'Agent conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001003', 'CNOS processing',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001004', 'CDB (Communication database)',
, 'LOCATION.AUTHORIZATIONID.PL'
call rtDef '00001005', 'DB access agent', 'LOCATION'
call rtDef '00001007', 'TCP/IP domain name', 'LINKNAME.DOMAIN.ERRNO'
call rtDef '00001008', 'TCP/IP service name', 'LOCATION.SERVICE.ERRNO'
call rtDef '00001080', 'ACCEL', 'SERVER.DOMAIN'
call rtDef '00001102', 'Bootstrap data set (BSDS)', 'MEMBER'
call rtDef '00002000', 'Table space CS-claim class', 'DB.SP'
call rtDef '00002001', 'Table space RR-claim class', 'DB.SP'
call rtDef '00002002', 'Table space write-claim class', 'DB.SP'
call rtDef '00002003', 'Index space CS-claim class', 'DB.SP'
call rtDef '00002004', 'Index space RR-claim class', 'DB.SP'
call rtDef '00002005', 'Index space write-claim class', 'DB.SP'
call rtDef '00002006', 'Table space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002007', 'Table space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002008', 'Table space partition write-claim class',
, 'DB.SP.PT'
call rtDef '00002009', 'Index space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002010', 'Index space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002011', 'Index space partition Write-claim class',
, 'DB.SP.PT'
call rtDef '00002100', 'Table space DBET entry', 'DB.SP'
call rtDef '00002101', 'Index space DBET entry', 'DB.SP'
call rtDef '00002102', 'Table space partition DBET entry', 'DB.SP.PT'
call rtDef '00002103', 'Index space partition DBET entry', 'DB.SP.PT'
call rtDef '00002104', 'DBET hash chain lock timeout',
, 'INTERNAL LOCK NN'
call rtDef '00002105', 'Logical partition DBET entry', 'DB.SP.PT'
call rtDef '00002200', 'Routine Parameter Storage', 'DBP'
call rtDef '00002201', 'm.debug Agent Storage', 'DBP'
call rtDef '00002300', 'ICSF encryption and decryption facilities'
call rtDef '00003000', 'Code (release maintenance_level or system' ,
'parameter)', 'REL,APAR,ZPARM'
call rtDef '00003002', 'Number of Stored Procedures'
call rtDef '00003072', 'Index'
call rtDef '00003073', 'Index'
call rtDef '00003328', 'Release dependency'
call rtDef '00003329', 'DBID/OBID', 'DI.OI'
call rtDef '00003330', 'OBID limit exceeded'
call rtDef '00003840', 'LOB column'
call rtDef '00004000', 'Profile exception threshold exceeded',
, 'PID.PTYPE.PNAME'
return
endProcedure resourceTypeIni
rtDef: procedure expose m.
parse arg cd, nm, pa
if symbol('m.resourceType.cd') <> 'VAR' then
m.resourceType.cd = nm
m.resourceTypeParms.cd = pa
return
endProcedure rtDef
getDbidObid: procedure expose m.
parse arg dbSys, dbid, obid
SQL_DBID = STRIP(dbid,L,0)
SQL_OBID = STRIP(obid,L,0)
if symbol('m.id2n.dbSys.dbidObid.dbid.obid') == 'VAR' then
/* haben es schon mal gefunden*/
return m.id2n.dbSys.dbidObid.dbid.obid
/* select from catalog */
/* from sysTables */
if dbSys \== m.sql_dbSys then do
if m.sql_dbSys \== '' then
call sqlDisconnect
if m.tstRZ4 then
if sysvar(sysNode) = 'RZ4' ,
& wordPos(dbSys, 'DP4G DBOL') < 1 then
return ''
call sqlConnect dbSys
end
res = sql2One("SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROm SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One("SELECT ",
" STRIP(DBNAME,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One( "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
m.dbidObid.dbid.obid = res
return m.dbidObid.dbid.obid
endProcedure getDbidObid
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM60A1
¨¨_________________________________________________________________________
*/
INSERT_TADM60A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM60A1..."
cIns = 0
cDead = 0
cTime = 0
say ' ' time() 'begin insert into tadm60a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM60A1 (" ,
"TIMESTAMP, ssid, event_type," ,
"VICTIM_PLAN, VICTIM_CORR_ID, VICTIM_COnn_ID," ,
"SOURCE_PLAN, SOURCE_CORR_ID, SOURCE_COnn_ID," ,
"REASON_CODE, type, name )" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
do tx=1 to m.to.0
/*______________________________________________________________________
row überspringen falls alt
*/
if (m.to.tx.evTy == 'D' & m.to.tx.tst <= m.lastDeadlock ) ,
|(m.to.tx.evTy == 'T' & m.to.tx.tst <= m.lastTimeout ) then
iterate
call sqlUpdArgs 7,
, m.to.tx.tst, m.to.tx.v.dbMb, m.to.tx.evTy,
, m.to.tx.v.plan, m.to.tx.v.corr, m.to.tx.v.conn,
, m.to.tx.h.plan, m.to.tx.h.corr, m.to.tx.h.conn,
, m.to.tx.reason, m.to.tx.type, m.to.tx.name
cIns = cIns + 1
cDead = cDead + (m.to.tx.evTy == 'D')
cTime = cTime + (m.to.tx.evTy == 'T')
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm60a1,' ,
cDead 'deadlocks and' cTime 'timeouts'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM60A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM63A1
¨¨_________________________________________________________________________
*/
INSERT_TADM63A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM63A1..."
say ' ' time() 'begin insert into tadm63a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM63A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"CORRID_ID," ,
"CONN_ID," ,
"AUTHID," ,
"LOGREC)" ,
"VALUES (?,?,?,?,?,?,?,?)"
cIns = 0
cUOW = 0
cCHK = 0
do tx=1 to m.uow.0
ux = 'UOW.'tx
if m.ux.UC == 'U' & m.ux.tst <= m.lastUOW then
iterate
if m.ux.UC == 'C' & m.ux.tst <= m.lastCheckp then
iterate
cIns = cIns + 1
cUOW = cUOW + (m.ux.UC == 'U')
cCHK = cCHK + (m.ux.UC == 'C')
call sqlUpdArgs 7,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.UC,
,m.ux.plan,
,m.ux.corr,
,m.ux.conn,
,m.ux.authid,
,m.ux.logRecs
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm63a1,' ,
cUOW 'uncommitedUOW and' cCHK 'checkpoints'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM63A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM64A1
¨¨_________________________________________________________________________
*/
INSERT_TADM64A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM64A1..."
say ' ' time() 'begin insert into tadm64a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM64A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"PACKAGE_NAME," ,
"COLLECTION_ID," ,
"CORRID_ID," ,
"CONN_ID," ,
"RESOURCE," ,
"LOCK_STATE," ,
"STATEMENT)" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.LoEs.0
ux = 'LOES.'tx
if m.ux.tst <= m.lastLockesc then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.E,
,m.ux.plan,
,m.ux.package,
,m.ux.CollID,
,m.ux.corr,
,m.ux.conn,
,m.ux.resource,
,m.ux.LckSt,
,m.ux.Statement
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm64a1,' ' LOCK ESCALATION'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM64A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM65A1
¨¨_________________________________________________________________________
*/
INSERT_TADM65A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM65A1..."
say ' ' time() 'begin insert into tadm65a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM65A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"CORRID_ID," ,
"JOBNAME," ,
"CONN_ID," ,
"AUTHID," ,
"ASID," ,
"TCB)" ,
"VALUES (?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.ReEot.0
ux = 'REEOT.'tx
if m.ux.tst <= m.lastReadEot then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.A,
,m.ux.corr,
,m.ux.Jobname,
,m.ux.conn,
,m.ux.AuthID,
,m.ux.AsID,
,m.ux.tcb
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm65a1,' ' ABNORMAL EOT'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM65A1..."
RETURN;
/*-- quote text t with apostrophs (sql string)
truncate if longer then 18 characters ---------------------------*/
cut18: procedure expose m.
parse arg t
if length(t) <= 18 then
return t
else
return left(space(t, 1), 18)
endProcedur cut18
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/*_____________________________________________________________________
¨¨
¨¨ DSN erstellen für RZ4
¨¨_____________________________________________________________________
*/
writeAblfAll: procedure expose m.
parse arg pre
call writeAblf to, fftimeO, pre'.TADM60A1'
call writeAblf uow, ffUow, pre'.TADM63A1'
call writeAblf Loes, ffLockE, pre'.TADM64A1'
call writeAblf ReEot, ffEOT, pre'.TADM65A1'
return 0
endProcedure writeAblfAll
/*______________________________________________________________________
¨¨
¨¨new dsn write
¨¨______________________________________________________________________
*/
writeAblf: procedure expose m.
parse arg st, ff, dsn
do sx=1 to m.st.0
o.sx = csv4obj(st'.'sx, ff, 0)
end
dsn=dsn'.D'date('j')'.T'translate(124578, time(), 12345678)
call writeDsn dsn '::v300', 'O.', m.st.0, 1
return
endProcedure writeAblf
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz m.ii_rz2c.rz m.ii_rz2plex.rz sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db m.ii_db2c.db mbr i
m.ii_mbr2db.mbr = db
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse upper arg nm
return iiLazy(ii_ds, nm, 'ds')
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2P: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2plex, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiLazy
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')'\n'
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')', ggRet
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/ 6
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXDB2LOQ) cre=2015-10-07 mod=2015-10-07-08.04.09 A540769 ---
/* REXX
¨¨____________________________________________________________________
¨¨
¨¨ EXDB2LOG
¨¨ --------
¨¨ read mastlog output and insert the messages into tadm6* tables
¨¨
¨¨ PARMS EXDB2LOG <PARM1>
¨¨ PARM1 = DB2 SUBSYSTEM
¨¨
¨¨ LOCATION DSN.DB2.EXEC ab 4.0
¨¨ TSO.rz?.P0.USER.EXEC bis 3.1
¨¨
¨¨ HISTORY:
¨¨ 2.10.2015 V4.1 for timeout also use DSNT500I and store
¨¨ these even without deadlock/timeout
¨¨ 20.10.2014 V4.0 logE2 => logEx
¨¨ 06.10.2014 V4.0 direkt aus Beta/eJes Extract DSNs lesen
¨¨ member/Datum aus IAT6140 usw.
¨¨ keine doppelte Ausgabe von Beta/eJes Logs
¨¨ 09.04.2014 V3.1 Ergebnis zusätzlich ins DSN
¨¨ 24.09.2012 V3.0 rewrite masterlog
¨¨ 18.04.2012 V2.2 rz8 und rzz integriert
¨¨ 17.04.2012 V2.1 truncate collids longer 18
¨¨ 28.03.2008 V2.0 ABNORMAL EOT (G.KERN,A914227)
¨¨ 27.03.2008 V1.1 UNCOMMITED UOW (G.KERN,A914227)
¨¨ 27.03.2008 V1.2 CHECKPOINTS (G.KERN,A914227)
¨¨ 27.03.2008 V1.3 LOCK ESCALATION (G.KERN,A914227)
¨¨ 30.01.2008 V1.0 GRUNDVERSION (G.KERN,A914227)
¨¨
¨¨_____________________________________________________________________
*/
m.debug = 0
m.tstRZ4 = 1
m.insertLocal = 1
m.writeABLF = 1
m.wkTest = 0
m.acTest = 0
call errReset 'h'
PARSE UPPER arg SSID rest
say "exDb2Log("ssid rest") version v4.1 vom 2.10.15"
if ssid == 1 then
return doFun1()
else if ssid == 2 then
return doFun2(rest)
else if ssid == 3 then
return doFun3()
else if 0 then
return workOld(ssid)
else do
o.1 = date('s') time() sysVar(sysNode) mvsvar('symdef', 'jobname') ,
'exDb2Log workOld deActivated'
call writeDsn 'mod dsn.ablf.logDeImp ::f', o., 1
say 'exDb2Log workOld deActivated'
return 0
end
endMainCode
/*-------------- alte Verarbeitung -----------------------------------*/
workOld:
parse arg ssid
call ini 0
/*_____________________________________________________________________
¨¨
¨¨ VARIABLEN INITIALISIEREN
¨¨_____________________________________________________________________
*/
m.tadmDbSy = ''
m.lastDeadlock = ''
m.lastTimeout = ''
m.tadmCreator = ''
/*_____________________________________________________________________
¨¨
¨¨ HAUPTPROGRAMM
¨¨_____________________________________________________________________
*/
SAY "DB2 SUBSYSTEM = "SSID
CALL OWNER_SSID_ZUWEISEN ssid /* ZUWEISEN OWNER & SSID FÜR SQL */
CALL sqlConnect ssid /* DB2 SUBSYSTEM VERBINDEN */
CALL readMstrLog /* INPUT-DS lesen und analysieren */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
if m.insertLocal then do
CALL sqlConnect m.tadmDbSy /* DB2 SUBSYSTEM VERBINDEN */
CALL GET_MAX_WERT_TIMEOUT /* MAX TIMEOUT vON TABELLE LESEN */
CALL GET_MAX_WERT_DEADLOCK /* MAX DEADLOCK VON TABELLE LESEN */
CALL GET_MAX_WERT_uncommittedUOW /* MAX uncommittedUOW */
CALL GET_MAX_WERT_CHECKPNT /* MAX CHECKPNT VON TABELLE Lesen */
CALL GET_MAX_WERT_LOCKESCA /* MAX LOCKESCA VON TABELLE Lesen */
CALL GET_MAX_WERT_EOT /* MAX EOT EINTRAG VON TABELLE LESEN */
CALL INSERT_TADM60A1 /* deadlocks und timeouts */
CALL INSERT_TADM63A1 /* uncommitted UOW */
CALL INSERT_TADM64A1 /* LOCK ESCALATION */
CALL INSERT_TADM65A1 /* abnormal eot */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
end
if m.writeABLF then /* write dsn für ABLF */
/* call writeAblfAll 'DSN.ABLF.LOGEX.'ssid */
call writeAblfAll 'A540769.LOGEX.ABLF.'ssid
return 0
endSubroutine workOld
/*--- write timestamp to dd parmNew ----------------------------------*/
doFun1: procedure expose m.
parse arg betaExt .
call ini 1
call readDD parmOld, i., '*'
call tsoClose parmOld
ix = i.0
say 'parmOld' ix strip(i.ix, 't')
w1 = word(i.ix, 1)
if i.0 = 0 then
old = '2014-01-01-00.00.00'
else if translate(w1, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad to tst in parmOld 1:' i.ix
else if substr(w1, 15, 2) >= 15 then
old = overlay(right(substr(w1, 15, 2)-15, 2,0), w1, 15)
else if substr(w1, 12, 2) >= 1 then
old = overlay(right(substr(w1, 12, 2)-1, 2,0) ,
|| '.'right(substr(w1, 15, 2)+45, 2,0), w1, 12)
else
old = left(w1, 11)'00.00.00'
new = translate('1234-56-78', date('s'), '12345678') ,
|| '-'translate(time(), '.', ':')
if new <= old then
call err 'new' new '<=' old 'old'
o.1 = new old
call writeDD parmNew, o., 1
call tsoClose parmNew
say 'parmNew' strip(o.1, 't')
if substr(old, 6, 2) > 2 then
betaS = overlay(right(substr(old, 6, 2)-2, 2,0), old, 6)
else
betaS = overlay(left(old, 4)-1,
|| '-'right(substr(old, 6, 2)+10, 2,0), old, 1)
if substr(betaS, 9, 2) > 28 then
betaS = overlay(28, betaS, 9)
betaS = translate('78.56.1234', left(betaS, 10), '1234-56-78')
say 'betaStart' betaS 'betaExt' betaExt
o.1 = 'REPORT'
o.2 = ' SDATE('betaS')'
o.3 = ' STIME(00:00:00)'
o.4 = ' PDATE(TODAY)'
o.5 = ' PTIME(23:59:59)'
o.6 = ' JOBNAME(D***MSTR)'
call writeDD betaRePa, o., 6
call tsoClose betaRePa
a.1 = ' 00:00:00 ' /* idiotisches Rexx stuerzt ab auf leerem
konatiniertem Dataset | */
call writeDD 'betaExt', a., 1
call tsoClose 'betaExt'
call writeDD 'eJesExt', a., 1
call tsoClose 'eJesExt'
say 'written idiotic dummy row on betaExt and eJesExt'
call eJesJobExtDD 'D%%%MSTR', 'JESMSGLG'
return 0
endProcedure doFun1
/*--- select jobs from betaRep ---------------------------------------*/
doFun2: procedure expose m.
parse arg betaExt .
call ini 1
say 'fun2' betaExt
call parmNewRead
new = m.parm_new
old = m.parm_old
call readDD betaRep, b., '*'
call tsoClose betaRep
say 'dd betaRep' b.0 'lines'
do bx=1 to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' then do
bx = bx + 1
if substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' then
leave
end
if pos('NO JOBS MATCHED SELECTION', b.bx) > 0 then do
say 'no jobs in Beta report:' b.bx
return 4
end
end
if bx > b.0 then
call err 'no title found in betaRep'
say b.bx
cJ = 2
cI = 11
cE = pos(' END DATE ', b.bx)
eE = cE + 10
cF = pos(' END TIME ', b.bx) + 1
eF = cF+8
m.o.0 = 0
if cE < 20 | cF < 20 then
call err 'bad end time/date in beta title' b.bx
cS = pos(' SUB DATE ', b.bx)
eS = cS + 10
cT = pos(' SUB TIME ', b.bx) + 1
eT = cT+8
m.o.0 = 0
m.f.0 = 0
if cS < 20 | cT < 20 then
call err 'bad end time/date in beta title' b.bx
jx = 0
jy = 0
do bx=bx to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' ,
| abbrev(substr(b.bx, 2), '-----') ,
| abbrev(substr(b.bx, 2), '=====') ,
| substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' ,
| abbrev(substr(b.bx, 2), 'PROGRAM B92BFJBR ') then
iterate
if pos(' JOB(S) MATCHED SELECTI', b.bx) > 0 then do
jz = word(substr(b.bx, 2), 1)
iterate
end
say b.bx
parse var b.bx 2 vJ 10 11 vI 19 ,
=(cS) vS =(eS) =(cT) vT =(eT) ,
=(cE) vE =(eE) =(cF) vF =(eF)
if translate(vE, '999999999', '012345678') \== '99.99.9999' then
call err 'bad end date' vE 'in line' bx':' b.bx
if translate(vF, '999999999', '012345678') \= '99:99:99' then
call err 'bad end time' vF 'in line' bx':' b.bx
vG = translate('1234-56-78', vE, '78.56.1234') ,
|| '-'translate(vF, '.', ':')
jx = jx + 1
if vG << old then
iterate
jy = jy + 1
say ' selected' vJ vI', ended' vG '>>=' old 'old'
call mAdd f, 'BFIND' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' OPERATOR(OR)' ,
, ' OPTIONS(FIRST)' ,
, ' SCOPE(BOTH)' ,
, ' MESSAGE(LONG)' ,
, ' RELOAD(YES)' ,
, ' MIXEDMODE(NO)' ,
, ' SLINE(0)' ,
, ' PLINE(0)' ,
, ' STRING1(DATE)'
call mAdd o, 'PRINT' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' MASK(MM/DD/YY)' ,
, ' AUTOSEL(NO)' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' MESSAGE(LONG)' ,
, ' SCOPE(BOTH)' ,
, ' DISPOSITION(MOD)' ,
, ' DATASET('betaExt')'
end
if jx <> jz then
call err jx 'jobs read not' jz 'as beta says'
say jy 'jobs selected from' jz 'in list'
call writeDD betaExPa, 'M.O.'
call tsoClose betaExPa
call writeDD betaFiPa, 'M.F.'
call tsoClose betaFiPa
return 4 * (jy = 0)
endProcedure doFun2
/*--- read concatenated master logs and write load files -------------*/
doFun3: procedure expose m.
call ini 1
call parmNewRead
call readMstrLog
call writeAblfAll 'A540769.LOGEX.ABLF'
/* call writeAblfAll 'DSN.ABLF.LOGEX.'sysvar(sysnode) */
return 0
endProcedure doFun3
/*--- read parmNew, extract new and old timestamp --------------------*/
parmNewRead: procedure expose m.
call readDD parmNew, n., '*'
call tsoClose parmNew
parse var n.1 new old .
say 'parmNew' new old
if n.0 < 1 then
call err 'empty parmNew'
else if translate(new, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad new in parmNew:' new
else if translate(old, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad old in parmNew:' old
else if new <= old then
call err 'new <= old' new old
m.parm_new = new
m.parm_old = old
return
endProcedure parmNewRead
/*_____________________________________________________________________
¨¨
¨¨ OWNER UND SSID FÜR SQL ABFRAGE ZUWEISEN
¨¨_____________________________________________________________________
*/
OWNER_SSID_ZUWEISEN: procedure expose m.
parse arg ssid
IF m.debug THEN SAY "ENTER PROCEDURE OWNER_SSID_ZUWEISEN..." ssid
SELECT
WHEN SSID = 'DBTF' THEN info = 'DTF OA1T DBTF'
WHEN SSID = 'DBOC' THEN info = 'DOC OA1T DBTF'
WHEN SSID = 'DVTB' THEN info = 'DTB OA1T DBTF'
WHEN SSID = 'DP2G' THEN info = 'DP2 OA1P DP2G' /* rz2 */
WHEN SSID = 'DBOF' THEN info = 'DOF OA1P DP2G'
WHEN SSID = 'DVBP' THEN info = 'DBP OA1P DP2G'
WHEN SSID = 'DC0G' THEN info = 'DC0 OA1P DC0G' /* rz8 */
WHEN SSID = 'DCVG' THEN info = 'DCV OA1P DCVG'
WHEN SSID = 'DD0G' THEN info = 'DD0 OA1P DD0G'
WHEN SSID = 'DDVG' THEN info = 'DDV OA1P DDVG'
WHEN SSID = 'DX0G' THEN info = 'DX0 OA1P DX0G'
WHEN SSID = 'DP8G' THEN info = 'DP8 OA1P DP8G'
WHEN SSID = 'DE0G' THEN info = 'DE0 OA1P DE0G' /* rzz */
WHEN SSID = 'DEVG' THEN info = 'DEV OA1P DEVG'
OTHERWISE call err "bad ssid = '"ssid"'"
END
parse var info m.db2Member3 m.tadmCreator m.tadmDbSy .
if m.wkTest then do
m.tadmCreator = A540769
m.tadmDbSy = 'DBAF'
if ssid = 'DVBP' then ssid = 'DBTF'
say '?????? wktest run' m.tadmDbSy
end
if m.acTest then do
m.tadmCreator = A754048
m.tadmDbSy = 'DE0G'
if ssid = '' then ssid = 'DE0G'
say '?????? actest run' m.tadmDbSy
end
say ' ssid' ssid 'member' m.db2Member3'?',
'to' m.tadmDbSy':'m.tadmCreator'.TADM6*A1'
IF m.debug THEN SAY "LEAVE PROCEDURE OWNER_SSID_ZUWEISEN..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX TIMEOUT WERT VON TADM60A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_TIMEOUT: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_TIMEOUT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'T' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C3 CURSOR FOR S3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S3 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C3 INTO :m.lastTimeout :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX TIMEOUT TIMESTAMP FOR" SSID "IS:" m.lastTimeout
ADDRESS DSNREXX "EXECSQL CLOSE C3"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_TIMEOUT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX DEADLOCK WERT VON TADM60A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_DEADLOCK: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_DEADLOCK..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'D' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C2 CURSOR FOR S2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S2 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C2 INTO :m.lastDeadlock :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX DEADLOCK TIMESTAMP FOR" SSID "IS:" m.lastDeadlock
ADDRESS DSNREXX "EXECSQL CLOSE C2"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_DEADLOCK..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX uncommittedUOW WERT VON TADM63A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_uncommittedUOW:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_uncommittedUOW..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'U' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C7 CURSOR FOR S7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S7 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C7 INTO :m.lastUOW :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX UNCOMMITTED UOW TIMESTAMP FOR" SSID "IS:" m.lastUOW
ADDRESS DSNREXX "EXECSQL CLOSE C7"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_uncommittedUOW..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX CHECKPNT WERT VON TADM63A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_CHECKPNT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_CHECKPNT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'C' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C9 CURSOR FOR S9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S9 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C9 INTO :m.lastCheckp :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX CHECKPOINT TIMESTAMP FOR" SSID "IS:" m.lastCheckp
ADDRESS DSNREXX "EXECSQL CLOSE C9"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_CHECKPNT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX LOCKESCA WERT VON TADM64A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_LOCKESCA:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_LOCKESCA..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM64A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'E' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C10 CURSOR FOR S10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S10 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C10 INTO :m.lastLockesc :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX LOCK ESCALATION TIMESTAMP FOR" SSID "IS:" m.lastLockesc
ADDRESS DSNREXX "EXECSQL CLOSE C10"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_LOCKESCA..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX EOT WERT VON TADM65A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_EOT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_EOT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM65A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'A' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C12 CURSOR FOR S12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S12 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C12 INTO :m.lastReadEot :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX ABNORMAL EOT TIMESTAMP FOR" SSID "IS:" m.lastReadEot
ADDRESS DSNREXX "EXECSQL CLOSE C12"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_EOT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ read the whole master log
¨¨ and analyse each interesting msg
¨¨_____________________________________________________________________
*/
readMstrLog:
call logMsgBegin rd
lx = 0
bx = 0
do forever
li = readNx(rd)
if li = '' then do
say lx 'lines' bx 'bytes' readNxPos(rd)
call readNxEnd rd
exit
end
lx = lx + 1
bx = bx + length(m.li)
end
m.to.0 = 0
m.uow.0 = 0
m.LoEs.0 = 0
m.ReEot.0 = 0
do mx=1
mid = logMsg(rd)
/* say mx mid m.rd.cc.0 readNxPos(rd) ????? */
if mid == '' then do
if m.info.jobKey \== '' then
call sayJobEnd info
say 'readMstrLog end:' readNxPos(rd)
call readNxEnd rd
return
end
else if m.info.tst <<= m.info.doneUntil then
nop /* already done yesterday or eJes <-> beta92 */
else if mid == 'DSNT375I' then
call anaTimeoutDeadlock rd, info, 'D'
else if mid == 'DSNT376I' then
call anaTimeoutDeadlock rd, info, 'T'
else if mid == 'DSNT500I' | mid == 'DSNT501I' then
call anaResourceNotAvailable rd, info, mid
else if mid == 'DSNJ031I' then
call anaUncommittedUOW rd, info, 'U'
else if mid == 'DSNR035I' then
call anaUncommittedUOW rd, info, 'C'
else if mid == 'DSNI031I' then
call anaLockEscalation rd, info, 'E'
else if mid == 'DSN3201I' then
call anaReadEot rd, info, 'A'
end
endProcedure readMstrLog
/*_____________________________________________________________________
¨¨
¨¨ if this is not a dsn message return ''
¨¨ otherwise, check it, collect infos into info and return id
¨¨_____________________________________________________________________
*/
logMsgBegin: procedure expose m.
parse arg rd
call readNxBegin rd, '-', 'DDIN1'
do until m.li <> ' 00:00:00' & m.li <> ''
li = readNx(rd)
end
m.info.doneUntil = m.parm_old
m.info.head = left('? ^ # no no', 300, '}')
m.info.jobKey = ''
m.mOld = ''
m.rd.curIsMsg = 1
m.cLogMsg = 0
m.cCont = 0
m.cContCx = 0
return
endProcedure logMsgBegin
logMsg: procedure expose m.
parse arg rd
m.cLogMsg = m.cLogMsg+1
li = readNxCur(rd)
if li == '' then
return ''
line = m.li
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
return logMstr(rd, line)
end
else if substr(strip(line), 1, 39) ,
== 'J E S 2 J O B L O G -- S Y S T E M ' then do
m.rd.jes2 = 1
m.info.j2Id = ''
return logMstr(rd, line)
end
if m.rd.jes2 then do
if translate(substr(line, 1, 9), '999999999', '012345678') ,
\== '99.99.99 ' then do
if line = '------ JES2 JOB STATISTICS ------' then do
m.info.mid = '----stat'
do cx=1 until li == '' | substr(m.li, 13, 1) = ' ' ,
| substr(m.li, 14, 1) <> ' ' ,
| substr(m.li, 15, 1) = ' '
m.rd.cc.cx = m.li
li = readNx(rd)
end
m.rd.cc.0 = cx
return m.info.mid
end
else
call err 'bad time in jes2 line' readNxPos(rd)
end
m.info.time = word(line, 1)
w2 = word(line, 2)
if w2 \== m.info.j2Id then do
if m.info.j2Id \== '' then
call err 'jes2 id mismach' m.info.j2Id ,
'<>' readNxPos(rd)
else if length(w2) <> 8 then
call err 'bad jes2 id' w2 'in' readNxPos(rd)
else
m.info.j2Id = w2
end
if substr(line, 18, 1) \== ' ' then
call err 'bad jes2 line' readNxPos(rd)
else if substr(line, 18, 6) == ' ---- ' then do
if word(line, 8) \== '----' then
call err 'bad jes2 ---- line' readNxPos(r)
call anaCurDate info, subword(substr(line, 24), 2, 3)
m.info.mid = '----date'
end
else do
m.info.mid = word(line, 3)
end
m.info.tst = m.info.date'-'m.info.time
call logMsgContJes2 rd, line
return m.info.mid
end
else do
if translate(substr(line, 1, 10), '999999999', '012345678') ,
\== ' 99:99:99 ' then
call err 'bad time in jes3 line' readNxPos(rd)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if substr(line, 10, 14) == ' ---- IAT6853 ' then do
if substr(line, 24, 20) \== 'THE CURRENT DATE IS ' then
call err 'bad IAT6853' readNxPos(rd)
call anaCurDate info, subword(substr(line, 44), 2, 3)
m.info.mid = 'IAT6853'
end
else do
m.info.mid = word(line, 2)
end
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
call logMsgContJes3 rd, line
return m.info.mid
end
endProcedure logMsg
logMsgContJes2: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
if translate(right(line, 5), 000000000,123456789)== ' 000' then do
mSeq = right(line, 3)
aSeq = left(' 'mSeq, 19)
m.mOld = mSeq subWord(m.mOld, 1, 49)
m.rd.cc.1 = substr(line, 19, length(line)-23)
end
else do
mSeq = ''
aSeq = left('', 19 ,'?')
m.rd.cc.1 = substr(line, 19)
end
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
/* else if left(m.li, 19) = ' 'mSeq then do */
else if abbrev(m.li, aSeq) then do
cx = cx + 1
m.rd.cc.cx = substr(m.li, 19)
end
else if translate(left(m.li, 19), 000000000, 123456789) ,
= ' 000' then do
/* ???? ix = wordPos(substr(m.li, 4, 3), m.mOld)
if symbol('m.igno.ix') == 'VAR' then
m.igno.ix = m.igno.ix + 1
else
m.igno.ix = 1
if ix < 1 then
say 'ignoring after' m.info.mid'#'mSeq readNxPos(rd)
*/ end
else
leave
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes2
logMsgContJes3: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
m.rd.cc.1 = substr(line, 10)
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
if \ abbrev(m.li, m.info.head) then do
if translate(substr(m.li, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then
leave
if translate(substr(m.info.head 2, 9) ,
, '999999999', '012345678') \== '99:99:99 ' then
leave
ds =((( substr(m.li, 2, 2) * 60) ,
+ substr(m.li, 5, 2) * 60) ,
+ substr(m.li, 8, 2)) ,
-((( substr(m.info.head, 2, 2) * 60) ,
+ substr(m.info.head, 5, 2) * 60) ,
+ substr(m.info.head, 8, 2))
if ds < 0 | ds > 3 then
leave
end
if substr(m.li, 10, 14) == ' ---- IAT6853 ' then
leave
vx = verify(m.li, ' ', 'N', 10)
if vx = 11 | vx = 12 then do
w2 = word(m.li, 2)
if (length(w2) == 7 | length(w2) == 8) ,
& verify(w2, m.ut_alfUCNum) = 0 then
if wordPos(left(w2, 3), 'IAT ACF DSN IEF IXL') > 0 then
leave
end
cx = cx + 1
m.rd.cc.cx = substr(m.li, 10)
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes3
/* ???????????????????????????????
logMsgCont: procedure expose m.
parse arg rd
if \ m.rd.jes2 then do
if m.rd.isMsgStart then do
m.rd.isMsgStart = 0
li = readNxCur(rd)
return substr(m.li, 12)
end
li = readNx(rd)
if li == '' then
return ''
else do
call err 'implement'
end
endProcedure logMsgCont
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
if translate(substr(line, 1, 10), '999999999', '012345678') ,
\== ' 99:99:99 ' then
return ''
if m.rd.curIsMsg then
li = readNx(rd)
else
li = readNxCur(rd)
do while li <> ''
line = m.li
if substr(line, 2, 18) \== 'IAT6140 JOB ORIGIN' then
??????????? */
finishJob: procedure expose m.
parse arg rd
if m.info.jobKey == '' then
return
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
if m.rd.jes2 then
j = 'jes2'
else
j = 'jes2'
say j m.info.job jKy 'to' m.info.tst p
ii = ''
/* do ix=0 to 99
if symbol('m.igno.ix') == 'VAR' then
ii = ii ix'='m.igno.ix
end
say ii */
say 'logMsg='m.cLogMsg 'cont='m.cCont 'contCx='m.cContCx
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' | jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
return
endProcedure finishJob
logMstr: procedure expose m.
parse arg rd, line
call finishJob rd
m.info.dateTst = ''
do until m.li <> ''
li = readNx(rd)
end
do lx=1 to 50
mid = logMsg(rd)
if mid = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if mid == 'IEF403I' then do
j1 = word(m.rd.cc.1, 2)
s1 = word(m.rd.cc.1, words(m.rd.cc.1))
end
else if mid == 'DSNY024I'then do
m2 = substr(word(m.rd.cc.1, 2), 2)
leave
end
else if abbrev(mid, 'DSN') then do
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return mid
isDsnMsg: procedure expose m.
parse arg line, info
if m.modeNew? then do
if translate(substr(line, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then do
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
call err 'bad line' line
s1 = ''
m2 = ''
if m.info.jobKey \== '' then do
call sayJobEnd info
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' ,
| jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
end
m.info.dateTst = ''
do lx=1 to 50
ln = readNx(rd)
if ln = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if translate(substr(m.ln, 2, 9), '999999999',
, '012345678') \== '99:99:99 ' then do
say 'bad start of mstrLog after' line
say ' @' readNxPos(rd)
return isDsnMsg(m.ln, info)
end
if word(m.ln, 2) == 'IEF403I' then do
j1 = word(m.ln, 3)
s1 = word(m.ln, words(m.ln))
end
else do
d2 = isDsnMsg(m.ln, info)
if d2 = 'DSNY024I' then do
m2 = substr(word(m.ln, 3), 2)
leave
end
else if d2 \== '' then
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return ''
end
mid = word(line, 2)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
return ''
end
end
else do
mid = word(line, 4)
parse var line m.info.dbMb m.info.date m.info.time .
m.info.dbSys = iiMbr2DbSys(m.info.dbMb)
if \ abbrev(mid, 'DSN') | wordIndex(line, 4) <> 29 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 5) = 'IAT6853' then
call anaCurDate info, substr(line,18), word(line,2)
m.info.wxTime = 3
m.info.cxTime = 19
return ''
end
m.info.head = left(line,27)
end
/* diese Prüfung ist falsch, manche displays zeigen --------------
Infos aus anderen membern an, z.B. -dis indoubt ......
aMbr = word(line, 5)
if abbrev(aMbr, '-') then
if '-'m.info.dbMb \== aMbr then
call err 'dbMember mismatch:' m.info.dbMb ,
'<>' readNxPos(rd) -----------------------------*/
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
return mid
endProcedure isDsnMsg
sayJobEnd: procedure expose m.
parse arg info
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
say 'job' m.info.job jKy 'to' m.info.tst p
return
endProcedure say JobEnd
/*_____________________________________________________________________
¨¨
¨¨ analyse current date in iat6853 message
¨¨ and check that it equals the header
¨¨_____________________________________________________________________
*/
anaCurDate: procedure expose m.
parse arg info, d1, compD
d2 = word(d1, 1) ,
translate(left(word(d1, 2), 1)),
|| translate(substr(word(d1, 2), 2),
, m.ut_AlfLC, m.ut_AlfUC) ,
word(d1, 3)
do while abbrev(d2, 0) /* date does not accept leading zeroes ||||| */
d2 = substr(d2, 2)
end
d3 = date('s', d2)
m.info.date = translate('1234-56-78', d3, '12345678')
m.info.dateTst = m.info.date'-'translate(m.info.time,'.',':')
if compD \== '' then
if m.info.date <> compD then
call err 'date mismatch' compD '<>' d3 readNxPos(rd)
return
endProcedure anaCurDate
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSN3201I event type A - ABNORMAL EOT AUS INPUT-DS LESEN
¨¨____________________________________________________________________
*/
anaReadEot: procedure expose m.
parse arg rd, info, pEvTy
m.ReEot.0 = m.ReEot.0 +1
ux = 'REEOT.'m.ReEot.0 /*zähler */
m.ux.A = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.corr = ''
m.ux.Jobname = ''
m.ux.conn = ''
m.ux.AuthID = '' /* AuthID = User column in db2 Table */
m.ux.AsID = ''
m.ux.tcb = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
jx = pos(' JOBNAME=', m.rd.cc.lx)
if cx > 0 then do
if jx < cx then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16)))
else
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16,
, jx-cx-16)))
end
if jx > 0 then
m.ux.Jobname = cut18(word(strip(substr(m.rd.cc.lx,jx+9)),1))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then do
m.ux.conn = cut18(word(substr(m.rd.cc.lx,cx+15), 1))
end
cx = pos(' USER=', m.rd.cc.lx)
if cx > 0 then do
m.ux.AuthID = word(substr(m.rd.cc.lx,cx+6), 1)
end
cx = pos(' ASID=', m.rd.cc.lx)
if cx > 0 then
m.ux.AsID = word(substr(m.rd.cc.lx,cx+6), 1)
cx = pos(' TCB=', m.rd.cc.lx)
if cx > 0 then
m.ux.tcb = strip(substr(m.rd.cc.lx,cx+5))
/* if m.ux.tcb <> '' then
leave ????? */
end
return
endProcedure anaReadEot
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSNI031I event type E - LOCK ESCALATION
¨¨____________________________________________________________________
*/
anaLockEscalation: procedure expose m.
parse arg rd, info, pEvTy
m.LoEs.0 = m.LoEs.0 +1
ux = 'LOES.'m.LoEs.0 /*zähler */
m.ux.E = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.plan = ''
m.ux.package = ''
m.ux.CollID = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.resource = ''
m.ux.LckSt = ''
m.ux.Statement = ''
do lx=1 to m.rd.cc.0
cx = pos(' RESOURCE NAME = ', m.rd.cc.lx)
if cx > 0 then
m.ux.resource = strip(word(m.rd.cc.lx, 4))
cx = pos(' LOCK STATE = ', m.rd.cc.lx)
if cx > 0 then
m.ux.LckSt = strip(word(m.rd.cc.lx, 4))
cx = pos(' PLAN NAME : PACKAGE NAME = ',m.rd.cc.lx)
if cx > 0 then do
PlanPack = substr(m.rd.cc.lx,cx+28)
cx = pos(':',planpack)
m.ux.plan = strip(left(planPack, cx-1))
m.ux.package = cut18(strip(substr(planPack,cx+1)))
end
cx = pos(' COLLECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.CollID = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' STATEMENT NUMBER = ', m.rd.cc.lx)
if cx > 0 then
m.ux.Statement= strip(substr(m.rd.cc.lx,cx+20))
cx = pos(' CORRELATION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+18)))
cx = pos(' CONNECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
/* if m.ux.conn <> '' then
leave ???????? */
end
return
endProcedure anaLockEscalation
sayObj: procedure expose m.
parse arg ff, o
say o':' cl
do fx=1 to m.ff.0
f1 = m.ff.fx
say left(f1, 20) m.o.f1
end
return
endProcedure sayObj
/*____________________________________________________________________
¨¨
¨¨ analye uncommit UOW msg: DSNJ031I / event type U and C
¨¨____________________________________________________________________
*/
anaUncommittedUOW: procedure expose m.
parse arg rd, info, pEvTy
m.uow.0 = m.uow.0 +1
ux = 'UOW.'m.uow.0 /* zähler */
m.ux.UC = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.logRecs = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.plan = ''
m.ux.authid = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CHECKPOINTS -', m.rd.cc.lx) /* for checkP */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 2))
cx = pos(' LOG RECORDS -', m.rd.cc.lx) /* for UOW */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 3))
cx = pos(' CORRELATION NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(word(substr(m.rd.cc.lx,cx+19),1))
cx = pos(' CONNECTION ID =', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' PLAN NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.plan = strip(substr(m.rd.cc.lx,cx+13))
cx = pos(' AUTHID =', m.rd.cc.lx)
if cx > 0 then
m.ux.authid = strip(substr(m.rd.cc.lx,cx+9))
/* if m.ux.authid <> '' then
leave ???????????? */
end
return
endProcedure anaUncommittedUOW
/*____________________________________________________________________
¨¨
¨¨ analye timeout, deadlock msg: DSNT375I, DSNT376I
¨¨____________________________________________________________________
*/
anaTimeoutDeadlock: procedure expose m.
parse arg rd, info, pEvTy
totx = newTimeout(info, pEvTy)
vs = 'V'
do lx=1 to m.rd.cc.0
if pos(' ONE HOLDER ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'T' then
call err 'holder for evTy' pEvTy':'m.rd.cc.lx ,
readNxPos(r)
else if vs <> 'V' then
call err 'several holders:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
if pos(' IS DEADLOCKED ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'D' then
call err 'is deadLocked for evTy' ,
pEvTy':'m.rd.cc.lx readNxPos(r)
else if vs <> 'V' then
call err 'several is deadLocked:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
cx = pos(' PLAN=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.plan = word(substr(m.rd.cc.lx, cx+6,8), 1)
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.corr = cut18(strip(substr(m.rd.cc.lx, cx+16)))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.conn = cut18(strip(substr(m.rd.cc.lx, cx+15)))
cx = pos(' ON MEMBER ', m.rd.cc.lx)
if cx > 0 then do
if vs <> 'H' then
call err 'on member in vs' vs':'m.rd.cc.lx readNxPos(rd)
else
m.toTx.vs.dbMb = word(substr(m.rd.cc.lx, cx+11, 8), 1)
end
end
return
endProcedure anaTimeOut
/*____________________________________________________________________
¨¨
¨¨ make and initialise a new timeout/deadlock row
¨¨____________________________________________________________________
*/
newTimeout: procedure expose m.
parse arg info, pEvTy
m.to.0 = m.to.0 + 1
toTx = 'TO.'m.to.0
call clearFlds totx, ffTimeO
m.toTx.tst = m.info.tst
m.toTx.evTy = pEvTy
m.toTx.v.dbMb = m.info.dbMb
m.toTx.dbSys = m.info.dbSys
return toTx
endProcedure newTimeout
/*____________________________________________________________________
¨¨
¨¨ analyse resourceNotAvailable msg DSNT501I and DSNT500I
¨¨____________________________________________________________________
*/
anaResourceNotAvailable: procedure expose m.
parse arg rd, info, mid
tCor = ''
tCon = ''
tRea = ''
tTyp = ''
tNam = ''
do lx = 1 to m.rd.cc.0 /* loop line of dsnt501i */
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
tCor = word(substr(m.rd.cc.lx,cx+16),1)
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
tCon = strip(substr(m.rd.cc.lx,cx+15))
cx = pos(' REASON ', m.rd.cc.lx)
if cx > 0 then
tRea = word(substr(m.rd.cc.lx,cx+8,20),1)
cx = pos(' TYPE ', m.rd.cc.lx)
if cx > 0 then
tTyp = word(substr(m.rd.cc.lx,cx+6,20),1)
cx = pos(' NAME ', m.rd.cc.lx)
if cx > 0 then
tNam = strip(substr(m.rd.cc.lx,cx+6))
end /* loop line of dsnt501i */
/* search preceeding timeOut/deadLock*/
if tCor = '' | tCon = '' then do
tx = m.to.0
if m.to.tx.name \== '' then
tx = -1
end
else do
mb = m.info.dbMb
tsN = m.info.tst
numeric digits 20
tsB = timeDays2Tst(timestamp2Days(tsN) - 30/86400)
numeric digits 9
do tx=m.to.0 to 1 by -1
if m.to.tx.v.dbMb <> mb ,
| m.to.tx.tst >> tsN | m.to.tx.tst << tsB then
tx = -1
else if m.to.tx.v.corr == tCor & m.to.tx.v.conn == tCon ,
& m.to.tx.name == '' then
leave
end
end
if tx > 0 then do
toTx = 'TO.'tx /* resource an timeout/deadlock anhängen */
end
else do /* new feature: store these also
evType depending on reason, but some have several */
if wordPos(tRea, '00C200FA 00C20031 00C900C0 00E70010') >0 then
toTx = newTimeout(info, 'T')
else
toTx = newTimeout(info, '')
m.toTx.v.corr = tCor
m.toTx.v.conn = tCon
end
m.toTx.type = tTyp
m.toTx.name = space(tNam, 1)
m.toTx.reason = tRea
if tTyp <> '' then
call resourceType info, toTx'.'type, toTx'.'name
return
endProcedure anaResourceNotAvailable
/*____________________________________________________________________
¨¨
¨¨ give the name of the resourcetype and dbid/obid
¨¨____________________________________________________________________
*/
resourceType: procedure expose m.
parse arg info, tp, nm
cd = m.tp
if symbol('m.resourceType.cd') <> 'VAR' then do
say '<'cd'>' c2x(cd)
say readNxPos(rd)
call err 'unknown resource type' cd
end
m.tp = m.resourceType.cd
parms = m.resourceTypeParms.cd
names = m.nm
if pos('DI.OI', parms) > 0 then do /* find dbid and obid */
px = 0
nx = 0
do until px = 0
py = pos('.', parms, px + 1)
ny = pos('.', names, nx + 1)
if (py=0) <> (ny=0) then
call err 'resource parms' parms 'mismatch name' names
if py = 0 then do
p1 = substr(parms, px+1)
n1 = substr(names, nx+1)
end
else do
p1 = substr(parms, px+1, py-px-1)
n1 = substr(names, nx+1, ny-nx-1)
end
n.p1 = n1
px = py
nx = ny
end
/* dbid und obid uebersetzen */
m.nm = strip(getDbidObid(m.info.dbSys, n.di, n.oi) names)
end
return cd
endProcedure resourceType
ini: procedure expose m.
parse arg m.modeNew
call resourceTypeIni
call sqlIni
call errAddCleanup "if m.sql_dbSys <> '' then do;" ,
"say 'rollback';call sqlExec Rollback; call sqlDisconnect; end"
if m.modeNew then
f1 = 'TST DBSYS'
else
f1 = 'TST'
call iniFlds ffTimeO, f1 'V.DBMB EVTY V.PLAN V.CORR V.CONN' ,
'H.PLAN H.CORR H.CONN' ,
'REASON TYPE NAME'
call iniFlds ffUow, f1 'DBMB UC PLAN CORR CONN AUTHID LOGRECS'
call iniFlds ffLockE, f1 'DBMB E PLAN PACKAGE COLLID' ,
'CORR CONN RESOURCE LCKST STATEMENT'
call iniFlds ffEOT, f1 'DBMB A CORR JOBNAME CONN AUTHID ASID TCB'
return
endProcedure ini
iniFlds: procedure expose m.
parse arg ff, flds
do fx=1 to words(flds)
m.ff.fx = word(flds, fx)
end
m.ff.0 = words(flds)
return
endProcedure iniFlds
clearFlds: procedure expose m.
parse arg o, ff
do fx=1 to m.ff.0
f1 = m.ff.fx
m.o.f1 = ''
end
return o
endProcedure clearlds
resourceTypeIni: procedure expose m.
/* the old definitions for backward compability */
call rtDef '00000100', 'DB'
call rtDef '00000200', 'TS'
call rtDef '00000201', 'IX-SPACE'
call rtDef '00000202', 'TS'
call rtDef '00000210', 'PARTITION'
call rtDef '00000220', 'DATASET'
call rtDef '00000230', 'TEMP FILE'
call rtDef '00000300', 'TEMP FILE'
call rtDef '00000300', 'PAGE'
call rtDef '00000301', 'IX-MINIPAGE'
call rtDef '00000302', 'TS-PAGE'
call rtDef '00000303', 'IX-PAGE'
call rtDef '00000304', 'TS-RID'
call rtDef '00000D01', 'DBID/OBID'
call rtDef '00000800', 'PLAN'
call rtDef '00000801', 'PACKAGE'
call rtDef '00002000', 'TS CS-CLAIM CLASS'
call rtDef '00002001', 'TS RR-CLAIM CLASS'
call rtDef '00002002', 'TS WRITE-CLAIM CLASS'
call rtDef '00002003', 'IX CS-CLAIM CLASS'
call rtDef '00002004', 'IX RR-CLAIM CLASS'
call rtDef '00002005', 'IX WRITE-CLAIM CLASS'
call rtDef '00002006', 'TS PART CS-CLAIM CLASS'
call rtDef '00002007', 'TS PART RR-CLAIM CLASS'
call rtDef '00002008', 'TS PART WRITE-CLAIM CLASS'
call rtDef '00002009', 'IX PART CS-CLAIM CLASS'
call rtDef '00002010', 'IX PART RR-CLAIM CLASS'
call rtDef '00002011', 'IX PART WRITE-CLAIM CLASS'
/* the complete Db2V10 resource type table */
call rtDef '00000100', 'Database', 'DB'
call rtDef '00000200', 'Table space', 'DB.SP'
call rtDef '00000201', 'Index space', 'DB.SP'
call rtDef '00000202', 'Table space RD.DB.TS'
call rtDef '00000205', 'Compression Dictionary', 'DB.SP'
call rtDef '00000210', 'Partition', 'DB.SP.PT'
call rtDef '00000220', 'Data set', 'DSN'
call rtDef '00000230', 'Temporary file', 'SZ'
call rtDef '00000240', 'Database procedure', 'DBP'
call rtDef '00000300', 'Page', 'DB.SP.PG'
call rtDef '00000301', 'Index minipage', 'DB.SP.PG.MP'
call rtDef '00000302', 'Table space page', 'DB.SP.PG'
call rtDef '00000303', 'Index space page', 'DB.SP.PG'
call rtDef '00000304', 'Table space RID', 'DB.SP.RID'
call rtDef '00000305', 'Index access/table space RID', 'DB.SP.RID'
call rtDef '00000306', 'Index access/table space page', 'DB.SP.PG'
call rtDef '00000307', 'Index space EOF', 'DB.SP.01'
call rtDef '00000400', 'ICF catalog', 'IC'
call rtDef '00000401', 'Authorization function'
call rtDef '00000402', 'Security Server',
, 'SAF/RACF return/reason codes'
call rtDef '00000500', 'Storage group', 'SG'
call rtDef '00000602', 'EDM DBD Space'
call rtDef '00000603', 'EDM DYNAMIC STATEMENT Space'
call rtDef '00000604', 'EDM skeleton storage'
call rtDef '00000605', 'EDM above-the-bar storage'
call rtDef '00000606', 'EDM below-the-bar storage'
call rtDef '00000700', 'Buffer pool space', 'BP'
call rtDef '00000701', 'Group buffer pool', 'GBP'
call rtDef '00000800', 'Plan', 'PL'
call rtDef '00000801', 'Package', 'COLLECTION.PACKAGE.CONTOKEN'
call rtDef '00000802', 'BINDLOCK01 through BINDLOCK20',
, 'BINDLOCK01 through BINDLOCK20'
call rtDef '00000900', '32KB data area'
call rtDef '00000901', 'Sort storage'
call rtDef '00000903', 'Hash anchor', 'DB.SP.PG.AI'
call rtDef '00000904', 'RIDLIST storage'
call rtDef '00000905', 'IRLM storage'
call rtDef '00000906', 'DB2', 'MEMBER'
call rtDef '00000907', 'LOB storage'
call rtDef '00000908', 'Basic Floating Point Extensions Facility'
call rtDef '00000909', 'Extended Time-of-Day (TOD) Clock'
call rtDef '0000090A', 'XML storage'
call rtDef '00000A00', 'Table', 'RD.CR.TB'
call rtDef '00000A10', 'Alias', 'RELDEP.OWNER.ALIAS.RD.CR.AL'
call rtDef '00000A11', 'Distinct type', 'SC.DT'
call rtDef '00000A12', 'User-defined function', 'SC.SN'
call rtDef '00000A13', 'Stored procedure', 'SC.SN'
call rtDef '00000A14', 'Sequence'
call rtDef '00000A16', 'Role'
call rtDef '00000A17', 'Trigger'
call rtDef '00000B00', 'View', 'RD.CR.VW'
call rtDef '00000C00', 'Index', 'RD.CR.IX'
call rtDef '00000C01', 'Index', 'CR.IX'
call rtDef '00000D00', 'DBID/OBID', 'RD.DI.OI'
call rtDef '00000D01', 'DBID/OBID', 'DI.OI'
call rtDef '00000D02', 'OBID', 'OI'
call rtDef '00000E00', 'SU limit exceeded', 'CN'
call rtDef '00000F00', 'Auxiliary column',
,'DI.OI.ROWID.COLN or DI.OI.DOCID.COLN'
call rtDef '00000F01', 'LOB lock', 'DIX.PIX.ROWID.VRSN'
call rtDef '00000F81', 'XML lock', 'DIX.PIX.DOCID'
call rtDef '00001000', 'DDF', 'LOCATION or SUBSYSTEM ID'
call rtDef '00001001', 'System conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001002', 'Agent conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001003', 'CNOS processing',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001004', 'CDB (Communication database)',
, 'LOCATION.AUTHORIZATIONID.PL'
call rtDef '00001005', 'DB access agent', 'LOCATION'
call rtDef '00001007', 'TCP/IP domain name', 'LINKNAME.DOMAIN.ERRNO'
call rtDef '00001008', 'TCP/IP service name', 'LOCATION.SERVICE.ERRNO'
call rtDef '00001080', 'ACCEL', 'SERVER.DOMAIN'
call rtDef '00001102', 'Bootstrap data set (BSDS)', 'MEMBER'
call rtDef '00002000', 'Table space CS-claim class', 'DB.SP'
call rtDef '00002001', 'Table space RR-claim class', 'DB.SP'
call rtDef '00002002', 'Table space write-claim class', 'DB.SP'
call rtDef '00002003', 'Index space CS-claim class', 'DB.SP'
call rtDef '00002004', 'Index space RR-claim class', 'DB.SP'
call rtDef '00002005', 'Index space write-claim class', 'DB.SP'
call rtDef '00002006', 'Table space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002007', 'Table space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002008', 'Table space partition write-claim class',
, 'DB.SP.PT'
call rtDef '00002009', 'Index space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002010', 'Index space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002011', 'Index space partition Write-claim class',
, 'DB.SP.PT'
call rtDef '00002100', 'Table space DBET entry', 'DB.SP'
call rtDef '00002101', 'Index space DBET entry', 'DB.SP'
call rtDef '00002102', 'Table space partition DBET entry', 'DB.SP.PT'
call rtDef '00002103', 'Index space partition DBET entry', 'DB.SP.PT'
call rtDef '00002104', 'DBET hash chain lock timeout',
, 'INTERNAL LOCK NN'
call rtDef '00002105', 'Logical partition DBET entry', 'DB.SP.PT'
call rtDef '00002200', 'Routine Parameter Storage', 'DBP'
call rtDef '00002201', 'm.debug Agent Storage', 'DBP'
call rtDef '00002300', 'ICSF encryption and decryption facilities'
call rtDef '00003000', 'Code (release maintenance_level or system' ,
'parameter)', 'REL,APAR,ZPARM'
call rtDef '00003002', 'Number of Stored Procedures'
call rtDef '00003072', 'Index'
call rtDef '00003073', 'Index'
call rtDef '00003328', 'Release dependency'
call rtDef '00003329', 'DBID/OBID', 'DI.OI'
call rtDef '00003330', 'OBID limit exceeded'
call rtDef '00003840', 'LOB column'
call rtDef '00004000', 'Profile exception threshold exceeded',
, 'PID.PTYPE.PNAME'
return
endProcedure resourceTypeIni
rtDef: procedure expose m.
parse arg cd, nm, pa
if symbol('m.resourceType.cd') <> 'VAR' then
m.resourceType.cd = nm
m.resourceTypeParms.cd = pa
return
endProcedure rtDef
getDbidObid: procedure expose m.
parse arg dbSys, dbid, obid
SQL_DBID = STRIP(dbid,L,0)
SQL_OBID = STRIP(obid,L,0)
if symbol('m.id2n.dbSys.dbidObid.dbid.obid') == 'VAR' then
/* haben es schon mal gefunden*/
return m.id2n.dbSys.dbidObid.dbid.obid
/* select from catalog */
/* from sysTables */
if dbSys \== m.sql_dbSys then do
if m.sql_dbSys \== '' then
call sqlDisconnect
if m.tstRZ4 then
if sysvar(sysNode) = 'RZ4' ,
& wordPos(dbSys, 'DP4G DBOL') < 1 then
return ''
call sqlConnect dbSys
end
res = sql2One("SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROm SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One("SELECT ",
" STRIP(DBNAME,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One( "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
m.dbidObid.dbid.obid = res
return m.dbidObid.dbid.obid
endProcedure getDbidObid
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM60A1
¨¨_________________________________________________________________________
*/
INSERT_TADM60A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM60A1..."
cIns = 0
cDead = 0
cTime = 0
say ' ' time() 'begin insert into tadm60a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM60A1 (" ,
"TIMESTAMP, ssid, event_type," ,
"VICTIM_PLAN, VICTIM_CORR_ID, VICTIM_COnn_ID," ,
"SOURCE_PLAN, SOURCE_CORR_ID, SOURCE_COnn_ID," ,
"REASON_CODE, type, name )" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
do tx=1 to m.to.0
/*______________________________________________________________________
row überspringen falls alt
*/
if (m.to.tx.evTy == 'D' & m.to.tx.tst <= m.lastDeadlock ) ,
|(m.to.tx.evTy == 'T' & m.to.tx.tst <= m.lastTimeout ) then
iterate
call sqlUpdArgs 7,
, m.to.tx.tst, m.to.tx.v.dbMb, m.to.tx.evTy,
, m.to.tx.v.plan, m.to.tx.v.corr, m.to.tx.v.conn,
, m.to.tx.h.plan, m.to.tx.h.corr, m.to.tx.h.conn,
, m.to.tx.reason, m.to.tx.type, m.to.tx.name
cIns = cIns + 1
cDead = cDead + (m.to.tx.evTy == 'D')
cTime = cTime + (m.to.tx.evTy == 'T')
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm60a1,' ,
cDead 'deadlocks and' cTime 'timeouts'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM60A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM63A1
¨¨_________________________________________________________________________
*/
INSERT_TADM63A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM63A1..."
say ' ' time() 'begin insert into tadm63a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM63A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"CORRID_ID," ,
"CONN_ID," ,
"AUTHID," ,
"LOGREC)" ,
"VALUES (?,?,?,?,?,?,?,?)"
cIns = 0
cUOW = 0
cCHK = 0
do tx=1 to m.uow.0
ux = 'UOW.'tx
if m.ux.UC == 'U' & m.ux.tst <= m.lastUOW then
iterate
if m.ux.UC == 'C' & m.ux.tst <= m.lastCheckp then
iterate
cIns = cIns + 1
cUOW = cUOW + (m.ux.UC == 'U')
cCHK = cCHK + (m.ux.UC == 'C')
call sqlUpdArgs 7,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.UC,
,m.ux.plan,
,m.ux.corr,
,m.ux.conn,
,m.ux.authid,
,m.ux.logRecs
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm63a1,' ,
cUOW 'uncommitedUOW and' cCHK 'checkpoints'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM63A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM64A1
¨¨_________________________________________________________________________
*/
INSERT_TADM64A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM64A1..."
say ' ' time() 'begin insert into tadm64a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM64A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"PACKAGE_NAME," ,
"COLLECTION_ID," ,
"CORRID_ID," ,
"CONN_ID," ,
"RESOURCE," ,
"LOCK_STATE," ,
"STATEMENT)" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.LoEs.0
ux = 'LOES.'tx
if m.ux.tst <= m.lastLockesc then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.E,
,m.ux.plan,
,m.ux.package,
,m.ux.CollID,
,m.ux.corr,
,m.ux.conn,
,m.ux.resource,
,m.ux.LckSt,
,m.ux.Statement
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm64a1,' ' LOCK ESCALATION'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM64A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM65A1
¨¨_________________________________________________________________________
*/
INSERT_TADM65A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM65A1..."
say ' ' time() 'begin insert into tadm65a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM65A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"CORRID_ID," ,
"JOBNAME," ,
"CONN_ID," ,
"AUTHID," ,
"ASID," ,
"TCB)" ,
"VALUES (?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.ReEot.0
ux = 'REEOT.'tx
if m.ux.tst <= m.lastReadEot then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.A,
,m.ux.corr,
,m.ux.Jobname,
,m.ux.conn,
,m.ux.AuthID,
,m.ux.AsID,
,m.ux.tcb
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm65a1,' ' ABNORMAL EOT'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM65A1..."
RETURN;
/*-- quote text t with apostrophs (sql string)
truncate if longer then 18 characters ---------------------------*/
cut18: procedure expose m.
parse arg t
if length(t) <= 18 then
return t
else
return left(space(t, 1), 18)
endProcedur cut18
/*----------------------------------------------------------------*/
/*--------- AUSGEBEN VON SQL-FEHLERBESCHREIBUNG SQLCA ------------*/
/*----------------------------------------------------------------*/
SQLCA:
IF m.debug THEN SAY "ENTER PROCEDURE SQLCA..."
parse ARG msg
ggSqlStmt = sqlText
call err msg sqlMsg()
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/*_____________________________________________________________________
¨¨
¨¨ DSN erstellen für RZ4
¨¨_____________________________________________________________________
*/
writeAblfAll: procedure expose m.
parse arg pre
call writeAblf to, fftimeO, pre'.TADM60A1'
call writeAblf uow, ffUow, pre'.TADM63A1'
call writeAblf Loes, ffLockE, pre'.TADM64A1'
call writeAblf ReEot, ffEOT, pre'.TADM65A1'
return 0
endProcedure writeAblfAll
writeAblf: procedure expose m.
parse arg st, ff, dsn
/*______________________________________________________________________
¨¨
¨¨new dsn write
¨¨______________________________________________________________________
*/
do sx=1 to m.st.0
o.sx = csv4obj(st'.'sx, ff, 0)
end
dsn=dsn'.D'date('j')'.T'translate(124578, time(), 12345678)
call writeDsn dsn '::v300', 'O.', m.st.0, 1
return
endProcedure writeAblf
newDSN: procedure expose dsnRZ4.
/*
dsnRZ4.1='DSN.ABLF.LOGEX.DE0G.TADM60A1'
dsnRZ4.2='DSN.ABLF.LOGEX.DE0G.TADM63A1'
dsnRZ4.3='DSN.ABLF.LOGEX.DE0G.TADM64A1'
dsnRZ4.4='DSN.ABLF.LOGEX.DE0G.TADM65A1'
address tso
do i=2 to 4
ok#dsn=SYSDSN("'"dsnRZ4.i"'")
IF ok#dsn = 'OK' then do
SAY 'DSN EXISTS WIRD GELÖSCHT'OK#DSN' = 'dsnRZ4.i
"DELETE '"dsnRZ4.i"'"
if RC>0 then say 'DSN konnte nicht gelöscht werden'
END
/*ok#dsn=SYSDSN("'"dsnRZ4.i"'")
*/ y=0
do until (fb=0 | y>2 )
"ALLOC DDNAME(DDN"i") DSN('"dsnRZ4.i"') new lrecl(160) recfm(f b)"
fb=rc;y=y+1
if fb>0 then do
"FREE DDNAME(DDN"i")"
end
end
end
*/
return
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_rz = ''
m.ii.rzC = ''
i = 'RZ1 1 S1 DBTF T DTF DVTB V DTB DBOC C DOC' ,
'RZ2 2 S2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RR2 R R2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RQ2 Q Q2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RZ4 4 S4 DBOL O DOL DP4G U DP4' ,
'RZX X X2 DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'RZY Y Y2 DE0G E DE0 DEVG M DEV DPYG Y DPY' ,
'RZZ Z Z2 DE0G E DE0 DEVG M DEV DPZG N DPZ'
m.ii_rz = ''
m.ii_rzC = ''
do wx=1 by 3 to words(i)
parse value subWord(i, wx, 3) with w1 w2 w3
if abbrev(w1, 'R') & length(w1) == 3 then do
rz = w1
m.ii_DbSys.rz = ''
m.ii_rz = strip(m.ii_rz rz)
m.ii_rzC = m.ii_rzC || w2
call iiA1 ii_sys2rz, w3, rz
call iiA1 ii_rz2c, rz, w2
end
else if abbrev(w1, 'D') & length(w1) == 4 then do
m.ii_DbSys.rz = strip(m.ii_DbSys.rz w1)
call iiA1 ii_db2c, w1, w2
call iiA1 ii_mbr2db, w3, w1
call iiA1 ii_db2Elar, w1, wordPos(w1, 'DVTB DVBP DEVG')>0
end
else
call err 'bad w1' w1 w2 w3
end
return
endProcedure iiIni
iiA1: procedure expose m.
parse arg st, key ,val
if symbol('m.st.key') \== 'VAR' then
m.st.key = val
else if m.st.key \== val then
call err 'already <> defined' st'.'key'='m.st.key 'val='val
return
endProcedure iiA1
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiRz2C
iiRzDbSysBegin:procedure expose m.
parse arg m
call iiIni
m.m.rx = 1
m.m.dx = 0
return
endProcedure iiRzDbSysBegin
iiRzDbSys:procedure expose m.
parse arg m
do forever
rz = word(m.ii_rz, m.m.rx)
if rz == '' then do
call vPut 'rz', ''
call vPut 'dbSys', ''
return 0
end
m.m.dx = m.m.dx+1
db = word(m.ii_dbSys.rz, m.m.dx)
if db == '' then do
m.m.rx = m.m.rx + 1
m.m.dx = 0
iterate
end
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
end
endProcedure iiRzDbSys
/* copy ii end ********* Installation Info *************************/
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err 'implement rxFetchVars ?' /* ?????????????
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
ret = left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
return ret
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
bef0 = m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then do
say 'atEnd????' m bef0 m.m.cx m.m.0 m.m.buf0x
say m bef0 m.m.cx m.m.0 m.m.buf0x
return ''
end
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfUCNum = m.ut_alfUC || m.ut_digits
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXDB2LOT) cre=2012-07-24 mod=2015-10-08-09.50.19 A540769 ---
/* rexx text exDb2Log */
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
call errReset 'h'
PARSE UPPER arg SSID rest
say "exDb2LoT("ssid rest")"
if ssid == '' then
ssid = 3
if ssid == 1 then do
call err implement fun1
end
else if ssid == 2 then do
betaExt = DSN.ABLF.LOGE2.RR2.BETAEXT
say 'exDb2loT 2' betaExt
pref = left(betaExt, lastPos('.', betaExt))
paPr = DBOF.DBAA.ABLF.LOGE2.
call dsnAlloc 'dd(parmNew)' paPr'parmNew'
call dsnAlloc 'dd(betaRep)' pref'betaRep'
call dsnAlloc 'dd(betaExPa)' pref'betaExPa'
res = exDb2Log(ssid BetaExt)
call tsoFree 'PARMNEW BETAREP betaExPa'
end
else if ssid == 3 then do
inDsn = A540769.LOGEX.RR2.BETAEXT
pref = left(inDsn, lastPos('.', inDsn))
call dsnAlloc 'dd(ddIn1)' inDsn
call dsnAlloc 'dd(parmNew) A540769.LOGEX.parmNew'
res = exDb2LoG(3)
call tsoFree 'ddIn1 parmNew'
end
else if ssid == 3 then do
inDsn = DSN.ABLF.LOGE2.RR2.BETAEXT
pref = left(inDsn, lastPos('.', inDsn))
pref = DBOF.DBAA.ABLF.LOGE2.
call dsnAlloc 'dd(ddIn1)' inDsn
call dsnAlloc 'dd(parmNew)' pref'parmNew'
res = exDb2Log(3)
call tsoFree 'ddIn1 parmNew'
end
else do
call dsnAlloc 'dd(ddIn1)', DSN.DBA.DE0G.MSTR.MSG.LOCKEXTR
res = exDb2Log(ssid)
call tsoFree 'ddIn1'
end
say 'cc='res
exit res
endMainCode
/* copy adrTso begin *************************************************/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXDB2LO0) cre=2015-10-05 mod=2015-10-05-20.48.27 A540769 ---
/* REXX
¨¨____________________________________________________________________
¨¨
¨¨ EXDB2LOG
¨¨ --------
¨¨ read mastlog output and insert the messages into tadm6* tables
¨¨
¨¨ PARMS EXDB2LOG <PARM1>
¨¨ PARM1 = DB2 SUBSYSTEM
¨¨
¨¨ LOCATION DSN.DB2.EXEC ab 4.0
¨¨ TSO.rz?.P0.USER.EXEC bis 3.1
¨¨
¨¨ HISTORY:
¨¨ 2.10.2015 V4.1 for timeout also use DSNT500I and store
¨¨ these even without deadlock/timeout
¨¨ 20.10.2014 V4.0 logE2 => logEx
¨¨ 06.10.2014 V4.0 direkt aus Beta/eJes Extract DSNs lesen
¨¨ member/Datum aus IAT6140 usw.
¨¨ keine doppelte Ausgabe von Beta/eJes Logs
¨¨ 09.04.2014 V3.1 Ergebnis zusätzlich ins DSN
¨¨ 24.09.2012 V3.0 rewrite masterlog
¨¨ 18.04.2012 V2.2 rz8 und rzz integriert
¨¨ 17.04.2012 V2.1 truncate collids longer 18
¨¨ 28.03.2008 V2.0 ABNORMAL EOT (G.KERN,A914227)
¨¨ 27.03.2008 V1.1 UNCOMMITED UOW (G.KERN,A914227)
¨¨ 27.03.2008 V1.2 CHECKPOINTS (G.KERN,A914227)
¨¨ 27.03.2008 V1.3 LOCK ESCALATION (G.KERN,A914227)
¨¨ 30.01.2008 V1.0 GRUNDVERSION (G.KERN,A914227)
¨¨
¨¨_____________________________________________________________________
*/
m.debug = 0
m.tstRZ4 = 1
m.insertLocal = 1
m.writeABLF = 1
m.wkTest = 0
m.acTest = 0
call errReset 'h'
PARSE UPPER arg SSID rest
say "exDb2Log("ssid rest") version v4.1 vom 2.10.15"
if ssid == 1 then
return doFun1()
else if ssid == 2 then
return doFun2(rest)
else if ssid == 3 then
return doFun3()
else if 0 then
return workOld(ssid)
else do
o.1 = date('s') time() sysVar(sysNode) mvsvar('symdef', 'jobname') ,
'exDb2Log workOld deActivated'
call writeDsn 'mod dsn.ablf.logDeImp ::f', o., 1
say 'exDb2Log workOld deActivated'
return 0
end
endMainCode
/*-------------- alte Verarbeitung -----------------------------------*/
workOld:
parse arg ssid
call ini 0
/*_____________________________________________________________________
¨¨
¨¨ VARIABLEN INITIALISIEREN
¨¨_____________________________________________________________________
*/
m.tadmDbSy = ''
m.lastDeadlock = ''
m.lastTimeout = ''
m.tadmCreator = ''
/*_____________________________________________________________________
¨¨
¨¨ HAUPTPROGRAMM
¨¨_____________________________________________________________________
*/
SAY "DB2 SUBSYSTEM = "SSID
CALL OWNER_SSID_ZUWEISEN ssid /* ZUWEISEN OWNER & SSID FÜR SQL */
CALL sqlConnect ssid /* DB2 SUBSYSTEM VERBINDEN */
CALL readMstrLog /* INPUT-DS lesen und analysieren */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
if m.insertLocal then do
CALL sqlConnect m.tadmDbSy /* DB2 SUBSYSTEM VERBINDEN */
CALL GET_MAX_WERT_TIMEOUT /* MAX TIMEOUT vON TABELLE LESEN */
CALL GET_MAX_WERT_DEADLOCK /* MAX DEADLOCK VON TABELLE LESEN */
CALL GET_MAX_WERT_uncommittedUOW /* MAX uncommittedUOW */
CALL GET_MAX_WERT_CHECKPNT /* MAX CHECKPNT VON TABELLE Lesen */
CALL GET_MAX_WERT_LOCKESCA /* MAX LOCKESCA VON TABELLE Lesen */
CALL GET_MAX_WERT_EOT /* MAX EOT EINTRAG VON TABELLE LESEN */
CALL INSERT_TADM60A1 /* deadlocks und timeouts */
CALL INSERT_TADM63A1 /* uncommitted UOW */
CALL INSERT_TADM64A1 /* LOCK ESCALATION */
CALL INSERT_TADM65A1 /* abnormal eot */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
end
if m.writeABLF then /* write dsn für ABLF */
/* call writeAblfAll 'DSN.ABLF.LOGEX.'ssid */
call writeAblfAll 'A540769.LOGEX.ABLF.'ssid
return 0
endSubroutine workOld
/*--- write timestamp to dd parmNew ----------------------------------*/
doFun1: procedure expose m.
parse arg betaExt .
call ini 1
call readDD parmOld, i., '*'
call tsoClose parmOld
ix = i.0
say 'parmOld' ix strip(i.ix, 't')
w1 = word(i.ix, 1)
if i.0 = 0 then
old = '2014-01-01-00.00.00'
else if translate(w1, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad to tst in parmOld 1:' i.ix
else if substr(w1, 15, 2) >= 15 then
old = overlay(right(substr(w1, 15, 2)-15, 2,0), w1, 15)
else if substr(w1, 12, 2) >= 1 then
old = overlay(right(substr(w1, 12, 2)-1, 2,0) ,
|| '.'right(substr(w1, 15, 2)+45, 2,0), w1, 12)
else
old = left(w1, 11)'00.00.00'
new = translate('1234-56-78', date('s'), '12345678') ,
|| '-'translate(time(), '.', ':')
if new <= old then
call err 'new' new '<=' old 'old'
o.1 = new old
call writeDD parmNew, o., 1
call tsoClose parmNew
say 'parmNew' strip(o.1, 't')
if substr(old, 6, 2) > 2 then
betaS = overlay(right(substr(old, 6, 2)-2, 2,0), old, 6)
else
betaS = overlay(left(old, 4)-1,
|| '-'right(substr(old, 6, 2)+10, 2,0), old, 1)
if substr(betaS, 9, 2) > 28 then
betaS = overlay(28, betaS, 9)
betaS = translate('78.56.1234', left(betaS, 10), '1234-56-78')
say 'betaStart' betaS 'betaExt' betaExt
o.1 = 'REPORT'
o.2 = ' SDATE('betaS')'
o.3 = ' STIME(00:00:00)'
o.4 = ' PDATE(TODAY)'
o.5 = ' PTIME(23:59:59)'
o.6 = ' JOBNAME(D***MSTR)'
call writeDD betaRePa, o., 6
call tsoClose betaRePa
a.1 = ' 00:00:00 ' /* idiotisches Rexx stuerzt ab auf leerem
konatiniertem Dataset | */
call writeDD 'betaExt', a., 1
call tsoClose 'betaExt'
call writeDD 'eJesExt', a., 1
call tsoClose 'eJesExt'
say 'written idiotic dummy row on betaExt and eJesExt'
call eJesJobExtDD 'D%%%MSTR', 'JESMSGLG'
return 0
endProcedure doFun1
/*--- select jobs from betaRep ---------------------------------------*/
doFun2: procedure expose m.
parse arg betaExt .
call ini 1
say 'fun2' betaExt
call parmNewRead
new = m.parm_new
old = m.parm_old
call readDD betaRep, b., '*'
call tsoClose betaRep
say 'dd betaRep' b.0 'lines'
do bx=1 to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' then do
bx = bx + 1
if substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' then
leave
end
if pos('NO JOBS MATCHED SELECTION', b.bx) > 0 then do
say 'no jobs in Beta report:' b.bx
return 4
end
end
if bx > b.0 then
call err 'no title found in betaRep'
say b.bx
cJ = 2
cI = 11
cE = pos(' END DATE ', b.bx)
eE = cE + 10
cF = pos(' END TIME ', b.bx) + 1
eF = cF+8
m.o.0 = 0
if cE < 20 | cF < 20 then
call err 'bad end time/date in beta title' b.bx
cS = pos(' SUB DATE ', b.bx)
eS = cS + 10
cT = pos(' SUB TIME ', b.bx) + 1
eT = cT+8
m.o.0 = 0
m.f.0 = 0
if cS < 20 | cT < 20 then
call err 'bad end time/date in beta title' b.bx
jx = 0
jy = 0
do bx=bx to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' ,
| abbrev(substr(b.bx, 2), '-----') ,
| abbrev(substr(b.bx, 2), '=====') ,
| substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' ,
| abbrev(substr(b.bx, 2), 'PROGRAM B92BFJBR ') then
iterate
if pos(' JOB(S) MATCHED SELECTI', b.bx) > 0 then do
jz = word(substr(b.bx, 2), 1)
iterate
end
say b.bx
parse var b.bx 2 vJ 10 11 vI 19 ,
=(cS) vS =(eS) =(cT) vT =(eT) ,
=(cE) vE =(eE) =(cF) vF =(eF)
if translate(vE, '999999999', '012345678') \== '99.99.9999' then
call err 'bad end date' vE 'in line' bx':' b.bx
if translate(vF, '999999999', '012345678') \= '99:99:99' then
call err 'bad end time' vF 'in line' bx':' b.bx
vG = translate('1234-56-78', vE, '78.56.1234') ,
|| '-'translate(vF, '.', ':')
jx = jx + 1
if vG << old then
iterate
jy = jy + 1
say ' selected' vJ vI', ended' vG '>>=' old 'old'
call mAdd f, 'BFIND' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' OPERATOR(OR)' ,
, ' OPTIONS(FIRST)' ,
, ' SCOPE(BOTH)' ,
, ' MESSAGE(LONG)' ,
, ' RELOAD(YES)' ,
, ' MIXEDMODE(NO)' ,
, ' SLINE(0)' ,
, ' PLINE(0)' ,
, ' STRING1(DATE)'
call mAdd o, 'PRINT' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' MASK(MM/DD/YY)' ,
, ' AUTOSEL(NO)' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' MESSAGE(LONG)' ,
, ' SCOPE(BOTH)' ,
, ' DISPOSITION(MOD)' ,
, ' DATASET('betaExt')'
end
if jx <> jz then
call err jx 'jobs read not' jz 'as beta says'
say jy 'jobs selected from' jz 'in list'
call writeDD betaExPa, 'M.O.'
call tsoClose betaExPa
call writeDD betaFiPa, 'M.F.'
call tsoClose betaFiPa
return 4 * (jy = 0)
endProcedure doFun2
/*--- read concatenated master logs and write load files -------------*/
doFun3: procedure expose m.
call ini 1
call parmNewRead
call readMstrLog
call writeAblfAll 'A540769.LOGEX.ABLF'
/* call writeAblfAll 'DSN.ABLF.LOGEX.'sysvar(sysnode) */
return 0
endProcedure doFun3
/*--- read parmNew, extract new and old timestamp --------------------*/
parmNewRead: procedure expose m.
call readDD parmNew, n., '*'
call tsoClose parmNew
parse var n.1 new old .
say 'parmNew' new old
if n.0 < 1 then
call err 'empty parmNew'
else if translate(new, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad new in parmNew:' new
else if translate(old, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad old in parmNew:' old
else if new <= old then
call err 'new <= old' new old
m.parm_new = new
m.parm_old = old
return
endProcedure parmNewRead
/*_____________________________________________________________________
¨¨
¨¨ OWNER UND SSID FÜR SQL ABFRAGE ZUWEISEN
¨¨_____________________________________________________________________
*/
OWNER_SSID_ZUWEISEN: procedure expose m.
parse arg ssid
IF m.debug THEN SAY "ENTER PROCEDURE OWNER_SSID_ZUWEISEN..." ssid
SELECT
WHEN SSID = 'DBTF' THEN info = 'DTF OA1T DBTF'
WHEN SSID = 'DBOC' THEN info = 'DOC OA1T DBTF'
WHEN SSID = 'DVTB' THEN info = 'DTB OA1T DBTF'
WHEN SSID = 'DP2G' THEN info = 'DP2 OA1P DP2G' /* rz2 */
WHEN SSID = 'DBOF' THEN info = 'DOF OA1P DP2G'
WHEN SSID = 'DVBP' THEN info = 'DBP OA1P DP2G'
WHEN SSID = 'DC0G' THEN info = 'DC0 OA1P DC0G' /* rz8 */
WHEN SSID = 'DCVG' THEN info = 'DCV OA1P DCVG'
WHEN SSID = 'DD0G' THEN info = 'DD0 OA1P DD0G'
WHEN SSID = 'DDVG' THEN info = 'DDV OA1P DDVG'
WHEN SSID = 'DX0G' THEN info = 'DX0 OA1P DX0G'
WHEN SSID = 'DP8G' THEN info = 'DP8 OA1P DP8G'
WHEN SSID = 'DE0G' THEN info = 'DE0 OA1P DE0G' /* rzz */
WHEN SSID = 'DEVG' THEN info = 'DEV OA1P DEVG'
OTHERWISE call err "bad ssid = '"ssid"'"
END
parse var info m.db2Member3 m.tadmCreator m.tadmDbSy .
if m.wkTest then do
m.tadmCreator = A540769
m.tadmDbSy = 'DBAF'
if ssid = 'DVBP' then ssid = 'DBTF'
say '?????? wktest run' m.tadmDbSy
end
if m.acTest then do
m.tadmCreator = A754048
m.tadmDbSy = 'DE0G'
if ssid = '' then ssid = 'DE0G'
say '?????? actest run' m.tadmDbSy
end
say ' ssid' ssid 'member' m.db2Member3'?',
'to' m.tadmDbSy':'m.tadmCreator'.TADM6*A1'
IF m.debug THEN SAY "LEAVE PROCEDURE OWNER_SSID_ZUWEISEN..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX TIMEOUT WERT VON TADM60A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_TIMEOUT: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_TIMEOUT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'T' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C3 CURSOR FOR S3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S3 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C3 INTO :m.lastTimeout :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX TIMEOUT TIMESTAMP FOR" SSID "IS:" m.lastTimeout
ADDRESS DSNREXX "EXECSQL CLOSE C3"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_TIMEOUT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX DEADLOCK WERT VON TADM60A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_DEADLOCK: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_DEADLOCK..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'D' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C2 CURSOR FOR S2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S2 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C2 INTO :m.lastDeadlock :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX DEADLOCK TIMESTAMP FOR" SSID "IS:" m.lastDeadlock
ADDRESS DSNREXX "EXECSQL CLOSE C2"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_DEADLOCK..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX uncommittedUOW WERT VON TADM63A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_uncommittedUOW:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_uncommittedUOW..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'U' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C7 CURSOR FOR S7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S7 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C7 INTO :m.lastUOW :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX UNCOMMITTED UOW TIMESTAMP FOR" SSID "IS:" m.lastUOW
ADDRESS DSNREXX "EXECSQL CLOSE C7"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_uncommittedUOW..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX CHECKPNT WERT VON TADM63A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_CHECKPNT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_CHECKPNT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'C' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C9 CURSOR FOR S9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S9 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C9 INTO :m.lastCheckp :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX CHECKPOINT TIMESTAMP FOR" SSID "IS:" m.lastCheckp
ADDRESS DSNREXX "EXECSQL CLOSE C9"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_CHECKPNT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX LOCKESCA WERT VON TADM64A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_LOCKESCA:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_LOCKESCA..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM64A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'E' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C10 CURSOR FOR S10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S10 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C10 INTO :m.lastLockesc :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX LOCK ESCALATION TIMESTAMP FOR" SSID "IS:" m.lastLockesc
ADDRESS DSNREXX "EXECSQL CLOSE C10"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_LOCKESCA..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX EOT WERT VON TADM65A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_EOT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_EOT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM65A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'A' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C12 CURSOR FOR S12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S12 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C12 INTO :m.lastReadEot :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX ABNORMAL EOT TIMESTAMP FOR" SSID "IS:" m.lastReadEot
ADDRESS DSNREXX "EXECSQL CLOSE C12"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_EOT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ read the whole master log
¨¨ and analyse each interesting msg
¨¨_____________________________________________________________________
*/
readMstrLog:
call readNxBegin rd, '-', 'DDIN1'
li = readNx(rd)
m.to.0 = 0
m.uow.0 = 0
m.LoEs.0 = 0
m.ReEot.0 = 0
m.info.doneUntil = m.parm_old
m.info.jobKey = ''
do lx=1 to 12e12 while li <> ''
mid = isDsnMsg(m.li, info)
if mid == '' then
nop
else if m.info.tst <<= m.info.doneUntil then
nop /* already done yesterday or eJes <-> beta92 */
else if mid == 'DSNT375I' then
call anaTimeoutDeadlock rd, info, 'D'
else if mid == 'DSNT376I' then
call anaTimeoutDeadlock rd, info, 'T'
else if mid == 'DSNT500I' | mid == 'DSNT501I' then
call anaResourceNotAvailable rd, info, mid
else if mid == 'DSNJ031I' then
call anaUncommittedUOW rd, info, 'U'
else if mid == 'DSNR035I' then
call anaUncommittedUOW rd, info, 'C'
else if mid == 'DSNI031I' then
call anaLockEscalation rd, info, 'E'
else if mid == 'DSN3201I' then
call anaReadEot rd, info, 'A'
l2 = readNxCur(rd)
if li == l2 then
li = readNx(rd)
else
li = l2
end
if m.info.jobKey \== '' then
call sayJobEnd info
say 'readMstrLog end:' readNxPos(rd)
call readNxEnd rd
return
endProcedure readMstrLog
/*_____________________________________________________________________
¨¨
¨¨ if this is not a dsn message return ''
¨¨ otherwise, check it, collect infos into info and return id
¨¨_____________________________________________________________________
*/
isDsnMsg: procedure expose m.
parse arg line, info
if m.modeNew then do
if translate(substr(line, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then do
if substr(line, 2, 18) \== 'IAT6140 JOB ORIGIN' then
call err 'bad line' line
s1 = ''
m2 = ''
if m.info.jobKey \== '' then do
call sayJobEnd info
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' ,
| jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
end
m.info.dateTst = ''
do lx=1 to 50
ln = readNx(rd)
if ln = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if translate(substr(m.ln, 2, 9), '999999999',
, '012345678') \== '99:99:99 ' then do
say 'bad start of mstrLog after' line
say ' @' readNxPos(rd)
return isDsnMsg(m.ln, info)
end
if word(m.ln, 2) == 'IEF403I' then do
j1 = word(m.ln, 3)
s1 = word(m.ln, words(m.ln))
end
else do
d2 = isDsnMsg(m.ln, info)
if d2 = 'DSNY024I' then do
m2 = substr(word(m.ln, 3), 2)
leave
end
else if d2 \== '' then
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return ''
end
mid = word(line, 2)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
return ''
end
end
else do
mid = word(line, 4)
parse var line m.info.dbMb m.info.date m.info.time .
m.info.dbSys = iiMbr2DbSys(m.info.dbMb)
if \ abbrev(mid, 'DSN') | wordIndex(line, 4) <> 29 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 5) = 'IAT6853' then
call anaCurDate info, substr(line,18), word(line,2)
m.info.wxTime = 3
m.info.cxTime = 19
return ''
end
m.info.head = left(line,27)
end
/* diese Prüfung ist falsch, manche displays zeigen --------------
Infos aus anderen membern an, z.B. -dis indoubt ......
aMbr = word(line, 5)
if abbrev(aMbr, '-') then
if '-'m.info.dbMb \== aMbr then
call err 'dbMember mismatch:' m.info.dbMb ,
'<>' readNxPos(rd) -----------------------------*/
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
return mid
endProcedure isDsnMsg
sayJobEnd: procedure expose m.
parse arg info
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
say 'job' m.info.job jKy 'to' m.info.tst p
return
endProcedure say JobEnd
/*_____________________________________________________________________
¨¨
¨¨ analyse current date in iat6853 message
¨¨ and check that it equals the header
¨¨_____________________________________________________________________
*/
anaCurDate: procedure expose m.
parse arg info, line, compD
if substr(line, 23, 21) ,
<> ' THE CURRENT DATE IS ' then
call err 'bad IAT6853' readNxPos(rd)
d1 = subword(substr(line, 44), 2, 3)
/* convert date, month must be in lower&upper case | */
d2 = word(d1, 1) ,
translate(left(word(d1, 2), 1)),
|| translate(substr(word(d1, 2), 2),
, m.ut_AlfLC, m.ut_AlfUC) ,
word(d1, 3)
do while abbrev(d2, 0) /* date does not accept leading zeroes ||||| */
d2 = substr(d2, 2)
end
d3 = date('s', d2)
m.info.date = translate('1234-56-78', d3, '12345678')
m.info.dateTst = m.info.date'-'translate(m.info.time,'.',':')
if compD \== '' then
if m.info.date <> compD then
call err 'date mismatch' compD '<>' d3 'line:' ,
compD line
return
endProcedure anaCurDate
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSN3201I event type A - ABNORMAL EOT AUS INPUT-DS LESEN
¨¨____________________________________________________________________
*/
anaReadEot: procedure expose m.
parse arg rd, info, pEvTy
li = readNxCur(rd)
m.ReEot.0 = m.ReEot.0 +1
ux = 'REEOT.'m.ReEot.0 /*zähler */
m.ux.A = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.corr = ''
m.ux.Jobname = ''
m.ux.conn = ''
m.ux.AuthID = '' /* AuthID = User column in db2 Table */
m.ux.AsID = ''
m.ux.tcb = ''
do forever
cx = pos(' CORRELATION-ID=', m.li)
jx = pos(' JOBNAME=', m.li)
if cx > 0 then do
if jx < cx then
m.ux.corr = cut18(strip(substr(m.li,cx+16)))
else
m.ux.corr = cut18(strip(substr(m.li,cx+16, jx-cx-16)))
end
if jx > 0 then do
m.ux.Jobname = cut18(word(strip(substr(m.li,jx+9)), 1))
end
cx = pos(' CONNECTION-ID=', m.li)
if cx > 0 then do
m.ux.conn = cut18(word(substr(m.li,cx+15), 1))
end
cx = pos(' USER=', m.li)
if cx > 0 then do
m.ux.AuthID = word(substr(m.li,cx+6), 1)
end
cx = pos(' ASID=', m.li)
if cx > 0 then do
m.ux.AsID = word(substr(m.li,cx+6), 1)
end
cx = pos(' TCB=', m.li)
if cx > 0 then
m.ux.tcb = strip(substr(m.li,cx+5))
li = readNx(rd)
if \ abbrev(m.li, m.info.head) then
leave
if m.ux.tcb <> '' then
leave
end
return
endProcedure anaReadEot
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSNI031I event type E - LOCK ESCALATION
¨¨____________________________________________________________________
*/
anaLockEscalation: procedure expose m.
parse arg rd, info, pEvTy
li = readNxCur(rd)
m.LoEs.0 = m.LoEs.0 +1
ux = 'LOES.'m.LoEs.0 /*zähler */
m.ux.E = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.plan = ''
m.ux.package = ''
m.ux.CollID = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.resource = ''
m.ux.LckSt = ''
m.ux.Statement = ''
do forever
cx = pos(' RESOURCE NAME = ', m.li)
if cx > 0 then
m.ux.resource = strip(word(m.li, m.info.wxTime + 4))
cx = pos(' LOCK STATE = ', m.li)
if cx > 0 then
m.ux.LckSt = strip(word(m.li, m.info.wxTime + 4))
cx = pos(' PLAN NAME : PACKAGE NAME = ',m.li)
if cx > 0 then do
PlanPack = substr(m.li,cx+28)
cx = pos(':',planpack)
m.ux.plan = strip(left(planPack, cx-1))
m.ux.package = cut18(strip(substr(planPack,cx+1)))
end
cx = pos(' COLLECTION-ID = ', m.li)
if cx > 0 then
m.ux.CollID = cut18(strip(substr(m.li,cx+17)))
cx = pos(' STATEMENT NUMBER = ', m.li)
if cx > 0 then
m.ux.Statement= strip(substr(m.li,cx+20))
cx = pos(' CORRELATION-ID = ', m.li)
if cx > 0 then
m.ux.corr = cut18(strip(substr(m.li,cx+18)))
cx = pos(' CONNECTION-ID = ', m.li)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.li,cx+17)))
li = readNx(rd)
if \ abbrev(m.li, m.info.head) then
leave
if m.ux.conn <> '' then
leave
end
return
endProcedure anaLockEscalation
sayObj: procedure expose m.
parse arg ff, o
say o':' cl
do fx=1 to m.ff.0
f1 = m.ff.fx
say left(f1, 20) m.o.f1
end
return
endProcedure sayObj
/*____________________________________________________________________
¨¨
¨¨ analye uncommit UOW msg: DSNJ031I / event type U and C
¨¨____________________________________________________________________
*/
anaUncommittedUOW: procedure expose m.
parse arg rd, info, pEvTy
li = readNxCur(rd)
m.uow.0 = m.uow.0 +1
ux = 'UOW.'m.uow.0 /* zähler */
m.ux.UC = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.logRecs = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.plan = ''
m.ux.authid = ''
do forever
cx = pos(' CHECKPOINTS -', m.li) /* for checkP */
if cx > 0 then
m.ux.logRecs = strip(word(m.li, m.info.wxTime + 2))
cx = pos(' LOG RECORDS -', m.li) /* for UOW */
if cx > 0 then
m.ux.logRecs = strip(word(m.li, m.info.wxTime + 3))
cx = pos(' CORRELATION NAME =', m.li)
if cx > 0 then
m.ux.corr = cut18(word(substr(m.li,cx+19),1))
cx = pos(' CONNECTION ID =', m.li)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.li,cx+17)))
cx = pos(' PLAN NAME =', m.li)
if cx > 0 then
m.ux.plan = strip(substr(m.li,cx+13))
cx = pos(' AUTHID =', m.li)
if cx > 0 then
m.ux.authid = strip(substr(m.li,cx+9))
li = readNx(rd)
if \ abbrev(m.li, m.info.head) then
leave
if m.ux.authid <> '' then
leave
end
return
endProcedure anaUncommittedUOW
/*____________________________________________________________________
¨¨
¨¨ analye timeout, deadlock msg: DSNT375I, DSNT376I
¨¨____________________________________________________________________
*/
anaTimeoutDeadlock: procedure expose m.
parse arg rd, info, pEvTy
li = readNxCur(rd)
totx = newTimeout(info, pEvTy)
vs = 'V'
do forever
if pos(' ONE HOLDER ', m.li) > 0 then do
if pEvTy <> 'T' then
call err 'holder for evTy' pEvTy':'readNxPos(r)
else if vs <> 'V' then
call err 'several holders:'readNxPos(r)
else
vs = 'H'
end
if pos(' IS DEADLOCKED ', m.li) > 0 then do
if pEvTy <> 'D' then
call err 'is deadLocked for evTy' pEvTy':'readNxPos(r)
else if vs <> 'V' then
call err 'several is deadLocked:'readNxPos(r)
else
vs = 'H'
end
cx = pos(' PLAN=', m.li)
if cx > 0 then
m.toTx.vs.plan = word(substr(m.li, cx+6,8), 1)
cx = pos(' CORRELATION-ID=', m.li)
if cx > 0 then
m.toTx.vs.corr = cut18(strip(substr(m.li, cx+16)))
cx = pos(' CONNECTION-ID=', m.li)
if cx > 0 then
m.toTx.vs.conn = cut18(strip(substr(m.li, cx+15)))
cx = pos(' ON MEMBER ', m.li)
if cx > 0 then do
if vs <> 'H' then
call err 'on member in vs' vs':' readNxPos(rd)
else
m.toTx.vs.dbMb = word(substr(m.li, cx+11, 8), 1)
end
li = readNx(rd)
if \ abbrev(m.li, m.info.head) then
leave
if substr(m.li, m.info.cxTime+10, 8) <> '' then
if isDsnMsg(m.li, info) <> '' then
leave
end
return
endProcedure anaTimeOut
/*____________________________________________________________________
¨¨
¨¨ make and initialise a new timeout/deadlock row
¨¨____________________________________________________________________
*/
newTimeout: procedure expose m.
parse arg info, pEvTy
m.to.0 = m.to.0 + 1
toTx = 'TO.'m.to.0
call clearFlds totx, ffTimeO
m.toTx.tst = m.info.tst
m.toTx.evTy = pEvTy
m.toTx.v.dbMb = m.info.dbMb
m.toTx.dbSys = m.info.dbSys
return toTx
endProcedure newTimeout
/*____________________________________________________________________
¨¨
¨¨ analyse resourceNotAvailable msg DSNT501I and DSNT500I
¨¨____________________________________________________________________
*/
anaResourceNotAvailable: procedure expose m.
parse arg rd, info, mid
tCor = ''
tCon = ''
tRea = ''
tTyp = ''
tNam = ''
do forever /* loop line of dsnt501i */
cx = pos(' CORRELATION-ID=', m.li)
if cx > 0 then
tCor = word(substr(m.li,cx+16),1)
cx = pos(' CONNECTION-ID=', m.li)
if cx > 0 then
tCon = strip(substr(m.li,cx+15))
cx = pos(' REASON ', m.li)
if cx > 0 then
tRea = word(substr(m.li,cx+8,20),1)
cx = pos(' TYPE ', m.li)
if cx > 0 then
tTyp = word(substr(m.li,cx+6,20),1)
cx = pos(' NAME ', m.li)
if cx > 0 then
tNam = strip(substr(m.li,cx+6))
li = readNx(rd)
if \ abbrev(m.li, m.info.head) then
leave
/* ???? < 15:17:59 DSNT397I -DOF8>
if substr(m.li, 29, 8) <> '' then ???? */
if isDsnMsg(m.li, info) <> '' then
leave
end /* loop line of dsnt501i */
/* search preceeding timeOut/deadLock*/
if tCor = '' | tCon = '' then do
tx = m.to.0
if m.to.tx.name \== '' then
tx = -1
end
else do
mb = m.info.dbMb
tsN = m.info.tst
numeric digits 20
tsB = timeDays2Tst(timestamp2Days(tsN) - 30/86400)
numeric digits 9
do tx=m.to.0 to 1 by -1
if m.to.tx.v.dbMb <> mb ,
| m.to.tx.tst >> tsN | m.to.tx.tst << tsB then
tx = -1
else if m.to.tx.v.corr == tCor & m.to.tx.v.conn == tCon ,
& m.to.tx.name == '' then
leave
end
end
if tx > 0 then do
toTx = 'TO.'tx /* resource an timeout/deadlock anhängen */
end
else do /* new feature: store these also
evType depending on reason, but some have several */
if wordPos(tRea, '00C200FA 00C20031 00C900C0 00E70010') >0 then
toTx = newTimeout(info, 'T')
else
toTx = newTimeout(info, '')
m.toTx.v.corr = tCor
m.toTx.v.conn = tCon
end
m.toTx.type = tTyp
m.toTx.name = space(tNam, 1)
m.toTx.reason = tRea
if tTyp <> '' then
call resourceType info, toTx'.'type, toTx'.'name
return
endProcedure anaResourceNotAvailable
/*____________________________________________________________________
¨¨
¨¨ give the name of the resourcetype and dbid/obid
¨¨____________________________________________________________________
*/
resourceType: procedure expose m.
parse arg info, tp, nm
cd = m.tp
if symbol('m.resourceType.cd') <> 'VAR' then do
say '<'cd'>' c2x(cd)
say readNxPos(rd)
call err 'unknown resource type' cd
end
m.tp = m.resourceType.cd
parms = m.resourceTypeParms.cd
names = m.nm
if pos('DI.OI', parms) > 0 then do /* find dbid and obid */
px = 0
nx = 0
do until px = 0
py = pos('.', parms, px + 1)
ny = pos('.', names, nx + 1)
if (py=0) <> (ny=0) then
call err 'resource parms' parms 'mismatch name' names
if py = 0 then do
p1 = substr(parms, px+1)
n1 = substr(names, nx+1)
end
else do
p1 = substr(parms, px+1, py-px-1)
n1 = substr(names, nx+1, ny-nx-1)
end
n.p1 = n1
px = py
nx = ny
end
/* dbid und obid uebersetzen */
m.nm = strip(getDbidObid(m.info.dbSys, n.di, n.oi) names)
end
return cd
endProcedure resourceType
ini: procedure expose m.
parse arg m.modeNew
call resourceTypeIni
call sqlIni
call errAddCleanup "if m.sql_dbSys <> '' then do;" ,
"say 'rollback';call sqlExec Rollback; call sqlDisconnect; end"
if m.modeNew then
f1 = 'TST DBSYS'
else
f1 = 'TST'
call iniFlds ffTimeO, f1 'V.DBMB EVTY V.PLAN V.CORR V.CONN' ,
'H.PLAN H.CORR H.CONN' ,
'REASON TYPE NAME'
call iniFlds ffUow, f1 'DBMB UC PLAN CORR CONN AUTHID LOGRECS'
call iniFlds ffLockE, f1 'DBMB E PLAN PACKAGE COLLID' ,
'CORR CONN RESOURCE LCKST STATEMENT'
call iniFlds ffEOT, f1 'DBMB A CORR JOBNAME CONN AUTHID ASID TCB'
return
endProcedure ini
iniFlds: procedure expose m.
parse arg ff, flds
do fx=1 to words(flds)
m.ff.fx = word(flds, fx)
end
m.ff.0 = words(flds)
return
endProcedure iniFlds
clearFlds: procedure expose m.
parse arg o, ff
do fx=1 to m.ff.0
f1 = m.ff.fx
m.o.f1 = ''
end
return o
endProcedure clearlds
resourceTypeIni: procedure expose m.
/* the old definitions for backward compability */
call rtDef '00000100', 'DB'
call rtDef '00000200', 'TS'
call rtDef '00000201', 'IX-SPACE'
call rtDef '00000202', 'TS'
call rtDef '00000210', 'PARTITION'
call rtDef '00000220', 'DATASET'
call rtDef '00000230', 'TEMP FILE'
call rtDef '00000300', 'TEMP FILE'
call rtDef '00000300', 'PAGE'
call rtDef '00000301', 'IX-MINIPAGE'
call rtDef '00000302', 'TS-PAGE'
call rtDef '00000303', 'IX-PAGE'
call rtDef '00000304', 'TS-RID'
call rtDef '00000D01', 'DBID/OBID'
call rtDef '00000800', 'PLAN'
call rtDef '00000801', 'PACKAGE'
call rtDef '00002000', 'TS CS-CLAIM CLASS'
call rtDef '00002001', 'TS RR-CLAIM CLASS'
call rtDef '00002002', 'TS WRITE-CLAIM CLASS'
call rtDef '00002003', 'IX CS-CLAIM CLASS'
call rtDef '00002004', 'IX RR-CLAIM CLASS'
call rtDef '00002005', 'IX WRITE-CLAIM CLASS'
call rtDef '00002006', 'TS PART CS-CLAIM CLASS'
call rtDef '00002007', 'TS PART RR-CLAIM CLASS'
call rtDef '00002008', 'TS PART WRITE-CLAIM CLASS'
call rtDef '00002009', 'IX PART CS-CLAIM CLASS'
call rtDef '00002010', 'IX PART RR-CLAIM CLASS'
call rtDef '00002011', 'IX PART WRITE-CLAIM CLASS'
/* the complete Db2V10 resource type table */
call rtDef '00000100', 'Database', 'DB'
call rtDef '00000200', 'Table space', 'DB.SP'
call rtDef '00000201', 'Index space', 'DB.SP'
call rtDef '00000202', 'Table space RD.DB.TS'
call rtDef '00000205', 'Compression Dictionary', 'DB.SP'
call rtDef '00000210', 'Partition', 'DB.SP.PT'
call rtDef '00000220', 'Data set', 'DSN'
call rtDef '00000230', 'Temporary file', 'SZ'
call rtDef '00000240', 'Database procedure', 'DBP'
call rtDef '00000300', 'Page', 'DB.SP.PG'
call rtDef '00000301', 'Index minipage', 'DB.SP.PG.MP'
call rtDef '00000302', 'Table space page', 'DB.SP.PG'
call rtDef '00000303', 'Index space page', 'DB.SP.PG'
call rtDef '00000304', 'Table space RID', 'DB.SP.RID'
call rtDef '00000305', 'Index access/table space RID', 'DB.SP.RID'
call rtDef '00000306', 'Index access/table space page', 'DB.SP.PG'
call rtDef '00000307', 'Index space EOF', 'DB.SP.01'
call rtDef '00000400', 'ICF catalog', 'IC'
call rtDef '00000401', 'Authorization function'
call rtDef '00000402', 'Security Server',
, 'SAF/RACF return/reason codes'
call rtDef '00000500', 'Storage group', 'SG'
call rtDef '00000602', 'EDM DBD Space'
call rtDef '00000603', 'EDM DYNAMIC STATEMENT Space'
call rtDef '00000604', 'EDM skeleton storage'
call rtDef '00000605', 'EDM above-the-bar storage'
call rtDef '00000606', 'EDM below-the-bar storage'
call rtDef '00000700', 'Buffer pool space', 'BP'
call rtDef '00000701', 'Group buffer pool', 'GBP'
call rtDef '00000800', 'Plan', 'PL'
call rtDef '00000801', 'Package', 'COLLECTION.PACKAGE.CONTOKEN'
call rtDef '00000802', 'BINDLOCK01 through BINDLOCK20',
, 'BINDLOCK01 through BINDLOCK20'
call rtDef '00000900', '32KB data area'
call rtDef '00000901', 'Sort storage'
call rtDef '00000903', 'Hash anchor', 'DB.SP.PG.AI'
call rtDef '00000904', 'RIDLIST storage'
call rtDef '00000905', 'IRLM storage'
call rtDef '00000906', 'DB2', 'MEMBER'
call rtDef '00000907', 'LOB storage'
call rtDef '00000908', 'Basic Floating Point Extensions Facility'
call rtDef '00000909', 'Extended Time-of-Day (TOD) Clock'
call rtDef '0000090A', 'XML storage'
call rtDef '00000A00', 'Table', 'RD.CR.TB'
call rtDef '00000A10', 'Alias', 'RELDEP.OWNER.ALIAS.RD.CR.AL'
call rtDef '00000A11', 'Distinct type', 'SC.DT'
call rtDef '00000A12', 'User-defined function', 'SC.SN'
call rtDef '00000A13', 'Stored procedure', 'SC.SN'
call rtDef '00000A14', 'Sequence'
call rtDef '00000A16', 'Role'
call rtDef '00000A17', 'Trigger'
call rtDef '00000B00', 'View', 'RD.CR.VW'
call rtDef '00000C00', 'Index', 'RD.CR.IX'
call rtDef '00000C01', 'Index', 'CR.IX'
call rtDef '00000D00', 'DBID/OBID', 'RD.DI.OI'
call rtDef '00000D01', 'DBID/OBID', 'DI.OI'
call rtDef '00000D02', 'OBID', 'OI'
call rtDef '00000E00', 'SU limit exceeded', 'CN'
call rtDef '00000F00', 'Auxiliary column',
,'DI.OI.ROWID.COLN or DI.OI.DOCID.COLN'
call rtDef '00000F01', 'LOB lock', 'DIX.PIX.ROWID.VRSN'
call rtDef '00000F81', 'XML lock', 'DIX.PIX.DOCID'
call rtDef '00001000', 'DDF', 'LOCATION or SUBSYSTEM ID'
call rtDef '00001001', 'System conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001002', 'Agent conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001003', 'CNOS processing',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001004', 'CDB (Communication database)',
, 'LOCATION.AUTHORIZATIONID.PL'
call rtDef '00001005', 'DB access agent', 'LOCATION'
call rtDef '00001007', 'TCP/IP domain name', 'LINKNAME.DOMAIN.ERRNO'
call rtDef '00001008', 'TCP/IP service name', 'LOCATION.SERVICE.ERRNO'
call rtDef '00001080', 'ACCEL', 'SERVER.DOMAIN'
call rtDef '00001102', 'Bootstrap data set (BSDS)', 'MEMBER'
call rtDef '00002000', 'Table space CS-claim class', 'DB.SP'
call rtDef '00002001', 'Table space RR-claim class', 'DB.SP'
call rtDef '00002002', 'Table space write-claim class', 'DB.SP'
call rtDef '00002003', 'Index space CS-claim class', 'DB.SP'
call rtDef '00002004', 'Index space RR-claim class', 'DB.SP'
call rtDef '00002005', 'Index space write-claim class', 'DB.SP'
call rtDef '00002006', 'Table space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002007', 'Table space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002008', 'Table space partition write-claim class',
, 'DB.SP.PT'
call rtDef '00002009', 'Index space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002010', 'Index space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002011', 'Index space partition Write-claim class',
, 'DB.SP.PT'
call rtDef '00002100', 'Table space DBET entry', 'DB.SP'
call rtDef '00002101', 'Index space DBET entry', 'DB.SP'
call rtDef '00002102', 'Table space partition DBET entry', 'DB.SP.PT'
call rtDef '00002103', 'Index space partition DBET entry', 'DB.SP.PT'
call rtDef '00002104', 'DBET hash chain lock timeout',
, 'INTERNAL LOCK NN'
call rtDef '00002105', 'Logical partition DBET entry', 'DB.SP.PT'
call rtDef '00002200', 'Routine Parameter Storage', 'DBP'
call rtDef '00002201', 'm.debug Agent Storage', 'DBP'
call rtDef '00002300', 'ICSF encryption and decryption facilities'
call rtDef '00003000', 'Code (release maintenance_level or system' ,
'parameter)', 'REL,APAR,ZPARM'
call rtDef '00003002', 'Number of Stored Procedures'
call rtDef '00003072', 'Index'
call rtDef '00003073', 'Index'
call rtDef '00003328', 'Release dependency'
call rtDef '00003329', 'DBID/OBID', 'DI.OI'
call rtDef '00003330', 'OBID limit exceeded'
call rtDef '00003840', 'LOB column'
call rtDef '00004000', 'Profile exception threshold exceeded',
, 'PID.PTYPE.PNAME'
return
endProcedure resourceTypeIni
rtDef: procedure expose m.
parse arg cd, nm, pa
if symbol('m.resourceType.cd') <> 'VAR' then
m.resourceType.cd = nm
m.resourceTypeParms.cd = pa
return
endProcedure rtDef
getDbidObid: procedure expose m.
parse arg dbSys, dbid, obid
SQL_DBID = STRIP(dbid,L,0)
SQL_OBID = STRIP(obid,L,0)
if symbol('m.id2n.dbSys.dbidObid.dbid.obid') == 'VAR' then
/* haben es schon mal gefunden*/
return m.id2n.dbSys.dbidObid.dbid.obid
/* select from catalog */
/* from sysTables */
if dbSys \== m.sql_dbSys then do
if m.sql_dbSys \== '' then
call sqlDisconnect
if m.tstRZ4 then
if sysvar(sysNode) = 'RZ4' ,
& wordPos(dbSys, 'DP4G DBOL') < 1 then
return ''
call sqlConnect dbSys
end
res = sql2One("SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROm SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One("SELECT ",
" STRIP(DBNAME,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One( "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
m.dbidObid.dbid.obid = res
return m.dbidObid.dbid.obid
endProcedure getDbidObid
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM60A1
¨¨_________________________________________________________________________
*/
INSERT_TADM60A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM60A1..."
cIns = 0
cDead = 0
cTime = 0
say ' ' time() 'begin insert into tadm60a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM60A1 (" ,
"TIMESTAMP, ssid, event_type," ,
"VICTIM_PLAN, VICTIM_CORR_ID, VICTIM_COnn_ID," ,
"SOURCE_PLAN, SOURCE_CORR_ID, SOURCE_COnn_ID," ,
"REASON_CODE, type, name )" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
do tx=1 to m.to.0
/*______________________________________________________________________
row überspringen falls alt
*/
if (m.to.tx.evTy == 'D' & m.to.tx.tst <= m.lastDeadlock ) ,
|(m.to.tx.evTy == 'T' & m.to.tx.tst <= m.lastTimeout ) then
iterate
call sqlUpdArgs 7,
, m.to.tx.tst, m.to.tx.v.dbMb, m.to.tx.evTy,
, m.to.tx.v.plan, m.to.tx.v.corr, m.to.tx.v.conn,
, m.to.tx.h.plan, m.to.tx.h.corr, m.to.tx.h.conn,
, m.to.tx.reason, m.to.tx.type, m.to.tx.name
cIns = cIns + 1
cDead = cDead + (m.to.tx.evTy == 'D')
cTime = cTime + (m.to.tx.evTy == 'T')
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm60a1,' ,
cDead 'deadlocks and' cTime 'timeouts'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM60A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM63A1
¨¨_________________________________________________________________________
*/
INSERT_TADM63A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM63A1..."
say ' ' time() 'begin insert into tadm63a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM63A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"CORRID_ID," ,
"CONN_ID," ,
"AUTHID," ,
"LOGREC)" ,
"VALUES (?,?,?,?,?,?,?,?)"
cIns = 0
cUOW = 0
cCHK = 0
do tx=1 to m.uow.0
ux = 'UOW.'tx
if m.ux.UC == 'U' & m.ux.tst <= m.lastUOW then
iterate
if m.ux.UC == 'C' & m.ux.tst <= m.lastCheckp then
iterate
cIns = cIns + 1
cUOW = cUOW + (m.ux.UC == 'U')
cCHK = cCHK + (m.ux.UC == 'C')
call sqlUpdArgs 7,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.UC,
,m.ux.plan,
,m.ux.corr,
,m.ux.conn,
,m.ux.authid,
,m.ux.logRecs
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm63a1,' ,
cUOW 'uncommitedUOW and' cCHK 'checkpoints'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM63A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM64A1
¨¨_________________________________________________________________________
*/
INSERT_TADM64A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM64A1..."
say ' ' time() 'begin insert into tadm64a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM64A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"PACKAGE_NAME," ,
"COLLECTION_ID," ,
"CORRID_ID," ,
"CONN_ID," ,
"RESOURCE," ,
"LOCK_STATE," ,
"STATEMENT)" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.LoEs.0
ux = 'LOES.'tx
if m.ux.tst <= m.lastLockesc then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.E,
,m.ux.plan,
,m.ux.package,
,m.ux.CollID,
,m.ux.corr,
,m.ux.conn,
,m.ux.resource,
,m.ux.LckSt,
,m.ux.Statement
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm64a1,' ' LOCK ESCALATION'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM64A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM65A1
¨¨_________________________________________________________________________
*/
INSERT_TADM65A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM65A1..."
say ' ' time() 'begin insert into tadm65a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM65A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"CORRID_ID," ,
"JOBNAME," ,
"CONN_ID," ,
"AUTHID," ,
"ASID," ,
"TCB)" ,
"VALUES (?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.ReEot.0
ux = 'REEOT.'tx
if m.ux.tst <= m.lastReadEot then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.A,
,m.ux.corr,
,m.ux.Jobname,
,m.ux.conn,
,m.ux.AuthID,
,m.ux.AsID,
,m.ux.tcb
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm65a1,' ' ABNORMAL EOT'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM65A1..."
RETURN;
/*-- quote text t with apostrophs (sql string)
truncate if longer then 18 characters ---------------------------*/
cut18: procedure expose m.
parse arg t
if length(t) <= 18 then
return t
else
return left(space(t, 1), 18)
endProcedur cut18
/*----------------------------------------------------------------*/
/*--------- AUSGEBEN VON SQL-FEHLERBESCHREIBUNG SQLCA ------------*/
/*----------------------------------------------------------------*/
SQLCA:
IF m.debug THEN SAY "ENTER PROCEDURE SQLCA..."
parse ARG msg
ggSqlStmt = sqlText
call err msg sqlMsg()
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/*_____________________________________________________________________
¨¨
¨¨ DSN erstellen für RZ4
¨¨_____________________________________________________________________
*/
writeAblfAll: procedure expose m.
parse arg pre
call writeAblf to, fftimeO, pre'.TADM60A1'
call writeAblf uow, ffUow, pre'.TADM63A1'
call writeAblf Loes, ffLockE, pre'.TADM64A1'
call writeAblf ReEot, ffEOT, pre'.TADM65A1'
return 0
endProcedure writeAblfAll
writeAblf: procedure expose m.
parse arg st, ff, dsn
/*______________________________________________________________________
¨¨
¨¨new dsn write
¨¨______________________________________________________________________
*/
do sx=1 to m.st.0
o.sx = csv4obj(st'.'sx, ff, 0)
end
dsn=dsn'.D'date('j')'.T'translate(124578, time(), 12345678)
call writeDsn dsn '::v300', 'O.', m.st.0, 1
return
endProcedure writeAblf
newDSN: procedure expose dsnRZ4.
/*
dsnRZ4.1='DSN.ABLF.LOGEX.DE0G.TADM60A1'
dsnRZ4.2='DSN.ABLF.LOGEX.DE0G.TADM63A1'
dsnRZ4.3='DSN.ABLF.LOGEX.DE0G.TADM64A1'
dsnRZ4.4='DSN.ABLF.LOGEX.DE0G.TADM65A1'
address tso
do i=2 to 4
ok#dsn=SYSDSN("'"dsnRZ4.i"'")
IF ok#dsn = 'OK' then do
SAY 'DSN EXISTS WIRD GELÖSCHT'OK#DSN' = 'dsnRZ4.i
"DELETE '"dsnRZ4.i"'"
if RC>0 then say 'DSN konnte nicht gelöscht werden'
END
/*ok#dsn=SYSDSN("'"dsnRZ4.i"'")
*/ y=0
do until (fb=0 | y>2 )
"ALLOC DDNAME(DDN"i") DSN('"dsnRZ4.i"') new lrecl(160) recfm(f b)"
fb=rc;y=y+1
if fb>0 then do
"FREE DDNAME(DDN"i")"
end
end
end
*/
return
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_rz = ''
m.ii.rzC = ''
i = 'RZ1 1 S1 DBTF T DTF DVTB V DTB DBOC C DOC' ,
'RZ2 2 S2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RR2 R R2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RQ2 Q Q2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RZ4 4 S4 DBOL O DOL DP4G U DP4' ,
'RZX X X2 DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'RZY Y Y2 DE0G E DE0 DEVG M DEV DPYG Y DPY' ,
'RZZ Z Z2 DE0G E DE0 DEVG M DEV DPZG N DPZ'
m.ii_rz = ''
m.ii_rzC = ''
do wx=1 by 3 to words(i)
parse value subWord(i, wx, 3) with w1 w2 w3
if abbrev(w1, 'R') & length(w1) == 3 then do
rz = w1
m.ii_DbSys.rz = ''
m.ii_rz = strip(m.ii_rz rz)
m.ii_rzC = m.ii_rzC || w2
call iiA1 ii_sys2rz, w3, rz
call iiA1 ii_rz2c, rz, w2
end
else if abbrev(w1, 'D') & length(w1) == 4 then do
m.ii_DbSys.rz = strip(m.ii_DbSys.rz w1)
call iiA1 ii_db2c, w1, w2
call iiA1 ii_mbr2db, w3, w1
call iiA1 ii_db2Elar, w1, wordPos(w1, 'DVTB DVBP DEVG')>0
end
else
call err 'bad w1' w1 w2 w3
end
return
endProcedure iiIni
iiA1: procedure expose m.
parse arg st, key ,val
if symbol('m.st.key') \== 'VAR' then
m.st.key = val
else if m.st.key \== val then
call err 'already <> defined' st'.'key'='m.st.key 'val='val
return
endProcedure iiA1
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiRz2C
iiRzDbSysBegin:procedure expose m.
parse arg m
call iiIni
m.m.rx = 1
m.m.dx = 0
return
endProcedure iiRzDbSysBegin
iiRzDbSys:procedure expose m.
parse arg m
do forever
rz = word(m.ii_rz, m.m.rx)
if rz == '' then do
call vPut 'rz', ''
call vPut 'dbSys', ''
return 0
end
m.m.dx = m.m.dx+1
db = word(m.ii_dbSys.rz, m.m.dx)
if db == '' then do
m.m.rx = m.m.rx + 1
m.m.dx = 0
iterate
end
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
end
endProcedure iiRzDbSys
/* copy ii end ********* Installation Info *************************/
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err 'implement rxFetchVars ?' /* ?????????????
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
ret = left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
return ret
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXDB2LO2) cre=2015-10-08 mod=2015-10-08-10.40.45 A540769 ---
/* REXX
¨¨____________________________________________________________________
¨¨
¨¨ EXDB2LOG
¨¨ --------
¨¨ read mastlog output and insert the messages into tadm6* tables
¨¨
¨¨ PARMS EXDB2LOG <PARM1>
¨¨ PARM1 = DB2 SUBSYSTEM
¨¨
¨¨ LOCATION DSN.DB2.EXEC ab 4.0
¨¨ TSO.rz?.P0.USER.EXEC bis 3.1
¨¨
¨¨ HISTORY:
¨¨ 7.10.2015 V4.2 added support for jes2
¨¨ 2.10.2015 V4.1 for timeout also use DSNT500I and store
¨¨ these even without deadlock/timeout
¨¨ 20.10.2014 V4.0 logE2 => logEx
¨¨ 06.10.2014 V4.0 direkt aus Beta/eJes Extract DSNs lesen
¨¨ member/Datum aus IAT6140 usw.
¨¨ keine doppelte Ausgabe von Beta/eJes Logs
¨¨ 09.04.2014 V3.1 Ergebnis zusätzlich ins DSN
¨¨ 24.09.2012 V3.0 rewrite masterlog
¨¨ 18.04.2012 V2.2 rz8 und rzz integriert
¨¨ 17.04.2012 V2.1 truncate collids longer 18
¨¨ 28.03.2008 V2.0 ABNORMAL EOT (G.KERN,A914227)
¨¨ 27.03.2008 V1.1 UNCOMMITED UOW (G.KERN,A914227)
¨¨ 27.03.2008 V1.2 CHECKPOINTS (G.KERN,A914227)
¨¨ 27.03.2008 V1.3 LOCK ESCALATION (G.KERN,A914227)
¨¨ 30.01.2008 V1.0 GRUNDVERSION (G.KERN,A914227)
¨¨
¨¨_____________________________________________________________________
*/
call errReset 'h'
PARSE UPPER arg SSID rest
if 0 then do /* prod settings */
m.debug = 0
m.tstRZ4 = 0
m.writeAblfPre = 'DSN.ABLF.LOGEX.'sysvar(sysnode)
end
else if 1 then do /* test settings */
m.debug = 0
m.tstRZ4 = 1
m.writeAblfPre = 'A540769.LOGEX.ABLF'
end
else if 0 then do /* old settings */
m.debug = 1
m.insertLocal = 1
m.writeABLF = 1
end
say "exDb2Log("ssid rest") version v4.2 vom 7.10.15"
if ssid == 1 then
return doFun1()
else if ssid == 2 then
return doFun2(rest)
else if ssid == 3 then
return doFun3()
else if 0 then
return workOld(ssid)
else do
o.1 = date('s') time() sysVar(sysNode) mvsvar('symdef', 'jobname') ,
'exDb2Log workOld deActivated'
call writeDsn 'mod dsn.ablf.logDeImp ::f', o., 1
say 'exDb2Log workOld deActivated'
return 0
end
endMainCode
/*-------------- alte Verarbeitung -----------------------------------*/
workOld:
parse arg ssid
call ini 0
/*_____________________________________________________________________
¨¨
¨¨ VARIABLEN INITIALISIEREN
¨¨_____________________________________________________________________
*/
m.tadmDbSy = ''
m.lastDeadlock = ''
m.lastTimeout = ''
m.tadmCreator = ''
/*_____________________________________________________________________
¨¨
¨¨ HAUPTPROGRAMM
¨¨_____________________________________________________________________
*/
SAY "DB2 SUBSYSTEM = "SSID
CALL OWNER_SSID_ZUWEISEN ssid /* ZUWEISEN OWNER & SSID FÜR SQL */
CALL sqlConnect ssid /* DB2 SUBSYSTEM VERBINDEN */
CALL readMstrLog /* INPUT-DS lesen und analysieren */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
if m.insertLocal then do
CALL sqlConnect m.tadmDbSy /* DB2 SUBSYSTEM VERBINDEN */
CALL GET_MAX_WERT_TIMEOUT /* MAX TIMEOUT vON TABELLE LESEN */
CALL GET_MAX_WERT_DEADLOCK /* MAX DEADLOCK VON TABELLE LESEN */
CALL GET_MAX_WERT_uncommittedUOW /* MAX uncommittedUOW */
CALL GET_MAX_WERT_CHECKPNT /* MAX CHECKPNT VON TABELLE Lesen */
CALL GET_MAX_WERT_LOCKESCA /* MAX LOCKESCA VON TABELLE Lesen */
CALL GET_MAX_WERT_EOT /* MAX EOT EINTRAG VON TABELLE LESEN */
CALL INSERT_TADM60A1 /* deadlocks und timeouts */
CALL INSERT_TADM63A1 /* uncommitted UOW */
CALL INSERT_TADM64A1 /* LOCK ESCALATION */
CALL INSERT_TADM65A1 /* abnormal eot */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
end
if m.writeABLF then /* write dsn für ABLF */
call writeAblfAll m.writeAblfPre'.'ssid
return 0
endSubroutine workOld
/*--- write timestamp to dd parmNew ----------------------------------*/
doFun1: procedure expose m.
parse arg betaExt .
call ini 1
call readDD parmOld, i., '*'
call tsoClose parmOld
ix = i.0
say 'parmOld' ix strip(i.ix, 't')
w1 = word(i.ix, 1)
if i.0 = 0 then
old = '2014-01-01-00.00.00'
else if translate(w1, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad to tst in parmOld 1:' i.ix
else if substr(w1, 15, 2) >= 15 then
old = overlay(right(substr(w1, 15, 2)-15, 2,0), w1, 15)
else if substr(w1, 12, 2) >= 1 then
old = overlay(right(substr(w1, 12, 2)-1, 2,0) ,
|| '.'right(substr(w1, 15, 2)+45, 2,0), w1, 12)
else
old = left(w1, 11)'00.00.00'
new = translate('1234-56-78', date('s'), '12345678') ,
|| '-'translate(time(), '.', ':')
if new <= old then
call err 'new' new '<=' old 'old'
o.1 = new old
call writeDD parmNew, o., 1
call tsoClose parmNew
say 'parmNew' strip(o.1, 't')
if substr(old, 6, 2) > 2 then
betaS = overlay(right(substr(old, 6, 2)-2, 2,0), old, 6)
else
betaS = overlay(left(old, 4)-1,
|| '-'right(substr(old, 6, 2)+10, 2,0), old, 1)
if substr(betaS, 9, 2) > 28 then
betaS = overlay(28, betaS, 9)
betaS = translate('78.56.1234', left(betaS, 10), '1234-56-78')
say 'betaStart' betaS 'betaExt' betaExt
o.1 = 'REPORT'
o.2 = ' SDATE('betaS')'
o.3 = ' STIME(00:00:00)'
o.4 = ' PDATE(TODAY)'
o.5 = ' PTIME(23:59:59)'
o.6 = ' JOBNAME(D***MSTR)'
call writeDD betaRePa, o., 6
call tsoClose betaRePa
a.1 = ' 00:00:00 ' /* idiotisches Rexx stuerzt ab auf leerem
konatiniertem Dataset | */
call writeDD 'betaExt', a., 1
call tsoClose 'betaExt'
call writeDD 'eJesExt', a., 1
call tsoClose 'eJesExt'
say 'written idiotic dummy row on betaExt and eJesExt'
call eJesJobExtDD 'D%%%MSTR', 'JESMSGLG'
return 0
endProcedure doFun1
/*--- select jobs from betaRep ---------------------------------------*/
doFun2: procedure expose m.
parse arg betaExt .
call ini 1
say 'fun2' betaExt
call parmNewRead
new = m.parm_new
old = m.parm_old
call readDD betaRep, b., '*'
call tsoClose betaRep
say 'dd betaRep' b.0 'lines'
do bx=1 to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' then do
bx = bx + 1
if substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' then
leave
end
if pos('NO JOBS MATCHED SELECTION', b.bx) > 0 then do
say 'no jobs in Beta report:' b.bx
return 4
end
end
if bx > b.0 then
call err 'no title found in betaRep'
say b.bx
cJ = 2
cI = 11
cE = pos(' END DATE ', b.bx)
eE = cE + 10
cF = pos(' END TIME ', b.bx) + 1
eF = cF+8
m.o.0 = 0
if cE < 20 | cF < 20 then
call err 'bad end time/date in beta title' b.bx
cS = pos(' SUB DATE ', b.bx)
eS = cS + 10
cT = pos(' SUB TIME ', b.bx) + 1
eT = cT+8
m.o.0 = 0
m.f.0 = 0
if cS < 20 | cT < 20 then
call err 'bad end time/date in beta title' b.bx
jx = 0
jy = 0
do bx=bx to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' ,
| abbrev(substr(b.bx, 2), '-----') ,
| abbrev(substr(b.bx, 2), '=====') ,
| substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' ,
| abbrev(substr(b.bx, 2), 'PROGRAM B92BFJBR ') then
iterate
if pos(' JOB(S) MATCHED SELECTI', b.bx) > 0 then do
jz = word(substr(b.bx, 2), 1)
iterate
end
say b.bx
parse var b.bx 2 vJ 10 11 vI 19 ,
=(cS) vS =(eS) =(cT) vT =(eT) ,
=(cE) vE =(eE) =(cF) vF =(eF)
if translate(vE, '999999999', '012345678') \== '99.99.9999' then
call err 'bad end date' vE 'in line' bx':' b.bx
if translate(vF, '999999999', '012345678') \= '99:99:99' then
call err 'bad end time' vF 'in line' bx':' b.bx
vG = translate('1234-56-78', vE, '78.56.1234') ,
|| '-'translate(vF, '.', ':')
jx = jx + 1
if vG << old then
iterate
jy = jy + 1
say ' selected' vJ vI', ended' vG '>>=' old 'old'
call mAdd f, 'BFIND' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' OPERATOR(OR)' ,
, ' OPTIONS(FIRST)' ,
, ' SCOPE(BOTH)' ,
, ' MESSAGE(LONG)' ,
, ' RELOAD(YES)' ,
, ' MIXEDMODE(NO)' ,
, ' SLINE(0)' ,
, ' PLINE(0)' ,
, ' STRING1(DATE)'
call mAdd o, 'PRINT' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' MASK(MM/DD/YY)' ,
, ' AUTOSEL(NO)' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' MESSAGE(LONG)' ,
, ' SCOPE(BOTH)' ,
, ' DISPOSITION(MOD)' ,
, ' DATASET('betaExt')'
end
if jx <> jz then
call err jx 'jobs read not' jz 'as beta says'
say jy 'jobs selected from' jz 'in list'
call writeDD betaExPa, 'M.O.'
call tsoClose betaExPa
call writeDD betaFiPa, 'M.F.'
call tsoClose betaFiPa
return 4 * (jy = 0)
endProcedure doFun2
/*--- read concatenated master logs and write load files -------------*/
doFun3: procedure expose m.
call ini 1
call parmNewRead
call readMstrLog
call writeAblfAll m.writeAblfPre
return 0
endProcedure doFun3
/*--- read parmNew, extract new and old timestamp --------------------*/
parmNewRead: procedure expose m.
call readDD parmNew, n., '*'
call tsoClose parmNew
parse var n.1 new old .
say 'parmNew' new old
if n.0 < 1 then
call err 'empty parmNew'
else if translate(new, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad new in parmNew:' new
else if translate(old, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad old in parmNew:' old
else if new <= old then
call err 'new <= old' new old
m.parm_new = new
m.parm_old = old
return
endProcedure parmNewRead
/*_____________________________________________________________________
¨¨
¨¨ OWNER UND SSID FÜR SQL ABFRAGE ZUWEISEN
¨¨_____________________________________________________________________
*/
OWNER_SSID_ZUWEISEN: procedure expose m.
parse arg ssid
IF m.debug THEN SAY "ENTER PROCEDURE OWNER_SSID_ZUWEISEN..." ssid
SELECT
WHEN SSID = 'DBTF' THEN info = 'DTF OA1T DBTF'
WHEN SSID = 'DBOC' THEN info = 'DOC OA1T DBTF'
WHEN SSID = 'DVTB' THEN info = 'DTB OA1T DBTF'
WHEN SSID = 'DP2G' THEN info = 'DP2 OA1P DP2G' /* rz2 */
WHEN SSID = 'DBOF' THEN info = 'DOF OA1P DP2G'
WHEN SSID = 'DVBP' THEN info = 'DBP OA1P DP2G'
WHEN SSID = 'DC0G' THEN info = 'DC0 OA1P DC0G' /* rz8 */
WHEN SSID = 'DCVG' THEN info = 'DCV OA1P DCVG'
WHEN SSID = 'DD0G' THEN info = 'DD0 OA1P DD0G'
WHEN SSID = 'DDVG' THEN info = 'DDV OA1P DDVG'
WHEN SSID = 'DX0G' THEN info = 'DX0 OA1P DX0G'
WHEN SSID = 'DP8G' THEN info = 'DP8 OA1P DP8G'
WHEN SSID = 'DE0G' THEN info = 'DE0 OA1P DE0G' /* rzz */
WHEN SSID = 'DEVG' THEN info = 'DEV OA1P DEVG'
OTHERWISE call err "bad ssid = '"ssid"'"
END
parse var info m.db2Member3 m.tadmCreator m.tadmDbSy .
if m.wkTest then do
m.tadmCreator = A540769
m.tadmDbSy = 'DBAF'
if ssid = 'DVBP' then ssid = 'DBTF'
say '?????? wktest run' m.tadmDbSy
end
if m.acTest then do
m.tadmCreator = A754048
m.tadmDbSy = 'DE0G'
if ssid = '' then ssid = 'DE0G'
say '?????? actest run' m.tadmDbSy
end
say ' ssid' ssid 'member' m.db2Member3'?',
'to' m.tadmDbSy':'m.tadmCreator'.TADM6*A1'
IF m.debug THEN SAY "LEAVE PROCEDURE OWNER_SSID_ZUWEISEN..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX TIMEOUT WERT VON TADM60A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_TIMEOUT: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_TIMEOUT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'T' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C3 CURSOR FOR S3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S3 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C3 INTO :m.lastTimeout :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX TIMEOUT TIMESTAMP FOR" SSID "IS:" m.lastTimeout
ADDRESS DSNREXX "EXECSQL CLOSE C3"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_TIMEOUT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX DEADLOCK WERT VON TADM60A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_DEADLOCK: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_DEADLOCK..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'D' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C2 CURSOR FOR S2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S2 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C2 INTO :m.lastDeadlock :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX DEADLOCK TIMESTAMP FOR" SSID "IS:" m.lastDeadlock
ADDRESS DSNREXX "EXECSQL CLOSE C2"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_DEADLOCK..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX uncommittedUOW WERT VON TADM63A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_uncommittedUOW:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_uncommittedUOW..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'U' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C7 CURSOR FOR S7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S7 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C7 INTO :m.lastUOW :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX UNCOMMITTED UOW TIMESTAMP FOR" SSID "IS:" m.lastUOW
ADDRESS DSNREXX "EXECSQL CLOSE C7"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_uncommittedUOW..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX CHECKPNT WERT VON TADM63A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_CHECKPNT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_CHECKPNT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'C' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C9 CURSOR FOR S9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S9 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C9 INTO :m.lastCheckp :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX CHECKPOINT TIMESTAMP FOR" SSID "IS:" m.lastCheckp
ADDRESS DSNREXX "EXECSQL CLOSE C9"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_CHECKPNT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX LOCKESCA WERT VON TADM64A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_LOCKESCA:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_LOCKESCA..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM64A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'E' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C10 CURSOR FOR S10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S10 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C10 INTO :m.lastLockesc :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX LOCK ESCALATION TIMESTAMP FOR" SSID "IS:" m.lastLockesc
ADDRESS DSNREXX "EXECSQL CLOSE C10"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_LOCKESCA..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ MAX EOT WERT VON TADM65A1 LESEN
¨¨_____________________________________________________________________
*/
GET_MAX_WERT_EOT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_EOT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM65A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'A' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C12 CURSOR FOR S12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S12 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C12 INTO :m.lastReadEot :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX ABNORMAL EOT TIMESTAMP FOR" SSID "IS:" m.lastReadEot
ADDRESS DSNREXX "EXECSQL CLOSE C12"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_EOT..."
RETURN
/*_____________________________________________________________________
¨¨
¨¨ read the whole master log
¨¨ and analyse each interesting msg
¨¨_____________________________________________________________________
*/
readMstrLog:
call logMsgBegin rd
m.to.0 = 0
m.uow.0 = 0
m.LoEs.0 = 0
m.ReEot.0 = 0
do mx=1
mid = logMsg(rd)
if mid == '' then do
if m.info.jobKey \== '' then
call finishJob rd
say 'readMstrLog end:' readNxPos(rd)
call readNxEnd rd
return
end
else if m.info.tst <<= m.info.doneUntil then
nop /* already done yesterday or eJes <-> beta92 */
else if mid == 'DSNT375I' then
call anaTimeoutDeadlock rd, info, 'D'
else if mid == 'DSNT376I' then
call anaTimeoutDeadlock rd, info, 'T'
else if mid == 'DSNT500I' | mid == 'DSNT501I' then
call anaResourceNotAvailable rd, info, mid
else if mid == 'DSNJ031I' then
call anaUncommittedUOW rd, info, 'U'
else if mid == 'DSNR035I' then
call anaUncommittedUOW rd, info, 'C'
else if mid == 'DSNI031I' then
call anaLockEscalation rd, info, 'E'
else if mid == 'DSN3201I' then
call anaReadEot rd, info, 'A'
end
endProcedure readMstrLog
/*_____________________________________________________________________
¨¨
¨¨ if this is not a dsn message return ''
¨¨ otherwise, check it, collect infos into info and return id
¨¨_____________________________________________________________________
*/
logMsgBegin: procedure expose m.
parse arg rd
call readNxBegin rd, '-', 'DDIN1'
do until m.li <> ' 00:00:00' & m.li <> ''
li = readNx(rd)
end
m.info.doneUntil = m.parm_old
m.info.head = left('? ^ # no no', 300, '}')
m.info.jobKey = ''
m.mOld = ''
m.rd.curIsMsg = 1
m.cLogMsg = 0
m.cCont = 0
m.cContCx = 0
m.cTONF = 0
m.cTONFX = 0
m.cTOFo = 0
m.cTOFoX = 0
return
endProcedure logMsgBegin
logMsg: procedure expose m.
parse arg rd
m.cLogMsg = m.cLogMsg+1
li = readNxCur(rd)
if li == '' then
return ''
line = m.li
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
return logMstr(rd, line)
end
else if substr(strip(line), 1, 39) ,
== 'J E S 2 J O B L O G -- S Y S T E M ' then do
m.rd.jes2 = 1
m.info.j2Id = ''
return logMstr(rd, line)
end
if m.rd.jes2 then do
if translate(substr(line, 1, 9), '999999999', '012345678') ,
\== '99.99.99 ' then do
if line = '------ JES2 JOB STATISTICS ------' then do
m.info.mid = '----stat'
/* achtung (unknown) hat space mehr | */
do cx=1 until li == '' | substr(m.li, 11, 3) = ' ' ,
| substr(m.li, 14, 1) <> ' ' ,
| substr(m.li, 15, 3) = ' '
m.rd.cc.cx = m.li
li = readNx(rd)
end
m.rd.cc.0 = cx
return m.info.mid
end
else
call err 'bad time in jes2 line' readNxPos(rd)
end
m.info.time = word(line, 1)
w2 = substr(line, 10, 8)
if w2 \== m.info.j2Id then do
if w2 = '' then
say 'jes2 empty id ???' readNxPos(rd)
else if m.info.j2Id \== '' then
call err 'jes2 id mismach' m.info.j2Id ,
'<>' readNxPos(rd)
else if pos(' ', w2) > 0 then
call err 'bad jes2 id' w2 'in' readNxPos(rd)
else
m.info.j2Id = w2
end
if substr(line, 18, 1) \== ' ' then
call err 'bad jes2 line' readNxPos(rd)
else if substr(line, 18, 6) == ' ---- ' then do
if word(line, 8) \== '----' then
call err 'bad jes2 ---- line' readNxPos(r)
call anaCurDate info, subword(substr(line, 24), 2, 3)
m.info.mid = '----date'
end
else do
m.info.mid = word(line, 3)
end
m.info.tst = m.info.date'-'m.info.time
call logMsgContJes2 rd, line
end
else do
if translate(substr(line, 1, 10), '999999999', '012345678') ,
\== ' 99:99:99 ' then
call err 'bad time in jes3 line' readNxPos(rd)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if substr(line, 10, 14) == ' ---- IAT6853 ' then do
if substr(line, 24, 20) \== 'THE CURRENT DATE IS ' then
call err 'bad IAT6853' readNxPos(rd)
call anaCurDate info, subword(substr(line, 44), 2, 3)
m.info.mid = 'IAT6853'
end
else do
m.info.mid = word(line, 2)
end
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
call logMsgContJes3 rd, line
end
if m.info.mid = '' then
return '?'
else
return m.info.mid
endProcedure logMsg
logMsgContJes2: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
if translate(right(line, 5), 000000000,123456789)== ' 000' then do
mSeq = right(line, 3)
m.mOld = mSeq subWord(m.mOld, 1, 49)
m.rd.cc.1 = substr(line, 19, length(line)-23)
end
else do
mSeq = ''
m.rd.cc.1 = substr(line, 19)
end
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
else if mSeq \== '' & left(m.li, 19) = ' 'mSeq then do
cx = cx + 1
m.rd.cc.cx = substr(m.li, 19)
end
else if translate(left(m.li, 19), 000000000, 123456789) ,
= ' 000' then do /* out of sequence look next */
/* ??? ix = wordPos(substr(m.li, 4, 3), m.mOld)
if symbol('m.igno.ix') == 'VAR' then
m.igno.ix = m.igno.ix + 1
else
m.igno.ix = 1
if ix < 1 then
say 'ignoring after' m.info.mid'#'mSeq readNxPos(rd)
??? */ end
else if m.li = ' 00:00:00' then do
end /* ignore marker from fun1 */
else
leave
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes2
logMsgContJes3: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
m.rd.cc.1 = substr(line, 10)
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
if \ abbrev(m.li, m.info.head) then do
if translate(substr(m.li, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then
leave
if translate(substr(m.info.head 2, 9) ,
, '999999999', '012345678') \== '99:99:99 ' then
leave
ds =((( substr(m.li, 2, 2) * 60) ,
+ substr(m.li, 5, 2) * 60) ,
+ substr(m.li, 8, 2)) ,
-((( substr(m.info.head, 2, 2) * 60) ,
+ substr(m.info.head, 5, 2) * 60) ,
+ substr(m.info.head, 8, 2))
if ds < 0 | ds > 3 then
leave
end
if substr(m.li, 10, 14) == ' ---- IAT6853 ' then
leave
vx = verify(m.li, ' ', 'N', 10)
if vx = 11 | vx = 12 then do
w2 = word(m.li, 2)
if (length(w2) == 7 | length(w2) == 8) ,
& verify(w2, m.ut_alfUCNum) = 0 then
if wordPos(left(w2, 3), 'IAT ACF DSN IEF IXL') > 0 then
leave
end
cx = cx + 1
m.rd.cc.cx = substr(m.li, 10)
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes3
finishJob: procedure expose m.
parse arg rd
if m.info.jobKey == '' then
return
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
if m.rd.jes2 then
j = 'jes2'
else
j = 'jes3'
say j m.info.job jKy 'to' m.info.tst p
/* ????
ii = ''
o ix=0 to 99
if symbol('m.igno.ix') == 'VAR' then
ii = ii ix'='m.igno.ix
end
say ii
say 'logMsg='m.cLogMsg 'cont='m.cCont 'contCx='m.cContCx,
'toNf='m.cTONf 'toNFX='m.cTONfX 'toFo='m.cTOFo 'toFoX='m.ctoFoX
??? */
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' | jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
return
endProcedure finishJob
logMstr: procedure expose m.
parse arg rd, line
call finishJob rd
m.info.dateTst = ''
do until m.li <> ''
li = readNx(rd)
end
do lx=1 to 50
mid = logMsg(rd)
if mid = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if mid == 'IEF403I' then do
j1 = word(m.rd.cc.1, 2)
s1 = word(m.rd.cc.1, words(m.rd.cc.1))
end
else if mid == 'DSNY024I'then do
m2 = substr(word(m.rd.cc.1, 2), 2)
leave
end
else if abbrev(mid, 'DSN') then do
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return mid
isDsnMsg: procedure expose m.
parse arg line, info
if m.modeNew? then do
if translate(substr(line, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then do
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
call err 'bad line' line
s1 = ''
m2 = ''
if m.info.jobKey \== '' then do
call sayJobEnd info
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' ,
| jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
end
m.info.dateTst = ''
do lx=1 to 50
ln = readNx(rd)
if ln = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if translate(substr(m.ln, 2, 9), '999999999',
, '012345678') \== '99:99:99 ' then do
say 'bad start of mstrLog after' line
say ' @' readNxPos(rd)
return isDsnMsg(m.ln, info)
end
if word(m.ln, 2) == 'IEF403I' then do
j1 = word(m.ln, 3)
s1 = word(m.ln, words(m.ln))
end
else do
d2 = isDsnMsg(m.ln, info)
if d2 = 'DSNY024I' then do
m2 = substr(word(m.ln, 3), 2)
leave
end
else if d2 \== '' then
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return ''
end
mid = word(line, 2)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
return ''
end
end
else do
mid = word(line, 4)
parse var line m.info.dbMb m.info.date m.info.time .
m.info.dbSys = iiMbr2DbSys(m.info.dbMb)
if \ abbrev(mid, 'DSN') | wordIndex(line, 4) <> 29 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 5) = 'IAT6853' then
call anaCurDate info, substr(line,18), word(line,2)
m.info.wxTime = 3
m.info.cxTime = 19
return ''
end
m.info.head = left(line,27)
end
/* diese Prüfung ist falsch, manche displays zeigen --------------
Infos aus anderen membern an, z.B. -dis indoubt ......
aMbr = word(line, 5)
if abbrev(aMbr, '-') then
if '-'m.info.dbMb \== aMbr then
call err 'dbMember mismatch:' m.info.dbMb ,
'<>' readNxPos(rd) -----------------------------*/
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
return mid
endProcedure isDsnMsg
sayJobEnd: procedure expose m.
parse arg info
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
say 'job' m.info.job jKy 'to' m.info.tst p
return
endProcedure say JobEnd
/*_____________________________________________________________________
¨¨
¨¨ analyse current date in iat6853 message
¨¨ and check that it equals the header
¨¨_____________________________________________________________________
*/
anaCurDate: procedure expose m.
parse arg info, d1, compD
d2 = word(d1, 1) ,
translate(left(word(d1, 2), 1)),
|| translate(substr(word(d1, 2), 2),
, m.ut_AlfLC, m.ut_AlfUC) ,
word(d1, 3)
do while abbrev(d2, 0) /* date does not accept leading zeroes ||||| */
d2 = substr(d2, 2)
end
d3 = date('s', d2)
m.info.date = translate('1234-56-78', d3, '12345678')
m.info.dateTst = m.info.date'-'translate(m.info.time,'.',':')
if compD \== '' then
if m.info.date <> compD then
call err 'date mismatch' compD '<>' d3 readNxPos(rd)
return
endProcedure anaCurDate
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSN3201I event type A - ABNORMAL EOT AUS INPUT-DS LESEN
¨¨____________________________________________________________________
*/
anaReadEot: procedure expose m.
parse arg rd, info, pEvTy
m.ReEot.0 = m.ReEot.0 +1
ux = 'REEOT.'m.ReEot.0 /*zähler */
m.ux.A = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.corr = ''
m.ux.Jobname = ''
m.ux.conn = ''
m.ux.AuthID = '' /* AuthID = User column in db2 Table */
m.ux.AsID = ''
m.ux.tcb = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
jx = pos(' JOBNAME=', m.rd.cc.lx)
if cx > 0 then do
if jx < cx then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16)))
else
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16,
, jx-cx-16)))
end
if jx > 0 then
m.ux.Jobname = cut18(word(strip(substr(m.rd.cc.lx,jx+9)),1))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then do
m.ux.conn = cut18(word(substr(m.rd.cc.lx,cx+15), 1))
end
cx = pos(' USER=', m.rd.cc.lx)
if cx > 0 then do
m.ux.AuthID = word(substr(m.rd.cc.lx,cx+6), 1)
end
cx = pos(' ASID=', m.rd.cc.lx)
if cx > 0 then
m.ux.AsID = word(substr(m.rd.cc.lx,cx+6), 1)
cx = pos(' TCB=', m.rd.cc.lx)
if cx > 0 then
m.ux.tcb = strip(substr(m.rd.cc.lx,cx+5))
/* if m.ux.tcb <> '' then
leave ????? */
end
return
endProcedure anaReadEot
/*____________________________________________________________________
¨¨
¨¨ analye msg: DSNI031I event type E - LOCK ESCALATION
¨¨____________________________________________________________________
*/
anaLockEscalation: procedure expose m.
parse arg rd, info, pEvTy
m.LoEs.0 = m.LoEs.0 +1
ux = 'LOES.'m.LoEs.0 /*zähler */
m.ux.E = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.plan = ''
m.ux.package = ''
m.ux.CollID = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.resource = ''
m.ux.LckSt = ''
m.ux.Statement = ''
do lx=1 to m.rd.cc.0
cx = pos(' RESOURCE NAME = ', m.rd.cc.lx)
if cx > 0 then
m.ux.resource = strip(word(m.rd.cc.lx, 4))
cx = pos(' LOCK STATE = ', m.rd.cc.lx)
if cx > 0 then
m.ux.LckSt = strip(word(m.rd.cc.lx, 4))
cx = pos(' PLAN NAME : PACKAGE NAME = ',m.rd.cc.lx)
if cx > 0 then do
PlanPack = substr(m.rd.cc.lx,cx+28)
cx = pos(':',planpack)
m.ux.plan = strip(left(planPack, cx-1))
m.ux.package = cut18(strip(substr(planPack,cx+1)))
end
cx = pos(' COLLECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.CollID = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' STATEMENT NUMBER = ', m.rd.cc.lx)
if cx > 0 then
m.ux.Statement= strip(substr(m.rd.cc.lx,cx+20))
cx = pos(' CORRELATION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+18)))
cx = pos(' CONNECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
/* if m.ux.conn <> '' then
leave ???????? */
end
return
endProcedure anaLockEscalation
sayObj: procedure expose m.
parse arg ff, o
say o':' cl
do fx=1 to m.ff.0
f1 = m.ff.fx
say left(f1, 20) m.o.f1
end
return
endProcedure sayObj
/*____________________________________________________________________
¨¨
¨¨ analye uncommit UOW msg: DSNJ031I / event type U and C
¨¨____________________________________________________________________
*/
anaUncommittedUOW: procedure expose m.
parse arg rd, info, pEvTy
m.uow.0 = m.uow.0 +1
ux = 'UOW.'m.uow.0 /* zähler */
m.ux.UC = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.logRecs = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.plan = ''
m.ux.authid = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CHECKPOINTS -', m.rd.cc.lx) /* for checkP */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 2))
cx = pos(' LOG RECORDS -', m.rd.cc.lx) /* for UOW */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 3))
cx = pos(' CORRELATION NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(word(substr(m.rd.cc.lx,cx+19),1))
cx = pos(' CONNECTION ID =', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' PLAN NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.plan = strip(substr(m.rd.cc.lx,cx+13))
cx = pos(' AUTHID =', m.rd.cc.lx)
if cx > 0 then
m.ux.authid = strip(substr(m.rd.cc.lx,cx+9))
/* if m.ux.authid <> '' then
leave ???????????? */
end
return
endProcedure anaUncommittedUOW
/*____________________________________________________________________
¨¨
¨¨ analye timeout, deadlock msg: DSNT375I, DSNT376I
¨¨____________________________________________________________________
*/
anaTimeoutDeadlock: procedure expose m.
parse arg rd, info, pEvTy
totx = newTimeout(info, pEvTy)
vs = 'V'
do lx=1 to m.rd.cc.0
if pos(' ONE HOLDER ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'T' then
call err 'holder for evTy' pEvTy':'m.rd.cc.lx ,
readNxPos(r)
else if vs <> 'V' then
call err 'several holders:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
if pos(' IS DEADLOCKED ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'D' then
call err 'is deadLocked for evTy' ,
pEvTy':'m.rd.cc.lx readNxPos(r)
else if vs <> 'V' then
call err 'several is deadLocked:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
cx = pos(' PLAN=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.plan = word(substr(m.rd.cc.lx, cx+6,8), 1)
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.corr = cut18(strip(substr(m.rd.cc.lx, cx+16)))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.conn = cut18(strip(substr(m.rd.cc.lx, cx+15)))
cx = pos(' ON MEMBER ', m.rd.cc.lx)
if cx > 0 then do
if vs <> 'H' then
call err 'on member in vs' vs':'m.rd.cc.lx readNxPos(rd)
else
m.toTx.vs.dbMb = word(substr(m.rd.cc.lx, cx+11, 8), 1)
end
end
return
endProcedure anaTimeOut
/*____________________________________________________________________
¨¨
¨¨ make and initialise a new timeout/deadlock row
¨¨____________________________________________________________________
*/
newTimeout: procedure expose m.
parse arg info, pEvTy
m.to.0 = m.to.0 + 1
toTx = 'TO.'m.to.0
call clearFlds totx, ffTimeO
m.toTx.tst = m.info.tst
m.toTx.evTy = pEvTy
m.toTx.v.dbMb = m.info.dbMb
m.toTx.dbSys = m.info.dbSys
return toTx
endProcedure newTimeout
/*____________________________________________________________________
¨¨
¨¨ analyse resourceNotAvailable msg DSNT501I and DSNT500I
¨¨____________________________________________________________________
*/
anaResourceNotAvailable: procedure expose m.
parse arg rd, info, mid
tCor = ''
tCon = ''
tRea = ''
tTyp = ''
tNam = ''
do lx = 1 to m.rd.cc.0 /* loop line of dsnt501i */
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
tCor = word(substr(m.rd.cc.lx,cx+16),1)
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
tCon = strip(substr(m.rd.cc.lx,cx+15))
cx = pos(' REASON ', m.rd.cc.lx)
if cx > 0 then
tRea = word(substr(m.rd.cc.lx,cx+8,20),1)
cx = pos(' TYPE ', m.rd.cc.lx)
if cx > 0 then
tTyp = word(substr(m.rd.cc.lx,cx+6,20),1)
cx = pos(' NAME ', m.rd.cc.lx)
if cx > 0 then
tNam = strip(substr(m.rd.cc.lx,cx+6))
end /* loop line of dsnt501i */
/* search preceeding timeOut/deadLock*/
if tCor = '' | tCon = '' then do
tx = m.to.0
if m.to.tx.name \== '' then
tx = -1
end
else do
mb = m.info.dbMb
tsN = m.info.tst
numeric digits 20
tsB = timeDays2Tst(timestamp2Days(tsN) - 30/86400)
numeric digits 9
tt = max(1, m.to.0 - 30)
do tx=m.to.0 to tt by -1
if m.to.tx.v.dbMb <> mb ,
| m.to.tx.tst >> tsN | m.to.tx.tst << tsB then do
m.ctoNF = m.ctoNF + 1
m.ctoNFX = m.ctoNFx + m.to.0 - tx
tx = -9
end
else if m.to.tx.v.corr == tCor & m.to.tx.v.conn == tCon ,
& m.to.tx.name == '' then
leave
end
if tx >= -1 then do
m.ctoFo = m.ctoFo + 1
m.ctoFoX = m.ctoFox + m.to.0 - tx
end
end
if tx >= tt then do
toTx = 'TO.'tx /* resource an timeout/deadlock anhängen */
end
else do /* new feature: store these also
evType depending on reason, but some have several */
if wordPos(tRea, '00C200FA 00C20031 00C900C0 00E70010') >0 then
toTx = newTimeout(info, 'T')
else
toTx = newTimeout(info, '')
m.toTx.v.corr = tCor
m.toTx.v.conn = tCon
end
m.toTx.type = tTyp
m.toTx.name = space(tNam, 1)
m.toTx.reason = tRea
if tTyp <> '' then
call resourceType info, toTx'.'type, toTx'.'name
return
endProcedure anaResourceNotAvailable
/*____________________________________________________________________
¨¨
¨¨ give the name of the resourcetype and dbid/obid
¨¨____________________________________________________________________
*/
resourceType: procedure expose m.
parse arg info, tp, nm
cd = m.tp
if symbol('m.resourceType.cd') <> 'VAR' then do
say '<'cd'>' c2x(cd)
say readNxPos(rd)
call err 'unknown resource type' cd
end
m.tp = m.resourceType.cd
parms = m.resourceTypeParms.cd
names = m.nm
if pos('DI.OI', parms) > 0 then do /* find dbid and obid */
px = 0
nx = 0
do until px = 0
py = pos('.', parms, px + 1)
ny = pos('.', names, nx + 1)
if (py=0) <> (ny=0) then
call err 'resource parms' parms 'mismatch name' names
if py = 0 then do
p1 = substr(parms, px+1)
n1 = substr(names, nx+1)
end
else do
p1 = substr(parms, px+1, py-px-1)
n1 = substr(names, nx+1, ny-nx-1)
end
n.p1 = n1
px = py
nx = ny
end
/* dbid und obid uebersetzen */
m.nm = strip(getDbidObid(m.info.dbSys, n.di, n.oi) names)
end
return cd
endProcedure resourceType
ini: procedure expose m.
parse arg m.modeNew
call resourceTypeIni
call sqlIni
call errAddCleanup "if m.sql_dbSys <> '' then do;" ,
"say 'rollback';call sqlExec Rollback; call sqlDisconnect; end"
if m.modeNew then
f1 = 'TST DBSYS'
else
f1 = 'TST'
call iniFlds ffTimeO, f1 'V.DBMB EVTY V.PLAN V.CORR V.CONN' ,
'H.PLAN H.CORR H.CONN' ,
'REASON TYPE NAME'
call iniFlds ffUow, f1 'DBMB UC PLAN CORR CONN AUTHID LOGRECS'
call iniFlds ffLockE, f1 'DBMB E PLAN PACKAGE COLLID' ,
'CORR CONN RESOURCE LCKST STATEMENT'
call iniFlds ffEOT, f1 'DBMB A CORR JOBNAME CONN AUTHID ASID TCB'
return
endProcedure ini
iniFlds: procedure expose m.
parse arg ff, flds
do fx=1 to words(flds)
m.ff.fx = word(flds, fx)
end
m.ff.0 = words(flds)
return
endProcedure iniFlds
clearFlds: procedure expose m.
parse arg o, ff
do fx=1 to m.ff.0
f1 = m.ff.fx
m.o.f1 = ''
end
return o
endProcedure clearlds
resourceTypeIni: procedure expose m.
/* the old definitions for backward compability */
call rtDef '00000100', 'DB'
call rtDef '00000200', 'TS'
call rtDef '00000201', 'IX-SPACE'
call rtDef '00000202', 'TS'
call rtDef '00000210', 'PARTITION'
call rtDef '00000220', 'DATASET'
call rtDef '00000230', 'TEMP FILE'
call rtDef '00000300', 'TEMP FILE'
call rtDef '00000300', 'PAGE'
call rtDef '00000301', 'IX-MINIPAGE'
call rtDef '00000302', 'TS-PAGE'
call rtDef '00000303', 'IX-PAGE'
call rtDef '00000304', 'TS-RID'
call rtDef '00000D01', 'DBID/OBID'
call rtDef '00000800', 'PLAN'
call rtDef '00000801', 'PACKAGE'
call rtDef '00002000', 'TS CS-CLAIM CLASS'
call rtDef '00002001', 'TS RR-CLAIM CLASS'
call rtDef '00002002', 'TS WRITE-CLAIM CLASS'
call rtDef '00002003', 'IX CS-CLAIM CLASS'
call rtDef '00002004', 'IX RR-CLAIM CLASS'
call rtDef '00002005', 'IX WRITE-CLAIM CLASS'
call rtDef '00002006', 'TS PART CS-CLAIM CLASS'
call rtDef '00002007', 'TS PART RR-CLAIM CLASS'
call rtDef '00002008', 'TS PART WRITE-CLAIM CLASS'
call rtDef '00002009', 'IX PART CS-CLAIM CLASS'
call rtDef '00002010', 'IX PART RR-CLAIM CLASS'
call rtDef '00002011', 'IX PART WRITE-CLAIM CLASS'
/* the complete Db2V10 resource type table */
call rtDef '00000100', 'Database', 'DB'
call rtDef '00000200', 'Table space', 'DB.SP'
call rtDef '00000201', 'Index space', 'DB.SP'
call rtDef '00000202', 'Table space RD.DB.TS'
call rtDef '00000205', 'Compression Dictionary', 'DB.SP'
call rtDef '00000210', 'Partition', 'DB.SP.PT'
call rtDef '00000220', 'Data set', 'DSN'
call rtDef '00000230', 'Temporary file', 'SZ'
call rtDef '00000240', 'Database procedure', 'DBP'
call rtDef '00000300', 'Page', 'DB.SP.PG'
call rtDef '00000301', 'Index minipage', 'DB.SP.PG.MP'
call rtDef '00000302', 'Table space page', 'DB.SP.PG'
call rtDef '00000303', 'Index space page', 'DB.SP.PG'
call rtDef '00000304', 'Table space RID', 'DB.SP.RID'
call rtDef '00000305', 'Index access/table space RID', 'DB.SP.RID'
call rtDef '00000306', 'Index access/table space page', 'DB.SP.PG'
call rtDef '00000307', 'Index space EOF', 'DB.SP.01'
call rtDef '00000400', 'ICF catalog', 'IC'
call rtDef '00000401', 'Authorization function'
call rtDef '00000402', 'Security Server',
, 'SAF/RACF return/reason codes'
call rtDef '00000500', 'Storage group', 'SG'
call rtDef '00000602', 'EDM DBD Space'
call rtDef '00000603', 'EDM DYNAMIC STATEMENT Space'
call rtDef '00000604', 'EDM skeleton storage'
call rtDef '00000605', 'EDM above-the-bar storage'
call rtDef '00000606', 'EDM below-the-bar storage'
call rtDef '00000700', 'Buffer pool space', 'BP'
call rtDef '00000701', 'Group buffer pool', 'GBP'
call rtDef '00000800', 'Plan', 'PL'
call rtDef '00000801', 'Package', 'COLLECTION.PACKAGE.CONTOKEN'
call rtDef '00000802', 'BINDLOCK01 through BINDLOCK20',
, 'BINDLOCK01 through BINDLOCK20'
call rtDef '00000900', '32KB data area'
call rtDef '00000901', 'Sort storage'
call rtDef '00000903', 'Hash anchor', 'DB.SP.PG.AI'
call rtDef '00000904', 'RIDLIST storage'
call rtDef '00000905', 'IRLM storage'
call rtDef '00000906', 'DB2', 'MEMBER'
call rtDef '00000907', 'LOB storage'
call rtDef '00000908', 'Basic Floating Point Extensions Facility'
call rtDef '00000909', 'Extended Time-of-Day (TOD) Clock'
call rtDef '0000090A', 'XML storage'
call rtDef '00000A00', 'Table', 'RD.CR.TB'
call rtDef '00000A10', 'Alias', 'RELDEP.OWNER.ALIAS.RD.CR.AL'
call rtDef '00000A11', 'Distinct type', 'SC.DT'
call rtDef '00000A12', 'User-defined function', 'SC.SN'
call rtDef '00000A13', 'Stored procedure', 'SC.SN'
call rtDef '00000A14', 'Sequence'
call rtDef '00000A16', 'Role'
call rtDef '00000A17', 'Trigger'
call rtDef '00000B00', 'View', 'RD.CR.VW'
call rtDef '00000C00', 'Index', 'RD.CR.IX'
call rtDef '00000C01', 'Index', 'CR.IX'
call rtDef '00000D00', 'DBID/OBID', 'RD.DI.OI'
call rtDef '00000D01', 'DBID/OBID', 'DI.OI'
call rtDef '00000D02', 'OBID', 'OI'
call rtDef '00000E00', 'SU limit exceeded', 'CN'
call rtDef '00000F00', 'Auxiliary column',
,'DI.OI.ROWID.COLN or DI.OI.DOCID.COLN'
call rtDef '00000F01', 'LOB lock', 'DIX.PIX.ROWID.VRSN'
call rtDef '00000F81', 'XML lock', 'DIX.PIX.DOCID'
call rtDef '00001000', 'DDF', 'LOCATION or SUBSYSTEM ID'
call rtDef '00001001', 'System conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001002', 'Agent conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001003', 'CNOS processing',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001004', 'CDB (Communication database)',
, 'LOCATION.AUTHORIZATIONID.PL'
call rtDef '00001005', 'DB access agent', 'LOCATION'
call rtDef '00001007', 'TCP/IP domain name', 'LINKNAME.DOMAIN.ERRNO'
call rtDef '00001008', 'TCP/IP service name', 'LOCATION.SERVICE.ERRNO'
call rtDef '00001080', 'ACCEL', 'SERVER.DOMAIN'
call rtDef '00001102', 'Bootstrap data set (BSDS)', 'MEMBER'
call rtDef '00002000', 'Table space CS-claim class', 'DB.SP'
call rtDef '00002001', 'Table space RR-claim class', 'DB.SP'
call rtDef '00002002', 'Table space write-claim class', 'DB.SP'
call rtDef '00002003', 'Index space CS-claim class', 'DB.SP'
call rtDef '00002004', 'Index space RR-claim class', 'DB.SP'
call rtDef '00002005', 'Index space write-claim class', 'DB.SP'
call rtDef '00002006', 'Table space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002007', 'Table space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002008', 'Table space partition write-claim class',
, 'DB.SP.PT'
call rtDef '00002009', 'Index space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002010', 'Index space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002011', 'Index space partition Write-claim class',
, 'DB.SP.PT'
call rtDef '00002100', 'Table space DBET entry', 'DB.SP'
call rtDef '00002101', 'Index space DBET entry', 'DB.SP'
call rtDef '00002102', 'Table space partition DBET entry', 'DB.SP.PT'
call rtDef '00002103', 'Index space partition DBET entry', 'DB.SP.PT'
call rtDef '00002104', 'DBET hash chain lock timeout',
, 'INTERNAL LOCK NN'
call rtDef '00002105', 'Logical partition DBET entry', 'DB.SP.PT'
call rtDef '00002200', 'Routine Parameter Storage', 'DBP'
call rtDef '00002201', 'm.debug Agent Storage', 'DBP'
call rtDef '00002300', 'ICSF encryption and decryption facilities'
call rtDef '00003000', 'Code (release maintenance_level or system' ,
'parameter)', 'REL,APAR,ZPARM'
call rtDef '00003002', 'Number of Stored Procedures'
call rtDef '00003072', 'Index'
call rtDef '00003073', 'Index'
call rtDef '00003328', 'Release dependency'
call rtDef '00003329', 'DBID/OBID', 'DI.OI'
call rtDef '00003330', 'OBID limit exceeded'
call rtDef '00003840', 'LOB column'
call rtDef '00004000', 'Profile exception threshold exceeded',
, 'PID.PTYPE.PNAME'
return
endProcedure resourceTypeIni
rtDef: procedure expose m.
parse arg cd, nm, pa
if symbol('m.resourceType.cd') <> 'VAR' then
m.resourceType.cd = nm
m.resourceTypeParms.cd = pa
return
endProcedure rtDef
getDbidObid: procedure expose m.
parse arg dbSys, dbid, obid
SQL_DBID = STRIP(dbid,L,0)
SQL_OBID = STRIP(obid,L,0)
if symbol('m.id2n.dbSys.dbidObid.dbid.obid') == 'VAR' then
/* haben es schon mal gefunden*/
return m.id2n.dbSys.dbidObid.dbid.obid
/* select from catalog */
/* from sysTables */
if dbSys \== m.sql_dbSys then do
if m.sql_dbSys \== '' then
call sqlDisconnect
if m.tstRZ4 then
if sysvar(sysNode) = 'RZ4' ,
& wordPos(dbSys, 'DP4G DBOL') < 1 then
return ''
call sqlConnect dbSys
end
res = sql2One("SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROm SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One("SELECT ",
" STRIP(DBNAME,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One( "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
m.dbidObid.dbid.obid = res
return m.dbidObid.dbid.obid
endProcedure getDbidObid
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM60A1
¨¨_________________________________________________________________________
*/
INSERT_TADM60A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM60A1..."
cIns = 0
cDead = 0
cTime = 0
say ' ' time() 'begin insert into tadm60a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM60A1 (" ,
"TIMESTAMP, ssid, event_type," ,
"VICTIM_PLAN, VICTIM_CORR_ID, VICTIM_COnn_ID," ,
"SOURCE_PLAN, SOURCE_CORR_ID, SOURCE_COnn_ID," ,
"REASON_CODE, type, name )" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
do tx=1 to m.to.0
/*______________________________________________________________________
row überspringen falls alt
*/
if (m.to.tx.evTy == 'D' & m.to.tx.tst <= m.lastDeadlock ) ,
|(m.to.tx.evTy == 'T' & m.to.tx.tst <= m.lastTimeout ) then
iterate
call sqlUpdArgs 7,
, m.to.tx.tst, m.to.tx.v.dbMb, m.to.tx.evTy,
, m.to.tx.v.plan, m.to.tx.v.corr, m.to.tx.v.conn,
, m.to.tx.h.plan, m.to.tx.h.corr, m.to.tx.h.conn,
, m.to.tx.reason, m.to.tx.type, m.to.tx.name
cIns = cIns + 1
cDead = cDead + (m.to.tx.evTy == 'D')
cTime = cTime + (m.to.tx.evTy == 'T')
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm60a1,' ,
cDead 'deadlocks and' cTime 'timeouts'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM60A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM63A1
¨¨_________________________________________________________________________
*/
INSERT_TADM63A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM63A1..."
say ' ' time() 'begin insert into tadm63a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM63A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"CORRID_ID," ,
"CONN_ID," ,
"AUTHID," ,
"LOGREC)" ,
"VALUES (?,?,?,?,?,?,?,?)"
cIns = 0
cUOW = 0
cCHK = 0
do tx=1 to m.uow.0
ux = 'UOW.'tx
if m.ux.UC == 'U' & m.ux.tst <= m.lastUOW then
iterate
if m.ux.UC == 'C' & m.ux.tst <= m.lastCheckp then
iterate
cIns = cIns + 1
cUOW = cUOW + (m.ux.UC == 'U')
cCHK = cCHK + (m.ux.UC == 'C')
call sqlUpdArgs 7,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.UC,
,m.ux.plan,
,m.ux.corr,
,m.ux.conn,
,m.ux.authid,
,m.ux.logRecs
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm63a1,' ,
cUOW 'uncommitedUOW and' cCHK 'checkpoints'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM63A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM64A1
¨¨_________________________________________________________________________
*/
INSERT_TADM64A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM64A1..."
say ' ' time() 'begin insert into tadm64a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM64A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"PACKAGE_NAME," ,
"COLLECTION_ID," ,
"CORRID_ID," ,
"CONN_ID," ,
"RESOURCE," ,
"LOCK_STATE," ,
"STATEMENT)" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.LoEs.0
ux = 'LOES.'tx
if m.ux.tst <= m.lastLockesc then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.E,
,m.ux.plan,
,m.ux.package,
,m.ux.CollID,
,m.ux.corr,
,m.ux.conn,
,m.ux.resource,
,m.ux.LckSt,
,m.ux.Statement
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm64a1,' ' LOCK ESCALATION'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM64A1..."
RETURN;
/*_________________________________________________________________________
¨¨
¨¨ INSERT IN DB2 TABELLE TADM65A1
¨¨_________________________________________________________________________
*/
INSERT_TADM65A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM65A1..."
say ' ' time() 'begin insert into tadm65a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM65A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"CORRID_ID," ,
"JOBNAME," ,
"CONN_ID," ,
"AUTHID," ,
"ASID," ,
"TCB)" ,
"VALUES (?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.ReEot.0
ux = 'REEOT.'tx
if m.ux.tst <= m.lastReadEot then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.A,
,m.ux.corr,
,m.ux.Jobname,
,m.ux.conn,
,m.ux.AuthID,
,m.ux.AsID,
,m.ux.tcb
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm65a1,' ' ABNORMAL EOT'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM65A1..."
RETURN;
/*-- quote text t with apostrophs (sql string)
truncate if longer then 18 characters ---------------------------*/
cut18: procedure expose m.
parse arg t
if length(t) <= 18 then
return t
else
return left(space(t, 1), 18)
endProcedur cut18
/*----------------------------------------------------------------*/
/*--------- AUSGEBEN VON SQL-FEHLERBESCHREIBUNG SQLCA ------------*/
/*----------------------------------------------------------------*/
SQLCA:
IF m.debug THEN SAY "ENTER PROCEDURE SQLCA..."
parse ARG msg
ggSqlStmt = sqlText
call err msg sqlMsg()
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/*_____________________________________________________________________
¨¨
¨¨ DSN erstellen für RZ4
¨¨_____________________________________________________________________
*/
writeAblfAll: procedure expose m.
parse arg pre
call writeAblf to, fftimeO, pre'.TADM60A1'
call writeAblf uow, ffUow, pre'.TADM63A1'
call writeAblf Loes, ffLockE, pre'.TADM64A1'
call writeAblf ReEot, ffEOT, pre'.TADM65A1'
return 0
endProcedure writeAblfAll
writeAblf: procedure expose m.
parse arg st, ff, dsn
/*______________________________________________________________________
¨¨
¨¨new dsn write
¨¨______________________________________________________________________
*/
do sx=1 to m.st.0
o.sx = csv4obj(st'.'sx, ff, 0)
end
dsn=dsn'.D'date('j')'.T'translate(124578, time(), 12345678)
call writeDsn dsn '::v300', 'O.', m.st.0, 1
return
endProcedure writeAblf
newDSN: procedure expose dsnRZ4.
/*
dsnRZ4.1='DSN.ABLF.LOGEX.DE0G.TADM60A1'
dsnRZ4.2='DSN.ABLF.LOGEX.DE0G.TADM63A1'
dsnRZ4.3='DSN.ABLF.LOGEX.DE0G.TADM64A1'
dsnRZ4.4='DSN.ABLF.LOGEX.DE0G.TADM65A1'
address tso
do i=2 to 4
ok#dsn=SYSDSN("'"dsnRZ4.i"'")
IF ok#dsn = 'OK' then do
SAY 'DSN EXISTS WIRD GELÖSCHT'OK#DSN' = 'dsnRZ4.i
"DELETE '"dsnRZ4.i"'"
if RC>0 then say 'DSN konnte nicht gelöscht werden'
END
/*ok#dsn=SYSDSN("'"dsnRZ4.i"'")
*/ y=0
do until (fb=0 | y>2 )
"ALLOC DDNAME(DDN"i") DSN('"dsnRZ4.i"') new lrecl(160) recfm(f b)"
fb=rc;y=y+1
if fb>0 then do
"FREE DDNAME(DDN"i")"
end
end
end
*/
return
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_rz = ''
m.ii.rzC = ''
i = 'RZ1 1 S1 DBTF T DTF DVTB V DTB DBOC C DOC' ,
'RZ2 2 S2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RR2 R R2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RQ2 Q Q2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RZ4 4 S4 DBOL O DOL DP4G U DP4' ,
'RZX X X2 DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'RZY Y Y2 DE0G E DE0 DEVG M DEV DPYG Y DPY' ,
'RZZ Z Z2 DE0G E DE0 DEVG M DEV DPZG N DPZ'
m.ii_rz = ''
m.ii_rzC = ''
do wx=1 by 3 to words(i)
parse value subWord(i, wx, 3) with w1 w2 w3
if abbrev(w1, 'R') & length(w1) == 3 then do
rz = w1
m.ii_DbSys.rz = ''
m.ii_rz = strip(m.ii_rz rz)
m.ii_rzC = m.ii_rzC || w2
call iiA1 ii_sys2rz, w3, rz
call iiA1 ii_rz2c, rz, w2
end
else if abbrev(w1, 'D') & length(w1) == 4 then do
m.ii_DbSys.rz = strip(m.ii_DbSys.rz w1)
call iiA1 ii_db2c, w1, w2
call iiA1 ii_mbr2db, w3, w1
call iiA1 ii_db2Elar, w1, wordPos(w1, 'DVTB DVBP DEVG')>0
end
else
call err 'bad w1' w1 w2 w3
end
return
endProcedure iiIni
iiA1: procedure expose m.
parse arg st, key ,val
if symbol('m.st.key') \== 'VAR' then
m.st.key = val
else if m.st.key \== val then
call err 'already <> defined' st'.'key'='m.st.key 'val='val
return
endProcedure iiA1
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiRz2C
iiRzDbSysBegin:procedure expose m.
parse arg m
call iiIni
m.m.rx = 1
m.m.dx = 0
return
endProcedure iiRzDbSysBegin
iiRzDbSys:procedure expose m.
parse arg m
do forever
rz = word(m.ii_rz, m.m.rx)
if rz == '' then do
call vPut 'rz', ''
call vPut 'dbSys', ''
return 0
end
m.m.dx = m.m.dx+1
db = word(m.ii_dbSys.rz, m.m.dx)
if db == '' then do
m.m.rx = m.m.rx + 1
m.m.dx = 0
iterate
end
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
end
endProcedure iiRzDbSys
/* copy ii end ********* Installation Info *************************/
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err 'implement rxFetchVars ?' /* ?????????????
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
ret = left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
return ret
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
bef0 = m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then do
say 'atEnd????' m bef0 m.m.cx m.m.0 m.m.buf0x
say m bef0 m.m.cx m.m.0 m.m.buf0x
return ''
end
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
m.ut_alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfUC = translate(m.ut_alfLc)
m.ut_Alfa = m.ut_alfLc || m.ut_alfUC
m.ut_alfUCNum = m.ut_alfUC || m.ut_digits
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_alfLc, m.ut_alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXDIGITS) cre=2011-05-23 mod=2011-05-23-11.53.48 A540769 ---
/* rexx */
say 'digits' digits()
call procDig 24
say 'digits' digits() 'after procDig 24'
numeric digits 20
say 'digits' digits() 'after 20'
call procDig 24
say 'digits' digits() 'after procDig 24'
call subDig 27
say 'digits' digits() 'after subDig 27'
numeric digits 33
say 'digits' digits() 'after 33'
call procDig 31
say 'digits' digits() 'after procDig 31'
call procDigEE 35
say 'digits' digits() 'after procDigEE 31'
/* lrsn = 12 hex digits = 48 digits ~ 15 decimal digits */
lr = '1000000089abc'
signal on syntax
do d=27 by-1
numeric digits d
say 'digits='d x2d(lr)
end
exit
syntax:
say 'after syntax'
lr = '0000000089abc'
do d=27 by-1
numeric digits d
say 'digits='d x2d(lr)
end
exit
call procDig 222
subDig:
parse arg nn
say 'subDigits bef' digits()
numeric digits nn
say 'subDigits aft' digits()
return
call procDig 111
procDig: procedure
parse arg nn
say 'procDigits bef' digits()
numeric digits nn
say 'procDigits aft' digits()
return
procDigEE: procedure
parse arg nn
say 'procDigitsEE bef' digits()
numeric digits nn
say 'procDigitsEE aft' digits()
return
}¢--- A540769.WK.REXX(EXDIS) cre=2012-09-10 mod=2012-09-10-14.34.12 A540769 ----
call sqlDsn st, 'DBTF', '-dis thread(*) type(active) scope(group)'
say 'rc' rc', sz' m.st.0
px = 0
plans = ''
do sx=1 to m.st.0
if px < 10 then do
px = 1 + pos(' PLAN ', m.st.sx)
if px > 10 then
say 'px' px
iterate
end
if left(m.st.sx, 1) <> '' then do
p1 = word(substr(m.st.sx, px, 9), 1)
if p1 <> '' & wordpos(p1, plans) < 1 then
plans = plans p1
end
if sx<20 | pos('PR5080', m.st.sx) > 0 then do
if px > 0 then
say sx word(substr(m.st.sx, px, 9), 1) ':'plans':' m.st.sx
else
say sx':' m.st.sx
end
end
say words(plans) plans
exit
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
/*--- initialize sqlRx (belongs to sqlQ, but currently only one|) ----*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlCAMsg = 0
m.sqlSuMsg = 2
call sqlPushRetOk
m.sql.ini = 1
m.sql.conType = ''
return 0
endProcedure sqlIni
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlOIni
hst = ''
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
cTy = 'Rx'
end
if m.sql.conType == cTy & m.sqlHost==hst & m.sqlConSSID == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.conSSID = sys
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conhost = ''
m.sql.conSSID = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
if retOk == '' then
retOk = 100 m.sqlRetOk
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExImm(src, ggRet)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, ggRet)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExImm(src, ggRet)
end
res = sqlExec(src, ggRet)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | fun == 'WITH' then
return sqlQuery(cx, src, retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = sqlGetCursor()
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = sqlGetCursor()
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlClose cx
call sqlFreeCursor cx
return res
endProcedure sql2One
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
s = ''
src = inp2str(src, '%+Q\s')
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
return sqlExec('prepare s'cx s 'from :src', ggRetOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = f'.FLDS'
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cn = translate(word(sNa, 1))
if cn == '' | symbol('sqlVarName.cn') == 'VAR' then
cn = 'COL'kx
sqlVarName.cn = 1
return cn
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
sqlHandleRCSqlCode:
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
/*???lse if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then*/
else if (sqlCode <> 0 | sqlWarn.0^==' ') & pos('w',ggRetOk)<1 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlDisconnect
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' ,
if(m.sql.conHost=='',,m.sql.conHost'/'),
|| m.sql.conSSID', interfaceType' m.sql.conType
return ggRes
endSubroutine sqlMsg
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca:
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.mAlfRex1) < 1 then
iterate
ex = verify(src, m.mAlfRexR, 'n', cx)
if ex - cx > 100 then
iterate
sx = sx + 1
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.mAlfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
end
m.st.0 = sx
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sql end **************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXEJES) cre=2014-09-23 mod=2014-10-08-10.39.01 A540769 ---
/* rexx ---------------------------------------------------------------
examples für eJes rexx interface
1) eJesJob1: jobs anzeigen, direkt mit eJes
2) eJesJob2: jobs anzeigen, mit copy Interface
3) eJesJobDs: jobs und DDs anzeigen, dd Lesen funktioniert nicht
4) eJesJobExtDD: eine DD pro Job extrahieren
5) eJesJobExtXX: eine DD pro Job extrahieren
---------------------------------------------------------------------*/
call eJesJobExtDD 'A540769*', jesMsgLg
exit
call eJesJobExtDD 'A540769*', jesMsgLg, A540769.tmp.exEJes, eJes
call eJesJobDs 'DP4*MSTR', 3
exit
call eJesJob1 'A540769'
exit
call eJesJob2 'A54*'
exit
call eJesJobExtDD 'D%%%MSTR', jesMsgLg, A540769.tmp.exEJes, eJes
exit
eJesJob1: procedure expose m.
parse arg jMask
call eJesRexx 'initapi'
call eJesMsg eJes_, 'initApi result='result
call eJesRexx "execApi 0 pReset"
call eJesRexx "execApi 0 owner=" /* sonst gibts nur meine */
call eJesRexx "execApi 0 'maskChar *%'" /* default ist space */
call eJesRexx "execApi 0 'jName="jMask"' (prefix eJes_"
call eJesScreen eJes_, 'pReset...jName result='result
call eJesRexx 'execApi * st (prefix job_'
/* * schiebt den Output in stem Variabeln */
call eJesScreen job_, '* st result='result
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
say jx job_jobName.jx job_jobId
/* locate aktiviert die angegebene Zeile */
call eJesRexx "execApi 0 'locate" jx"' (prefix loc_"
if loc_jobName <> job_jobName.jx then
say loc_jobName '<>' job_jobName.jx
end
call eJesRexx 'execApi 0 end (prefix eEnd_'
call eJesScreen eEnd_, 'end result='result
address eJes 'termApi'
return
endProcedure eJesJob1
eJesJob2: procedure expose m.
parse arg jMask
call eJesInit jMask
cc = eJesExec('* st', job_, 4)
call eJesScreen job_, '* st result='cc
say 'jMask='jMask':' job_lines 'jobs'
if cc = 0 then
do jx=1 to job_lines
say jx job_jobName.jx job_jobId.jx
call eJesRexx "execApi 0 'locate" jx"' (prefix loc_"
if loc_jobName <> job_jobName.jx then
say loc_jobName '<>' job_jobName.jx
if loc_jobId <> job_jobId.jx then
say loc_jobId '<>' job_jobId.jx
end
call eJesExec '0 end', eEnd_
call eJesScreen eEnd_, 'end result='result
call eJesTerm
return
endProcedure eJesJob2
eJesJobDs: procedure expose m.
parse arg jMask, shLi
call eJesInit jMask
cc = eJesExec('* st', job_, 4)
say 'jMask='jMask':' job_lines 'jobs cc='cc
if cc = 0 then
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
call eJesExec "* :s", ds_
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
do lx=1 to ds_lines
say ' ' ds_tcData.ds__ddName.lx ds_tcData.ds__sName.lx ,
'r='ds_tcData.ds__records.lx
if shLi > 0 then do
call eJesExec "0 locate" lx, li_
say li_msg.0 li_msg.1
call eJesExec '0 :sa', li_
say li_msg.0 li_msg.1
if subWord(li_msg.1, 1, 2) \== 'EJES247 Spool' then
call eJesErr li_, 'bad msg for alloc'
liDD = word(li_msg.1, words(li_msg.1))
say "execIo" lidd
call adrTso "execio" shLi "diskr",
lidd "(stem" li. "open finis)"
do lx=1 to li.0
say left(' ' li.lx, 78)
end
say ':sf normally fails|||||||||||||||'
call eJesExec '0 :sf', li_
say li_msg.0 li_msg.1
end
end
call eJesExec '0 end'
end
call eJesExec '0 end'
call eJesTerm
return
endProcedure
eJesJobExtXX: procedure expose m.
parse arg jMask, dd, oPref, oLlq
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
sufAll = ''
exDsn = oPref'.'oLlq
call dsnAlloc 'dd(eJesExt) mod' exDsn '::v'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
trace ?r
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
suf = '.'job_jobName'.'oLLq
sx = lastPos(suf, sufAll)
if sx > 0 then do
lx = substr(word(substr(sufAll, sx+length(suf)-1),1),2)
if lx = '' then
suf = suf'2'
else
suf = suf || (lx + 1)
end
sufAll = sufAll suf
exDsn = oPref || suf
call dsnAlloc 'dd(eJesExt)' exDsn '::v'
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==>' exDsn
end
call sleep 20
call eJesExec "0 end", ds_
end
call tsoFree eJesExt
call eJesTerm
return
endProcedure
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXEXIT) cre=2014-07-28 mod=2014-07-28-16.07.44 A540769 ---
arg a
if a = '' then do
do x=1 to 40
res = exExit(2**x)
say x 2**x 'len' length(res) left(res, 10)'...'right(res,10)
end
end
else do
exit '<'a left('', a, '-') a'>'
end
}¢--- A540769.WK.REXX(EXIDCAMS) cre=2016-08-13 mod=2016-08-23-15.07.47 A540769 ---
$#@
if 0 then $@¢
call dsnDel 'A540769.tmp.pli', 'eins vier drei'
$! else if 0 then $@¢ $** delete mit file( **********
f = dsnAlloc('A540769.tmp.pli dd(del)')
call adrTso "delete 'A540769.tmp.pli(zwei)' file(del)"
call tsoFree del
$! else if 1 then $@¢ $** repro ******************
l1 = A540769.wk.jcl
l2 = A540769.tmp.text
l2 = A540769.tmp.text333
$**call dsnCopy l1'(jc)', l2'(jcCo)'
trace ?r
address tso "repro ids('"l1"(jc)') ods('"l2"(jcRepro)')"
say 'rc='rc
$!
}¢--- A540769.WK.REXX(EXIEBCOP) cre=2016-08-23 mod=2016-08-23-16.31.12 A540769 ---
$#@
if 0 then $@¢
call dsnDel 'A540769.tmp.pli', 'eins vier drei'
$! else if 0 then $@¢ $** delete mit file( **********
f = dsnAlloc('A540769.tmp.pli dd(del)')
call adrTso "delete 'A540769.tmp.pli(zwei)' file(del)"
call tsoFree del
$! else if 1 then $@¢ $** repro ******************
l1 = A540769.wk.jcl
l2 = A540769.tmp.texv
l2 = A540769.tmp.text
call dsnAlloc 'dd(sysin) new ::f80'
i.1 = ' COPY O=SYSUT2,I=((SYSUT1,R))'
I.2 = ' SELECT M=(EXIEBCOP)'
call writeDD sysIn, i., 2
call tsoClose sysIn
call dsnAlloc 'dd(sysut1)' l1 $** '(wst)'
call dsnAlloc 'dd(sysut2)' l2 $** '(wstebGe2)'
call dsnAlloc 'dd(sysPrint) sysout(*)'
$**call dsnCopy l1'(jc)', l2'(jcCo)'
trace ?r
call adrTso 'call *(IEBCOPY)'
say 'rc='rc
call tsoFree sysPrint sysut1 sysut2 sysin
$!
$*(
//SYSPRINT DD SYSOUT=*
//IN1 DD DISP=SHR,DSN=A540769.WK.JCL
//OU1 DD DISP=SHR,DSN=A540769.TMP.TEXT333
COPY O=OU1,I=((IN1,R))
SELECT M=(CSM,JC)
$*)
}¢--- A540769.WK.REXX(EXIEBGEN) cre=2016-08-23 mod=2016-08-23-15.44.34 A540769 ---
$#@
if 0 then $@¢
call dsnDel 'A540769.tmp.pli', 'eins vier drei'
$! else if 0 then $@¢ $** delete mit file( **********
f = dsnAlloc('A540769.tmp.pli dd(del)')
call adrTso "delete 'A540769.tmp.pli(zwei)' file(del)"
call tsoFree del
$! else if 1 then $@¢ $** repro ******************
l1 = A540769.wk.jcl
l2 = A540769.tmp.texw
l2 = A540769.tmp.text
call dsnAlloc 'dd(sysut1)' l1'(jc)'
call dsnAlloc 'dd(sysut2)' l2'(jcIebGen)'
call dsnAlloc 'dd(sysPrint) sysout(*)'
$**call dsnCopy l1'(jc)', l2'(jcCo)'
trace ?r
ADDRESS LINKPGM ICEGENER
say 'rc='rc
call tsoFree sysPrint sysut1 sysut2
$!
}¢--- A540769.WK.REXX(EXISPF) cre=2012-10-10 mod=2012-10-11-22.24.15 A540769 ---
vars = 'zPrefix zScrCur zScreenC zScrName zScrMax zScreen'
call errReset 'i'
call v1 'zPrefix'
call v1 'zScreen current split screen'
call v1 'zScrCur current number of split screens'
call v1 'zScrMax max number of split screens'
call v1 'zScrName screenName'
call v1 'zScreenW screen width'
call v1 'zScreenC pos in screen'
lx = zScreenC - ((zScreenC)//zScreenW) + 1
say 'cursorPos L' || ((zScreenC)%zScreenW+1) ,
||'C' || ((zScreenC)//zScreenW+1) 'lineSt' lx
call adrIsp 'VGET (' zScreenI ')'
say 'cursLine' substr(zScreenI, lx, zScreenW)
sep = ' .'
do wx=zScreenC+1 to lx+zScreenW-2 ,
while pos(substr(zScreenI, wx, 1), sep) > 0
end
do wx=wx by -1 to lx+1 ,
while pos(substr(zScreenI, wx-1, 1), sep) = 0
end
do wy=wx to lx+zScreenW-2 ,
while pos(substr(zScreenI, wy, 1), sep) = 0
end
say 'cursWord' substr(zScreenI, wx, wy-wx)'|'
call v1 'zScreenI sreen data'
exit
exit asdf ahjk
v1:
parse arg var msg
call adrIsp 'VGET (' var ')'
say left(var, 8) value(var)':' msg
return
say wx word(vars, wx) value(word(vars, wx))
end
exit
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXISPSEL) cre=2015-12-18 mod=2015-12-18-13.35.01 A540769 ---
/* rexx
attention: does not work as a macro, only as tso command |
*/
cmd = "SELECT CMD(date ) newappl(neA1) passlib"
cmd = "SELECT CMD(exArgs eins 'zwei'() ) newappl(neA1) passlib"
say 'address ispexec' cmd
address ispExec cmd
say 'rc='rc 'for address ispexec' cmd
}¢--- A540769.WK.REXX(EXISPSTA) cre=2016-09-09 mod=2016-09-09-16.01.06 A540769 ---
/* enquire ispf member statistics */
call adrIsp "lmInit dataid(lmid) dataset(tmp.rexx)"
call adrIsp 'lmOpen dataid('lmid')'
call adrIsp 'lmmFind dataid('lmid') member(wsh) stats(yes) noLla'
say f('%t S')
say translate(ZLC4DATE, '-', '/') zlcNoRc zlExt zlcNoRcE
say translate(ZLM4DATE'-'zlmTime':'zlmSec, '-.', '/:') zlUser
call adrIsp 'lmmStats dataid('lmid') member(wsh) createD4(1908/04/01)',
'modDate4(2122/05/31) modTime(23:24:25) user(MyUser7)'
call adrIsp 'lmClose dataid('lmid')'
call adrIsp 'lmFree dataid('lmid')'
}¢--- A540769.WK.REXX(EXLISTD) cre=2012-11-15 mod=2014-10-29-17.45.05 A540769 ---
parse arg ds
if ds = '' then ds = 'wk.rexx(m*)'
call dsnMbrs q, ds
do x=1 to m.q.0
say x m.q.x
end
exit
x = Outtrap('Mem.')
address Tso "LISTDS" ds "MEMBERS"
x = Outtrap('OFF')
trace ?r
do iMem = 1 To Mem.0 while Mem.iMem \= "--MEMBERS--"
end
trace ?r
do iMem = iMem+1 To Mem.0
say strip(mem.iMem) '<'mem.iMem'>'
end
dsnMbrs: procedure expose m.
parse arg m, pds '(' mbr ')'
mbr = translate(strip(mbr))
if mbr \== '' then
if right(mbr, 1) \== '*' then
call err 'bad mbr, should end with *' arg(2)
else
mbr = left(mbr, length(mbr)-1)
call adrTso "LISTDS" pds "MEMBERS"
do x = 1 To m.tso_Trap.0 while m.tso_Trap.x \= "--MEMBERS--"
end
if x >= m.tso_Trap.0 then
say 'no Members'
o = 1
do x=x+1 to m.tso_Trap.0
m.m.o = strip(m.tso_Trap.x)
if abbrev(m.m.o, mbr) then
o = o+1
end
m.m.0 = o-1
return
trace ?r
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(EXMAIL) cre=2015-06-02 mod=2015-06-03-07.45.28 A540769 ---
$#@
call dsnAlloc 'dd(mailIn) new ::f'
$<>
call pipeWriteAll
$>dd(mailIn)
$<=/mailIn/
sender=walter.keller@credit-suisse.com
type=TEXT/HTML
to=walter.keller@credit-suisse.com
subject=rexx mail''t html
TEXT=<HTML>
TEXT=<HEAD>
ATT=DD¢ATT1!FILE¢att1.html!
TESTINFO=Y
text=<title>mail title</title>
TEXT=</HEAD>
TEXT=<BODY>
TEXT=<TABLE STYLE="BORDER:SOLID;BORDER-WIDTH: THIN">
TEXT=<TR>
TEXT=<TD STYLE="BACKGROUND-COLOR: #8A9DA8">ABLAUF</TD>
TEXT=<TD STYLE="BACKGROUND-COLOR: #8A9DA8">ART </TD>
TEXT=<TD STYLE="BACKGROUND-COLOR: #8A9DA8">STATUS</TD>
TEXT=<TD STYLE="BACKGROUND-COLOR: #8A9DA8">LETZTER LAUF</TD>
TEXT=<TD STYLE="BACKGROUND-COLOR: #8A9DA8">LINK </TD>
TEXT=</TR>
TEXT=<TR>
TEXT=<TD STYLE="FONT-SIZE:12PX">RZ2/DBOF</TD>
TEXT=<TD STYLE="FONT-SIZE:12PX">GBGR</TD>
TEXT=<TD ALIGN="CENTER" STYLE="FONT-SIZE:12PX">OK </TD>
TEXT=<TD STYLE="FONT-SIZE:12PX">2015-03-19-06.15.16</TD>
TEXT=<TD STYLE="FONT-SIZE:12PX">
TEXT=HTTP://CHW20025641/HOST/ZUEGELSCHUB/INDEX_ZUEGELSCHUB.HTM</TD>
TEXT=</TR>
TEXT=</TABLE>
TEXT=<p></p>
TEXT=</ul><li> %%JOBNAME%%(%%JOBID%%) %%JOBSTEP%% %%MAINPGM%%
TEXT=</li><li> %%PLEX%% %%JESNODE%% %%JESGLBL%% %%PLEX%%
TEXT=</li><li> von dd att1
textDD=ATT1
TEXT=</li><li> ende liste
TEXT=</li></ul>
INFO=Y
TEXT=</BODY>
TEXT=</HTML>
SEND=Y
$/mailIn/
$<>
call dsnAlloc 'dd(att1) new ::v4092'
$<>
call pipeWriteAll
$>dd(att1)
$<=/att1/
attacheement 1
<h1>header eins aus att1 rexx</h1>
und weiter aus <b>rexx</b>
jajaj
$/att1/
$<>
dsnOs3560 = 'PCL.U0000.P0.'sysVar(sysNode)'AKT.PERM.@008.LLB'
call readDD mailin, i., '*'
call tsoClose mailIn
say i.0 strip(i.1) strip(i.20)
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
address LINKMVS 'OS3560'
say 'rc os3560' rc
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn att1
$#out 20150602 16:39:44
$#out 20150602 16:25:40
$#out 20150602 16:24:15
*** run error ***
call OS3560 failed Rc(12)
$#out 20150602 16:23:29
$#out 20150602 16:23:21
$#out 20150602 16:21:44
}¢--- A540769.WK.REXX(EXMBRLST) cre=2014-07-21 mod=2014-07-21-08.40.50 A540769 ---
parse arg pds
if pds = '' then
pds = wk.lctl
oldtrap = outtrap()
call outtrap o.
address tso listDS pds members
dsRC = rc
call outtrap oldTrap
say 'rc='rc 'count' o.0
oy = o.0 + 99
do ox=1 to o.0
if o.ox == '--MEMBERS--' then
oy = ox
if ox > oy then
say (ox-oy) strip(o.ox)
else
say '???' ox o.ox'|'
end
}¢--- A540769.WK.REXX(EXPDS) cre=2014-10-29 mod=2014-10-29-16.58.57 A540769 ----
call syscalls on
address sysCall 'readdir' "//'a540769.wk.rexx'" dd.
say rc dd.0
do i=1 to dd.0
say i dd.i
end
exit
say i.0 i.1
call err 'wie gehts'
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return arg(2)
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err.eCat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return res
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(EXPIPE) cre=2011-03-03 mod=2016-05-03-14.09.12 A540769 ---
/* rexx */
call adrTso "free dd(p1)", '*'
call adrTso "alloc dd(p1) dsnType(pipe)",
"pathopts(OCREAT,OAPPEND)" ,
"pathmode(SIWUSR,SIRUSR)",
"path('/tmp/pipeEins')",
"pathdisp(keep,keep)",
"lrecl(80) RECFM(V B) blksize(8000)"
/* "path('/u/a540769/pipeEins')", */
say 'after alloc' rc
/*call writeDDBegin p1
say 'after ddBeg' */
say 'writing to pipe'
o.1 = 'pipe msg 1'
o.1 = 'pipe msg 2 llllllllllllllllllllllllllllllllllllllang'
o.2 = 'pipe msg 3 llllllllllllllllllllllllllllllllllllllang'
call writeDD p1, o., 3
say 'after write1'
call writeDD p1, o., 3
say 'after write2'
call writeDDEnd p1
say 'after ddEnd'
exit
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
if arg() > 0 then
say ' ' arg(1)
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXPIPER) cre=2016-05-03 mod=2016-05-03-13.56.30 A540769 ---
/* rexx */
call adrTso "free dd(p1)", '*'
call adrTso "alloc dd(p1) dsnType(pipe)",
"pathopts(OCREAT,OAPPEND)" ,
"pathmode(SIWUSR,SIRUSR)",
"path('/tmp/pipeEins')",
"pathdisp(delete,delete)",
"lrecl(80) RECFM(V B) blksize(8000)"
/* "path('/u/a540769/pipeEins')", */
say 'after alloc' rc
say 'reading pipe'
do forever
call readDD p1, i., 1
say time() 'read' i.1
end
call readDDEnd p1
exit
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
if arg() > 0 then
say ' ' arg(1)
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(EXPUSH) cre=2009-05-07 mod=2009-05-07-17.12.37 F540769 ---
/* rexx */
parse arg sys
say 'adrDsn sys' sys 'drei lifo sechs lifo'
push 'push 1'
queue 'queue2'
address tso 'execio * diskr drei (lifo open finis)'
push 'push 4'
queue 'queue5'
address tso 'execio * diskr sechs (lifo open finis)'
push 'push 7'
queue 'queue 8'
/*
address tso 'execio * diskr dsnin (lifo open finis)'
queue 'END queue'
address tso 'alloc dd(eins) shr ddName(dsnIn)'
say 'alloc rc' rc
address tso 'execio * diskr eins (lifo open finis)'
*/
do while queued() > 0
parse pull eins
say 'pulled' eins
end
say 'exiting'
exit
address tso 'DSN SYSTEM('sys')'
say 'rc' rc
exit
}¢--- A540769.WK.REXX(EXQUEUE) cre=2014-04-16 mod=2014-04-16-08.09.49 A540769 ---
/* rexx */
call pp
push p1
queue q2
push p3
queue q4
call pp
queue '-xis group '
queue '-dis group '
queue 'end '
queue 'und so weiter'
address tso 'dsn sys(dp4g)'
say 'dsn rc' rc
call pp
exit
pp:
do x=0 while queued() > 0
parse pull p1
say 'pulled' p1
end
say pulled x
return
}¢--- A540769.WK.REXX(EXRESULT) cre=2014-09-13 mod=2014-09-13-11.01.34 A540769 ---
xRes = 0
rc = 99
call res
say 'call result' result 'rc='rc
call res
say 'call result' result 'rc='rc
say 'fun='res() 'result' result 'rc='rc
say 'fun='res() 'result' result 'rc='rc
exit
res:
xRes = xRes + 1
return 'retRes='xRes
}¢--- A540769.WK.REXX(EXSLEEP) cre=2012-11-16 mod=2012-11-16-12.24.42 A540769 ---
/* rexx */
say 'exSleep('arg(1)')'
do i=1 to 30
call sleep 1
end
exit
/* copy sleep begin ***************************************************/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep end *****************************************************/
}¢--- A540769.WK.REXX(EXSOURCE) cre=2011-04-15 mod=2015-06-08-08.00.31 A540769 ---
/* rexx */
parse source src
say 'source' src
parse source . . nm dd dsn .
say 'name' nm 'dd' dd 'dsn' dsn
if dd \= '?' then do
say 'listDsi' listDsi(dd 'file')
say 'sysDsName' sysDsName
end
exit
}¢--- A540769.WK.REXX(EXSYSVAR) cre=2011-04-14 mod=2012-12-13-18.13.34 A540769 ---
/* rexx ****************************************************************
sysVar und mvsVar beispiele
/d symbols in eJes eingeben
&SYSALVL. = "2"
&SYSCLONE. = "13"
&SYSNAME. = "S13"
&SYSPLEX. = "PLEXA"
&SYSR1. = "SYA101"
&ALLOCXX. = "00,L"
&BPXPRMMM. = ",0M,13"
&BPXPRMXX. = "00"
&CEEXX. = "00"
&CLOCKXX. = "00"
&CNMNETID. = "CHSKA000"
&CNMRODM. = "RODMCS1"
&CNMTCPN. = "TXX51Q0"
&COMMNDXX. = "13"
&CONSOLXX. = "00"
&COUPLEXX. = "00"
&CSASIZE. = "4800"
&CSFPRMXX. = "00"
&CTCA01. = "C6"
***********************************************************************/
all= SYSALVL,
SYSCLONE,
SYSNAME,
SYSPLEX,
SYSR1,
ALLOCXX,
BPXPRMMM,
BPXPRMXX,
CEEXX,
CLOCKXX,
CNMNETID,
CNMRODM,
CNMTCPN,
COMMNDXX,
JOBNAME,
STEPNAME,
CLASS
do wx = 1 to words(all)
v = word(all, wx)
say v
say left(v, 20) mvsVar('symDef', v)
end
ALL = 'SYSNODE SYSCPU SYSSRV'
do wx = 1 to words(all)
v = word(all, wx)
say v
say left(v, 20) sysVar(v)
end
}¢--- A540769.WK.REXX(EXTIME) cre=2015-06-12 mod=2015-06-15-08.58.44 A540769 ---
/* rexx ---------------------------------------------------------------
different time helpers
1) tod: conversion years, days, seconds ==> tod
to compare to z/architecture, chap 4->timing->time-of-day
==> tod¢0..51! contains Milliseconds since 1.1.1900
without any Leapseconds (TAI time scale)
2) conversions stck/stckE <=> timestamp
stck <==> timestamp TAI10 ==> BLSUXTOD <== BLSUXTID
stckE <==> timestamp TAI10 ==> BLSUETOD <== BLSUETID
see z/OS MVS Interactive Problem Control System (IPCS) Customization
---------------------------------------------------------------------*/
call todList
exit
call timeStckE2TAI10EE x2c(left('00', 32, 'f'))
do i=4 to 20
call timeStckE2TAI10EE x2c('0'd2x(i)'0')
end
do i=0 to 20
call timeStckE2TAI10EE x2c(left(left('00D', 14, 0)d2x(i), 32, '0'))
end
call timetai102stckEEE '1966-06-12-10.00.00.0000'right(i, 2, 0)
call timetai102stckEEE '2047-06-12-10.00.00.0000'right(i, 2, 0)
do i=0 to 20
call timetai102stckEEE '2015-06-12-10.00.00.0000'right(i, 2, 0)
end
exit
todList: procedure expose m.
say ' y day secs > days seconds 64 bit tod' ,
'timestamp tai-10 by BLSUETOD'
say ' 1 3 4 6'
say ' 5 1 7 3'
call tod 0, 0, 0
call tod 0, 0, 2.5e-10
call tod 0, 0, 1e-9
call tod 0, 0, 1e-6
call tod 0, 0, 16e-6
call tod 0, 0, 1
call tod 0, 1, 0
call tod 1, 0, 0
call tod 72, 17, 0
call tod 72, 17+182, 1
call tod 73, 18, 2
call tod 109, 27, 24
call tod 112, 27+182, 25
return
tod: procedure expose m.
parse arg y, d, s
numeric digits 30
t64 = format(((y * 365 + d) * 86400 +s) * 1000000 * 4096, , 0)
stcE = right(d2c(t64), 9, '00'x) || copies('00'x, 7)
eDATE = left('', 26)
ADDRESS LINKPGM "BLSUETOD stcE EDATE"
say right(y, 3) right(d, 3) right(s, 7),
right( y * 365 + d, 6) ,
left(format((y * 365 + d) * 86400 + s, , 3, 2, 2 ), 9) ,
right(d2x(t64), 16) ,
eDate
return
timetai102stckEEE: procedure expose m.
parse arg tst
tDate = translate('56/78/yz34 hi:mn:st.abcdef', tst ,
, 'yz34-56-78-hi.mn.st.abcdef')
ACC=left('', 8, '00'x)
AEE=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
ADDRESS LINKPGM "BLSUETID TDATE AEE"
say tst 'Etid' c2x(aee)
if acc \== substr(Aee, 2, 8) then
say tst 'Xtid ' c2x(acc) '||||||||'
RETURN acc
endProcedure timetai102stckE
timeStckE2TAI10EE: PROCEDURE expose m.
parse arg stcE
stcE = left(stcE, 16, '00'x)
stck = substr(stcE, 2, 8)
TDATE = left('', 26)
eDATE = left('', 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
ADDRESS LINKPGM "BLSUETOD stcE EDATE"
say c2x(stcE) eDate
if eDate \== tDate then
say ' 'c2x(stck)left('',14, '*')tDate
return
endProcedure timeStckE2TAI10
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < length(m.time_tst01) then
return overlay(tst, m.time_tst01)
else
return left(tst, length(m.time_tst01))
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
tt = translate(tst, '000000000', '123456789')
if \(abbrev(tt,m.time_tst00)&abbrev(m.time_tst00'.000000',tt)) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 15
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 15
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.time_tst00 = '0000-00-00-00.00.00'
m.time_tst01 = '0001-01-01-00.00.00.000000'
m.time_tst99 = '9999-12-31-24.00.00.000000'
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAi10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization
BLSUETID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timetai102stckE: procedure expose m.
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timetai102stckE
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & s >>= '08')s, 20, 0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >>= '08'x)s, 16,'00'x)
/*--- TAI10 timestamp yyyy-mm.... -> stck value in hex(16) ----------*/
timeTAI102LRSN: procedure expose m.
return c2x(left(timetai102stckE(arg(1)), 10))
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
return d2x(c2d(left(timetai102stckE(tst), 9)) ,
- m.time_Zone + m.time_Leap, 18)'0000'
endProcedure timeLZT2LRSN
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
stck = left(stck, 16, '00'x)
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(timeLrsnExp(arg(1)))'000000000000'x)
endProcedure timeLrsn2TAI10
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
return timeStckE2TAI10(d2c(x2d(left(timeLrsnExp(lrsn), 18)) ,
+ m.time_Zone-m.time_Leap))
endProcedure timeLrsn2LZT
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 25
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 15
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
}¢--- A540769.WK.REXX(EXTRAP) cre=2014-01-27 mod=2014-01-27-09.06.11 A540769 ---
/* rexx testing traps -----------------------------------------------
call stack bleibt immer erhalten.
return in trap funktioniert unterschiedlich, signErr <=> callErr
call on: ist return von trap procedure,
code continues nach dem statement, das trap auslöste
signal on: ist return von der Prozedur, die trap auslöste
on syntax und on no value nur mit signal
----------------------------------------------------------------------*/
m.stack = 0
call info 'exTrap 0 vor bist Du'
call stack 10, 'bist Du da?'
call info 'exTrap 1 vor signal on novalue'
call signNoVa
call info 'exTrap 2 vor signal on syntax'
call signSyn
call info 'exTrap 3 vor signal on error'
call signErr
call info 'exTrap 3 vor call on error'
call callErr
call info 'exTrap 3 exiting'
exit
signNoVa: procedure expose m.
say 'signlNoValue throwing no value'
signal on novalue name noVaTrap
call stack 10, 'noVa'
say 'signNoValue returning after no value'
return 0
signSyn: procedure expose m.
say 'signal on syntax'
signal on syntax name synTrap
call stack 10, 'syn'
say 'signal on syntax returning after syntax'
return 0
signErr: procedure expose m.
say 'signal on error'
signal on error name errSignTrap
call stack 10, 'err'
say 'signal on error returning after error'
return 0
callErr: procedure expose m.
say 'call on error'
call on error name errCallTrap
call stack 10, 'err'
say 'call on error returning after error'
return 0
stack: procedure expose m.
parse arg lv, what
m.stack = m.stack + 1
localStack = m.stack
if lv = 1 | lv = 2 | lv = 7 then do
call info 'stack'lv
r = stack(lv-1, what)
call info 'stack'lv 'returning r='r
return '<stack local='localStack'>'
end
if lv > 0 then
return stack(lv-1, what)
call info 'stack:'
if what = 'noVa' then
x=y
else if what = 'syn' then
x=1/0
else if what = 'err' then
address tso 'tso?err'
else
say 'not implemented' what
call info 'stack returning'
return '<stack' what',local='localStack'>'
endProcedure stack
noVaTrap:
return trapInfo('no value trap', sigl)
synTrap:
return trapInfo('syntax trap', sigl)
errSignTrap:
return trapInfo('signal on error trap', sigl)
errCallTrap:
return trapInfo('call on error trap', sigl)
trapInfo:
call info arg(1) 'trapinfo begin '
say ' condition c='condition('c')', i='condition('i') ,
|| ', d='condition('d')', s='condition('s')
say ' sigl='arg(2)
say ' rc='rc', result='result
if datatype(rc, 'n') & rc > 0 then
say ' errortext='errortext(rc)
call info arg(1) 'trapinfo return'
return '<trapInfo' arg(1)', local='localStack'>'
info:
say arg(1)': m.stack='m.stack', localStack='localStack', what='what
return
}¢--- A540769.WK.REXX(EXUSSDIR) cre=2014-07-21 mod=2014-07-21-07.06.23 A540769 ---
/* rexx */
parse arg dir /* take directory path as argument */
if dir='' then
dir = 'A540769.WK'
call syscalls ON
address syscall
v_reg 1 dirlist /* register as a file server */
say 'v_reg retval' retVal errno errnoJr
v_rpn (dir) vfs vn mnt. st. /* resolve the directory path name */
say 'v_rpn retval' retVal errno errnoJr
exit
if retval=-1 then
do
say error resolving path dir - error codes: errno errnojr
return
end
i=1 /* next dir entry to read is 1 */
do forever /* loop reading directory */
v_readdir vn d. i /* read starting at next entry */
if retval=-1 then
do
say error reading directory - error codes: errno errnojr
leave
end
}¢--- A540769.WK.REXX(EXVPUT) cre=2013-03-18 mod=2013-03-18-17.04.28 A540769 ---
/* rexx */
parse arg a
call errReset hi
call adrIsp 'vGet (exVputV1 zScreen) shared', 0 8
say "shared exVPutV1 was '"exVPutV1"' zScreen" zScreen
if datatype(a, n) then do
if a > 0 then
exVputV1 = overlay('+', exVPutV1, a)
say "setting exVPutV1 to '"exVPutV1"'"
call adrIsp 'vPut exVPutV1 shared'
end
exit
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(EX1) cre=2009-12-05 mod=2011-04-15-14.20.21 A540769 ------
/* REXX */
CALL EXSOURCE
EXIT 23
}¢--- A540769.WK.REXX(EX2) cre=2009-12-05 mod=2009-12-06-00.07.57 A540769 ------
RESULT = 0
CALL EX1
SAY RC RESULT
/* REXX
PARSE UPPER ARG SSID TYPE FUN
IF WORDPOS(SSID, 'DBTF') < 1 THEN DO
CALL CHECKRTN SSID TYPE FUN
ELSE
CALL CHECKRT0 SSID TYPE FUN */
IF DATATYPE(RESULT, 'N') THEN
EXIT RESULT
ELSE
EXIT 0
EXIT
}¢--- A540769.WK.REXX(F) cre=2016-10-26 mod=2016-10-26-09.51.12 A540769 --------
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"¢"pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
if pos(c, ' jJLlu') > 0 then do /* special cases */
if c == ' ' then do /* get current timestamp */
if pos(d, 'sMAnY ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeJj') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
return fTstGen('N'd, "date('S') time('L')")
end
if c == 'j' then /* via date D */
return fTstGen('D'd, "date('s'," s", 'J')")
if c == 'J' then
return fTstGen('D'd, "date('s'," s", 'B')")
call timeIni /* via db2 timestamp */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
if c == 'u' then
return fTstGen('S'd, 'timeLRSN2LZT(timeUniq2lrsn('s'))')
end
if symbol('m.f_tstFo.c')=='VAR' & symbol('m.f_tstFo.d')=='VAR' then
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"c || d"'"
/*--- initialize f_tst --------------------------------------*/
m.f_tstIni = 1
call utIni
m.f_tstScan = 0
a = 'F_TSTFO.'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
/*---------- picture characters not in DB2 timestamp
Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 to deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplemented
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X deimplemented
jjjjj: Julian
JJJJJJ: base date (days since 1.1.0001)
llllllllll: 10 Byte LRSN
LL...: 10 Byte LRSN as 20 HexCharacters
uuuuuuuu: db2 Utility Unique
qr: minuten//10, sec ==> aa - xy base 25 ------*/
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGe2(c || d, s) /* retry after initialisation */
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic aT for source s -----------------------------*/
fTstgFF: procedure expose m.
parse arg f, aT, s
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, aT
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if pos(t, 'lLu') > 0 then
call timeIni
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
}¢--- A540769.WK.REXX(FC) cre=2010-07-16 mod=2010-07-17-14.12.07 A540769 -------
/* REXX *************************************************************
synopsis: fc fun dsn
editMacro: if dsn is missing the currently edited dataset
fc: find and count
findCount: vershiedene keys zwische fBeg und fEnd
auf einer Zeile finden, zählen plus runLängen zählen
Zeit zwischen startLrsn und endLrsn zählen und sortieren
und startRba ausgeben
LogRecord Bytes zusammenzählen
**********************************************************************/
/**** Test Data *******************************************************
1 jcl = abx(jclm) * sdf
2 jcl = abx(2clm) * sdf
3
4 abc(jclm) * sdf
5 abc 6 abc 7 abc 8 abc 9 abc
10 abc
1 jcl = abx(jclm) * sdf
1 jcl = abx(jclm) * sdf
2 jcl = abx(2clm) * sdf
**********************************************************************/
parse arg fun dsn
call errReset hi
if fun \== '' then do
if dsn = '' then
call errHelp 'dsn missing in args' fun
dsn = dsn2jcl(dsn, 1)
end
else do
call adrEdit 'macro (args) NOPROCESS'
parse var args fun dsn
if fun = '' then
fun = 'OBID('
if dsn \= '' then do
dsn = dsn2jcl(dsn, 1)
end
else do
call adrEdit '(pds) = dataset'
call adrEdit '(mbr) = member'
dsn = dsnSetMbr(pds, mbr)
end
end
numeric digits 20
call mapIni
call mapReset fc, 'k'
m.run.0 = 0
m.max.0 = 11
m.max.1 = 9e99
do kx=2 to m.max.0
m.max.kx = 0
end
say 'reading dsn' dsn
upper fun
fr = dsnAlloc('dd(in)' dsn)
if fun == 'SUBTYPE(' then
call findCount fc, fun, ')'
else if fun == 'OBID(' then
call findCount fc, fun, ')', '*LRH*'
else if fun == 'STARTLRSN=' then
call findLRSN fc, fun, 'ENDLRSN=', 'STARTRBA='
else if fun == 'abx(' then
call findCount fc, fun, ')'
else
call err 'bad fun'
call readDDEnd in
interpret subword(fr, 2)
exit
findCount: procedure expose m.
parse arg m, fBeg, fEnd, fBy
lx=0
first = 1
fByMax = 5
fByLx = 0
aBy = ''
do while readDD(in, in., 5000)
do ix=1 to in.0
lx = lx + 1
bx = pos(fBeg, in.ix)
if bx < 1 then do
if lx <= fByLx then do
if word(in.ix, 1) == fBy then do
aBy = aBy + x2d(left(word(in.ix, 2), 4))
fByLx = 0
end
end
iterate
end
ex = pos(fEnd, in.ix, bx+1)
if ex > bx then
key = substr(in.ix, bx, ex+length(fEnd)-bx)
else
key = substr(in.ix, bx, 30)
if lst = key & \ first then do
lstCnt = lstCnt + 1
end
else do
if first then
first = 0
else
call runAdd m, lst, lstLx, lstCnt, aBy
lst = key
lstLx = lx
lstCnt = 1
if fBy \== '' then
aBy = 0
end
if fBy \== '' then
fByLx = lx + fByMax
end
end
if \ first then
call runAdd m, lst, lstLx, lstCnt, aBy
call runOut m, lx
return
endProcedure findCount
findLrsn: procedure expose m.
parse arg m, fBeg, fEnd, fRba
lx=0
first = 1
mini= 9e99
maxi=-9e99
tCnt = 0
tTim = 0
do while readDD(in, in., 5000)
do ix=1 to in.0
lx = lx + 1
bx = pos(fBeg, in.ix)
if bx < 1 then
iterate
ex = pos(fEnd, in.ix)
if ex <= bx then do
say 'bad lrsn' lCnt ix in.ix
iterate
end
b = word(substr(in.ix, bx+length(fBeg)), 1)
e = word(substr(in.ix, ex+length(fEnd)), 1)
ti = (x2d(e) - x2d(b)) / 62500
tCnt = tCnt + 1
tTim = tTim + ti
if ti < mini then do
mini = ti
say 'mini' left(ti, 20) b e
end
else if ti > maxi then do
maxi = ti
say 'maxi' left(ti, 20) b e
end
do kx=m.max.0 by -1 to 1
ky = kx+1
if ti >= word(m.max.kx, 1) then
k.ky = m.max.kx
else do
r = word(substr(in.ix,
, pos(fRba, in.ix)+length(fRba)),1)
m.max.ky = left(ti, 20) r b e
leave
end
end
end
end
say tCnt 'lrsn totTime' tTim 'avgerage' (tTim / max(1, tCnt)),
'in' lx 'lines'
do kx=2 to m.max.0
say m.max.kx
end
return
endProcedure findLRSN
runAdd: procedure expose m.
parse arg m, key, lx, cnt, dx
call mapPut m, key, mapGet(m, key, 0)+cnt
if symbol('M.RUN.cnt.key') \= 'VAR' then
m.run.cnt.key = lx 0 0
parse var m.run.cnt.key l1 c1 d1
if dx \== '' then
d1 = d1 + dx
m.run.cnt.key = l1 (c1+1) d1
m.run.0 = max(m.run.0, cnt)
return
endProcedure runAdd
runOut: procedure expose m.
parse arg m, lx
kk = mapKeys(m)
say m.kk.0 'keys found, in' lx 'lines'
do kx=1 to m.kk.0
ky = m.kk.kx
say right(mapGet(m, ky), 10) ky
end
say '+++runs'
do kx=1 to m.kk.0
ky = m.kk.kx
say right(mapGet(m, ky), 10) ky
do lx=1 to m.run.0
if symbol('m.run.lx.ky') == 'VAR' then do
v = m.run.lx.ky
if word(v, 3) == '' then
t3 = ''
else
t3 = right(word(v, 3) , 12) ,
format(word(v, 3)/word(v, 2), 10, 2)
say right(lx, 20) right(word(v, 2), 6) ,
t3 '@'word(v, 1)
end
end
end
return
endProcedure runOut
findCount: procedure expose m.
parse arg m, fBeg, fEnd
lCnt=0
lst = ''
do while readDD(in, in., 5000)
do ix=1 to in.0
lCnt = lCnt + 1
bx = pos(fBeg, in.ix)
if bx < 1 then
iterate
ex = pos(fEnd, in.ix, bx+1)
if ex > bx then
key = substr(in.ix, bx, ex+length(fEnd)-bx)
else
key = substr(in.ix, bx, 30)
aByt = 0
do 4 while ix < in.0
ix = ix+1
lCnt = lCnt + 1
if word(in.ix, 1) \= '*LRH*' then
iterate
aByt = x2d(left(word(in.ix, 2), 4))
leave
end
call mapPut ff, key, mapGet(ff, key, 0)+1
if lst = key then do
lstCnt = lstCnt + 1
lstByt = lstByt + aByt
end
else do
if lst <> '' & word(lst.lst, 1) < lstCnt then do
if symbol('lst.lstCnt.lst') \= 'VAR' then
lst.lstCnt.lst = 0 0
parse var lst.lstCnt.lst c1 b1
lst.lstCnt.lst = (c1+1) (b1+lstByt)
end
lst = key
lstLx = lCnt
lstCnt = 1
lstByt = aByt
end
end
end
if lst <> '' & word(lst.lst, 1) < lstCnt then do
if symbol('lst.lstCnt.lst') \= 'VAR' then
lst.lstCnt.lst = 0 0
parse var lst.lstCnt.lst c1 b1
lst.lstCnt.lst = (c1+1) (b1+lstByt)
end
kk = mapKeys(ff)
say m.kk.0 'keys found, in' lCnt 'lines'
do kx=1 to m.kk.0
ky = m.kk.kx
say right(mapGet(ff, ky), 10) ky
end
do kx=1 to m.kk.0
ky = m.kk.kx
say right(mapGet(ff, ky), 10) ky
do lx=1 to 100
if symbol('lst.lx.ky') == 'VAR' then
say right(lx, 20) right(word(lst.lx.ky, 1), 6) ,
right(word(lst.lx.ky, 2), 10),
format(word(lst.lx.ky, 2),
/ word(lst.lx.ky, 1), 10, 2)
end
end
end
else if 1 then do
fBeg = 'STARTLRSN='
fEnd = 'ENDLRSN='
k0 = 10
k.0 = 9e99
do kx=1 to k0
k.kx = 0
end
do while readDD(in, in., 5000)
lCnt = lCnt + in.0
do ix=1 to in.0
bx = pos(fBeg, in.ix)
if bx < 1 then
iterate
ex = pos(fEnd, in.ix, bx+1)
if ex <= bx then
say 'bad lrsn' lCnt ix in.ix
else do
b = word(substr(in.ix, bx+length(fBeg)), 1)
e = word(substr(in.ix, ex+length(fEnd)), 1)
ti = (x2d(e) - x2d(b)) / 62500
do kx=k0 by -1 to 0
ky = kx+1
if ti >= word(k.kx, 1) then
k.ky = k.kx
else do
r = word(substr(in.ix,
, pos('STARTRBA=', in.ix)+9),1)
k.ky = left(ti, 20) r b e
leave
end
end
end
end
end
do kx=1 to k0
say k.kx
end
end
squash = verify(args, 'sS', 'm') > 0
find = verify(args, 'fF', 'm') > 0
say 'macro args' args 'squash='squash 'find='find
parse var args delta fnd
if left(args, 1) = '?' | translate(left(args, 4)) = 'HELP' then
exit help()
call adrEdit 'process range Q R', 4
call adrEdit '(lf) = linenum .zfrange'
call adrEdit '(lT) = linenum .zLrange'
say 'dopWeg from line' lf 'to' lt
lStop = lT
call adrEdit "(laLi) = line" lf
lnx = lf + 1
cnt = 0
do while lnx <= lStop
call adrEdit "(nxLi) = line" lnx
if squash then
dop = space(laLi, 1) == space(nxLi, 1)
else
dop = laLi == nxLi
if dop then do
if find then do
say 'doppelte Zeilen' (lnx-1) lnx
call adrEdit 'locate' (lnx-1)
exit
end
else do
call adrEdit 'delete' lnx
lStop = lSTop - 1
cnt = cnt + 1
end
end
else do
lnx = lnx + 1
laLi = nxLi
end
end
say 'deleted' cnt 'duplicate lines'
exit
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
opt = left('K', m.map.keys.a \== '')
if opt == 'K' then
call mAdd m.map.Keys.a, ky
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
oldTrap = outtrap()
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
if oldTrap = '' then
call outtrap off
else
call outtrap oldTrap append
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(FILETSO) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 ---
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg || copies('.*', pos('*', arg) < 1)" ,
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
}¢--- A540769.WK.REXX(FILINUX) cre=2015-07-06 mod=2015-07-06-09.58.39 A540769 ---
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_V
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class_V
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
}¢--- A540769.WK.REXX(FMT) cre=2013-11-19 mod=2013-11-19-12.09.35 A540769 ------
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
}¢--- A540769.WK.REXX(FMTF) cre=2013-11-19 mod=2013-11-19-12.09.35 A540769 -----
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFTab: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = 'FMTF.F'
return fmtFWriteSt(fmtFReset('FMTF.F'), j2Buf(rdr)'.BUF', wiTi)
endProcedure fmtFTab
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteSt: procedure expose m. ?????????
parse arg m, st, wiTi
if m.st.0 < 1 then
return 0
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(m.st.1)
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, m.st.sx)
end
return st.0
fmtFWriteSt
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = m.st.sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa */
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
f1 = substr(format(nMa, 2, 2, 9, 0), 7)
if f1 \= '' then
eMa = max(eMa, f1)
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo */
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
}¢--- A540769.WK.REXX(FTAB) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 -----
/* copy fTab begin ****************************************************
output Modes: t = tableMode 1 line per object with fixed colums th
c = colMode 1 line per column/field of object
we build a format for each column
and a set of title lines, one sequence printed before
, one sequence printed after
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * fTabAdd * add col info
sqlFTabOthers ?
fTabGenTab or fTabGenCol
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
primary data for each col
.col : column (rexx) name plus aDone
.done : == 0 sqlFtabOthers should add it again
.fmt : format
.labelLo : long label for multi line cycle titles
.labelSh : short label for singel title line (colwidth)
.tit.* : title line piece for this col
**********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.verbose = pos('s', m.m.opt) < 1 /* not silent */
m.m.0 = 0
m.m.set.0 = 0
return fTabResetCols(oMutate(m, m.fTab_class))
endProcedure fTabReset
/*--- clean out all cols of ftab, but keep settings -----------------*/
fTabResetCols: procedure expose m.
parse arg m
m.m.0 = 0
return m
/*--- for column cx set title tx ------------------------------------*/
fTabSetTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if tx > m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabSetTit
/*--- set default atts for a col name ------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, sh, lo
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelSh = sh
m.m.set.sx.labelLo = lo
m.m.set.c1 = sx
return
endProcedure fTabSet
/*--- add a column --------------------------------------------------
m, rexxName done, fmt, labelShort, labelLong, titles... ------*/
fTabAdd: procedure expose m.
parse arg m, rxNm aDone
m.m.generated = ''
cx = m.m.0 + 1
m.m.0 = cx
cc = m'.'cx
m.cc.col = rxNm
m.cc.done = aDone \== 0
parse arg , , m.cc.fmt, m.cc.labelSh, m.cc.labelLo
if rxNm == '=' | rxNm == 0 | rxNm == 1 then
call err 'bad rxNm' rxNm
if \ (aDone == '' | aDone == 0 | aDone == 1) then
call err 'bad aDone' aDone
m.cc.tit.0 = max(arg()-4, 1)
m.cc.tit.1 = ''
do tx=2 to m.cc.tit.0
m.cc.tit.tx = arg(tx+4)
end
return cc
endProcedure fTabAdd
/*--- complete column info-------------------------------------------*/
fTabColComplete: procedure expose m.
parse arg m
do cx=1 to m.m.0
nm = m.m.cx.col
f1 = m.m.cx.fmt
if f1 = '' then
m.m.cx.fmt = '@.'nm'%-8C'
else do
px = pos('%', f1)
ax = pos('@', f1)
if px > 0 & (ax <= 0 | ax >= px) then
m.m.cx.fmt = left(f1, px-1)'@.'nm || substr(f1, px)
end
if m.m.cx.labelLo = '' then
if nm = '' then
m.m.cx.labelLo = '='
else
m.m.cx.labelLo = nm
if m.m.cx.labelSh = '' then
m.m.cx.labelSh = m.m.cx.labelLo
end
return
endProcedure fTabColComplete
/*--- generate line formats and title lines -------------------------*/
fTabGenTab: procedure expose m.
parse arg m, sep
if m.m.generated == '' then
call fTabColComplete m
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
f = ''
tLen = 0
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelSh
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelSh) < 1 then /* corrupted| */
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelSh, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fGen('%>', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
/*try with cycle lines for cSta to cEnd */
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelLo
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelLo
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelLo) ,
= translate(m.m.kx.labelSh)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenTab
/*--- generate column format ----------------------------------------*/
fTabGenCol: procedure expose m.
parse arg m
if m.m.generated == '' then
call fTabColComplete m
do kx=1 to m.m.0
t = m.m.kx.labelLo
l = if(m.m.kx.labelSh == t, , m.m.kx.labelSh)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabGenCol
/*--- output all of rdr in tab format -------------------------------*/
fTab: procedure expose m.
parse arg m, rdr
if pos('a', m.m.opt) < 1 then
i = rdr
else do
i = in2Buf(rdr)
if m.i.buf.0 > 0 then
call fTabDetect m, i'.BUF'
end
if pos('o', m.m.opt) > 0 then do
call pipeWriteAll i
end
else if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
i = jOpen(in2file(i), '<')
do rx=1 while jRead(i)
call out left('--- row' rx '', 80, '-')
call fTabCol m, m.i
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
call jClose i
end
else do
call fTabBegin m
call fAll m.m.fmt, i
return fTabEnd(m)
end
return m
endProcedure fTab
/*--- output object i in col format ---------------------------------*/
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenTab m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr
if m == '' then
m = fTabReset(f_auto, 1, , 'a')
else if pos('a', m.m.opt) < 1 then
m.m.opt = 'a'm.m.opt
return fTab(m, rdr)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
do cx=1 to m.m.0
rxNm = m.m.cx.col
done.rxNm = m.m.cx.done
if m.m.cx.fmt == '' then
m.m.cx.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
ff = oFldD(m.b.1)
do fx=1 to m.ff.0
rxNm = substr(m.ff.fx, 2)
if done.rxNm \== 1 then do
cc = fTabAdd(m, rxNm)
m.cc.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabDetectFmt: procedure expose m.
parse arg st, suf
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
return '%'newFo
endProcedure fTabDetectFmt
/* copy fTab end ***************************************************/
}¢--- A540769.WK.REXX(GB#V310) cre=2013-09-12 mod=2013-09-20-11.32.33 A540769 ---
/*REXX ****************************************************************/
/* OUTPUT ANPASSEN FüR MAILVERSAND */
/* */
/* ERSTELLT : 24.09.2004 */
/* OWNER : A754048 Alessandro */
/* UPDATE : 13.09.13 Walter dbSys rausholen, ZwischenTit eliminieren*/
/* rz/dbSys/jobname in mail einfuegen */
/* : 22.01.2007, Walter Keller */
/**********************************************************************/
say 'GB#V310 version 13.9.2013'
if 0 then do /* allocates for online test */
call dsnAlloc 'dd(mailin) shr DBTF.DBAA.LCTL(QM416215)'
call dsnAlloc 'dd(in) shr DSN.QM416T7P.MAIL1'
call dsnAlloc 'dd(out) shr A540769.tmp.text(mailOut) reuse'
end
inDsn = '=IN'
mailin = '=MAILIN'
outDsn = '=OUT'
subjextX = 0
text1x = 0
ox = 0
/* mailIn einlesen: mail Skeleton --------*/
call readDsn mailIn, ma.
do mx=1 to ma.0 /* jede skeleton Zeile */
ox = ox + 1
out.ox = left(ma.mx, 79)
if wordPos($SUB, ma.mx) > 0 then do
subjectX = ox
end
else if strip(ma.mx) = '$@TEXT' then do
text1x = ox
ox = ox + 1
schwWe = sqlOutput()
end
end /* jede skeleton Zeile */
if text1x = 0 then
call err 'no $@TEXT in mailIn'
if subjectX = 0 then
call err 'no $SUB in mailIn'
/* subjekt und text ergänzen -------------*/
if schwWe = 0 then do
sub = 'OK'
su2 = 'Alles im grünen Bereich |||'
end
else do
sub = schwWe 'Schwellen erreicht'
su2 = sub
end
out.text1x = ' Gigabyte Grenze' sysvar(sysnode)'/'db2sys':' su2
text2x = text1x + 1
out.text2x = ' Job' mvsVar('SYMDEF', 'JOBNAME') 'um' time()',' date()
out.subjectX = strip(delStr(out.subjectX,
, pos('$SUB', out.subjectX), 4)) ,
sysvar(sysnode)'/'db2sys':' sub
/* output schreiben ----------------------*/
call writeDsn outDsn, out., ox ,1
exit
/*--- den SqlOuptut lesen und gefiltert in den Output schreiben ------*/
sqlOutput:
cnt = 0
cntLast = 0
headSta = -9
cntSucc = 0
cntSpec = 0
special = 0
db2sys = ''
call readDsn inDsn, in.
lastSucc = ox
do ix=1 to in.0 /* every input line */
w1 = translate(word(substr(in.ix, 2), 1))
l3 = left(w1, 3)
x1 = pos(w1, in.ix, 2)
ox = ox + 1
select
when w1 == '--$SPECIAL' then do
special = 1
ox = ox - 1
end
when l3 = '--\' then do
out.ox = '*'substr(in.ix, x1+3, 78)
end
when l3 = '--*' | (l3 = '--/' & cntLast > 0) then do
out.ox = '*'substr(in.ix, x1+3, 78)
lastSucc = ox
end
when abbrev(w1, '+--') then do /* separator line */
out.ox = substr(in.ix, x1, 79)
if headSta = -9 then do /* begin output */
headSta = ix
head1 = out.ox
end
else if ix > headSta+2 & out.ox = head1 then do
ox = ox - 1 /* do not show page title */
end
end
when right(w1, 1) = '|' & right(w1, 2) <> '||' then do
/* data line */
out.ox = substr(in.ix, pos('|', in.ix), 79)
if ix = headSta + 1 then do
head2 = out.ox /* column title */
end
else if ix = headSta + 3 then do
/* first data line
do we find db2Sys? */
s0 = pos(' server ', head2)
if s0 > 0 then do
s1 = length(strip(left(head2, s0)))
s2 = word(substr(out.ox, s1+1), 1)
s3 = right(s2, 4)
if db2sys = '' then
db2sys = s3
else if db2sys <> s3 then
call err 'db2sys mismatch' db2sys '<>' s3,
'in line' ix in.ix
end
end
else if out.ox = head2 then
ox = ox-1 /* do not show page title */
end
when w1 = 'SUCCESSFUL' then do /* end of output */
cntSucc = cntSucc + 1
if headSta > 0 then do
out.ox = head1
ox = ox + 1
headSta = -9
head2 = ''
end
parse upper var in.ix 2 suc ret of cntLast rw .
if ^ ( suc == 'SUCCESSFUL' & ret == 'RETRIEVAL',
& abbrev(rw, 'ROW') & datatype(cntLast, 'N')) then
call err 'bad SUCCESSFUL row' ix':' in.ix
if cntLast > 0 then do
ox = ox - 1
lastSucc = ox
if special then
cntSpec = cntSpec + cntLast
else
cnt = cnt + cntLast
special = 0
end
else do
ox = lastSucc /* do not output previous lines */
end
end
otherwise do
ox = ox - 1 /* do not output this line */
end
end /* select */
end /* every input line */
say in.0 'inputLines,' cntSucc 'selects,' cnt 'selected rows,' ,
cntSpec 'special rows'
return cnt
endProcedure sqlOutput
err:
call errA arg(1), 1
endSubroutine err
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' | addPrefix = 0 then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 2))
addPref = pos('~', spec) > 0
if addPref then
spec = strip(spec, 'b', '~')
do wx=1 to 3
w = word(spec, wx)
if w = '' then
leave
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if m.dsnAlloc.dsn = '' then
m.dsnAlloc.dsn = dsn2jcl(w, addPref)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
if m.dsnAlloc.dsn <> '' then
disp = disp "dsn('"m.dsnAlloc.dsn"')"
call adrTso 'alloc dd('dd')' disp subword(spec, wx)
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
call errA arg(1), 1
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt, ggHist
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
if ggHist ^== 1 then
exit setRc(12)
say 'divide by zero to show stack history'
x = 1 / 0
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggMsg
call help
call err ggMsg
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return current time and cpu usage ------------------------------*/
showtime: procedure
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* Programm Ende ---------------------------------------*/
/**********************************************************************/
}¢--- A540769.WK.REXX(GEBDUP) cre=2011-07-15 mod=2011-07-15-14.25.11 A540769 ---
numeric digits 22
n = 1e6
do g=1 to 50
say 'n' n 'g' g '==>' dup(n, g)
end
exit
dup: procedure expose m.
parse arg n , g
r =1e0
do y=0 to g-1
r = r * (n-g-y) / (n-y)
end
return r
}¢--- A540769.WK.REXX(IFICOM) cre=2009-10-27 mod=2009-10-27-08.30.00 A540769 ---
/* REXX */ 00010000
/* */ 00020000
/* Sample DB2 Stored procedure, as described in */ 00030000
/* Application Programming Guide */ 00040000
/* */ 00050000
/* SP executes DB2 Command via the IFI Interface */ 00060000
/* */ 00070000
/* 'CALLRX01' in A979074.TSO.EXEC is a sample caller program */ 00080000
/* for SP 'COMMAND' */ 00090000
/* 'CPROCX01' in A979074.RZ1.SPUFI.CNTL contains Proc Definition*/ 00100000
/* */ 00110000
/* CREATE PROCEDURE SYSPROC.COMMAND */ 00120000
/* (IN CMDTEXT VARCHAR(254), */ 00130000
/* OUT CMDRESULT VARCHAR(32704)) */ 00140000
/* LANGUAGE REXX */ 00150000
/* EXTERNAL NAME COMMAND */ 00160000
/* NO COLLID */ 00170000
/* ASUTIME NO LIMIT */ 00180000
/* PARAMETER STYLE GENERAL */ 00190000
/* STAY RESIDENT NO */ 00200000
/* RUN OPTIONS 'TRAP(ON)' */ 00210000
/* WLM ENVIRONMENT DB2DSNR */ 00220000
/* SECURITY DB2 */ 00230000
/* DYNAMIC RESULT SETS 1 */ 00240000
/* COMMIT ON RETURN NO */ 00250000
/* ; */ 00260000
/* */ 00270000
/* */ 00280000
/* */ 00290000
PARSE UPPER ARG CMD /* Get the DB2 command text */ 00300000
00310000
/* Remove enclosing quotes */ 00320000
IF LEFT(CMD,2) = ""'" & RIGHT(CMD,2) = "'"" THEN 00330000
CMD = SUBSTR(CMD,2,LENGTH(CMD)-2) 00340000
ELSE 00350000
IF LEFT(CMD,2) = """'" & RIGHT(CMD,2) = "'""" THEN 00360000
CMD = SUBSTR(CMD,3,LENGTH(CMD)-4) 00370000
00380000
COMMAND = SUBSTR("COMMAND",1,18," ") 00390000
00400000
say time(NORMAL)': Executing Command 'cmd 00410000
00420000
/****************************************************************/ 00430000
/* Set up the IFCA, return area, and output area for the */ 00440000
/* IFI COMMAND call. */ 00450000
/****************************************************************/ 00460000
IFCA = SUBSTR('00'X,1,180,'00'X) 00470000
IFCA = OVERLAY(D2C(LENGTH(IFCA),2),IFCA,1+0) 00480000
IFCA = OVERLAY("IFCA",IFCA,4+1) 00490000
RTRNAREASIZE = 262144 /*1048572*/ 00500000
RTRNAREA = D2C(RTRNAREASIZE+4,4)LEFT(' ',RTRNAREASIZE,' ') 00510000
OUTPUT = D2C(LENGTH(CMD)+4,2)||'0000'X||CMD 00520000
BUFFER = SUBSTR(" ",1,16," ") 00530000
00540000
00550000
/****************************************************************/ 00560000
/* Make the IFI COMMAND call. */ 00570000
/****************************************************************/ 00580000
ADDRESS LINKPGM "DSNWLIR COMMAND IFCA RTRNAREA OUTPUT" 00590000
WRC = RC 00600000
RTRN= SUBSTR(IFCA,12+1,4) 00610000
REAS= SUBSTR(IFCA,16+1,4) 00620000
TOTLEN = C2D(SUBSTR(IFCA,20+1,4)) 00630000
00640000
00650000
/****************************************************************/ 00660000
/* Set up the host command environment for SQL calls. */ 00670000
/****************************************************************/ 00680000
"SUBCOM DSNREXX" /* Host cmd env available? */ 00690000
IF RC THEN /* No--add host cmd env */ 00700000
S_RC = RXSUBCOM('ADD','DSNREXX','DSNREXX') 00710000
00720000
00730000
/****************************************************************/ 00740000
/* Set up SQL statements to insert command output messages */ 00750000
/* into a temporary table. */ 00760000
/****************************************************************/ 00770000
SQLSTMT='INSERT INTO SYSIBM.SYSPRINT(SEQNO,TEXT) VALUES(?,?)' 00780000
00790000
ADDRESS DSNREXX "EXECSQL DECLARE C1 CURSOR FOR S1" 00800000
IF SQLCODE <> 0 THEN CALL SQLCA 00810000
00820000
ADDRESS DSNREXX "EXECSQL PREPARE S1 FROM :SQLSTMT" 00830000
IF SQLCODE <> 0 THEN CALL SQLCA 00840000
00850000
00860000
/****************************************************************/ 00870000
/* Extract messages from the return area and insert them into */ 00880000
/* the temporary table. */ 00890000
/****************************************************************/ 00900000
SEQNO = 0 00910000
OFFSET = 4+1 00920000
DO WHILE ( OFFSET < TOTLEN ) 00930000
LEN = C2D(SUBSTR(RTRNAREA,OFFSET,2)) 00940000
SEQNO = SEQNO + 1 00950000
TEXT = SUBSTR(RTRNAREA,OFFSET+4,LEN-4-1) 00960000
ADDRESS DSNREXX "EXECSQL EXECUTE S1 USING :SEQNO,:TEXT" 00970000
IF SQLCODE <> 0 THEN CALL SQLCA 00980000
OFFSET = OFFSET + LEN 00990000
END 01000000
01010000
01020000
/****************************************************************/ 01030000
/* Set up a cursor for a result set that contains the command */ 01040000
/* output messages from the temporary table. */ 01050000
/****************************************************************/ 01060000
01070000
SQLSTMT='SELECT SEQNO,TEXT FROM SYSIBM.SYSPRINT ORDER BY SEQNO' 01080000
ADDRESS DSNREXX "EXECSQL DECLARE C2 CURSOR FOR S2" 01090000
IF SQLCODE <> 0 THEN CALL SQLCA 01100000
01110000
ADDRESS DSNREXX "EXECSQL PREPARE S2 FROM :SQLSTMT" 01120000
IF SQLCODE <> 0 THEN CALL SQLCA 01130000
01140000
01150000
/****************************************************************/ 01160000
/* Open the cursor to return the message output result set to */ 01170000
/* the caller. */ 01180000
/****************************************************************/ 01190000
ADDRESS DSNREXX "EXECSQL OPEN C2" 01200000
IF SQLCODE <> 0 THEN CALL SQLCA 01210000
01220000
01230000
S_RC = RXSUBCOM('DELETE','DSNREXX','DSNREXX') /* REMOVE CMD ENV */ 01240000
EXIT SUBSTR(RTRNAREA,1,TOTLEN+4) 01250000
01260000
01270000
/****************************************************************/ 01280000
/* Routine to display the SQLCA */ 01290000
/****************************************************************/ 01300000
SQLCA: 01310000
SAY 'SQLCODE ='SQLCODE 01320000
SAY 'SQLERRMC ='SQLERRMC 01330000
SAY 'SQLERRP ='SQLERRP 01340000
01350000
SAY 'SQLERRD ='SQLERRD.1',', 01360000
|| SQLERRD.2',', 01370000
|| SQLERRD.3',', 01380000
|| SQLERRD.4',', 01390000
|| SQLERRD.5',', 01400000
|| SQLERRD.6 01410000
01420000
SAY 'SQLWARN ='SQLWARN.0',', 01430000
|| SQLWARN.1',', 01440000
|| SQLWARN.2',', 01450000
|| SQLWARN.3',', 01460000
|| SQLWARN.4',', 01470000
|| SQLWARN.5',', 01480000
|| SQLWARN.6',', 01490000
|| SQLWARN.7',', 01500000
|| SQLWARN.8',', 01510000
|| SQLWARN.9',', 01520000
|| SQLWARN.10 01530000
01540000
SAY 'SQLSTATE='SQLSTATE 01550000
SAY 'SQLCODE ='SQLCODE 01560000
EXIT 'SQLERRMC ='SQLERRMC';' , 01570000
|| 'SQLERRP ='SQLERRP';' , 01580000
|| 'SQLERRD ='SQLERRD.1',', 01590000
|| SQLERRD.2',', 01600000
|| SQLERRD.3',', 01610000
|| SQLERRD.4',', 01620000
|| SQLERRD.5',', 01630000
|| SQLERRD.6';' , 01640000
|| 'SQLWARN ='SQLWARN.0',', 01650000
|| SQLWARN.1',', 01660000
|| SQLWARN.2',', 01670000
|| SQLWARN.3',', 01680000
|| SQLWARN.4',', 01690000
|| SQLWARN.5',', 01700000
|| SQLWARN.6',', 01710000
|| SQLWARN.7',', 01720000
|| SQLWARN.8',', 01730000
|| SQLWARN.9',', 01740000
|| SQLWARN.10';' , 01750000
|| 'SQLSTATE='SQLSTATE';' 01760000
01770000
01780000
}¢--- A540769.WK.REXX(IFICOMCA) cre=2009-10-27 mod=2009-10-27-08.30.50 A540769 ---
/* REXX */ 00010000
/* */ 00020000
/* Sample Caller Program for a DB2 Stored Procedure */ 00030000
/* (from the Application programming guide) */ 00040000
/* */ 00050000
/* 'CALLRX01' in A979074.TSO.EXEC is a sample caller program */ 00060000
/* for Stored Procedure 'COMMAND', as defined in */ 00070000
/* 'COMMAND' in A979074.TSO.EXEC */ 00080000
/* */ 00090000
/* call from ISPF: TSO CALLRX01 DBTF -DIS GROUP */ 00100000
/* */ 00110000
/* check that WLM Environment DB2DSNR is AVAILABLE on the SYSPLEX */ 00120000
/* DISPLAY WLM,APPLENV=DB2DSNR */ 00130000
/* VARY WLM,APPLENV=DB2DSNR,RESUME or REFRESH */ 00140000
/* */ 00150000
/* check that procedure is started on the target DB2 */ 00160000
/* -DIS PROCEDURE SYSPROC.COMMAND SCOPE(GROUP) */ 00170000
/* -STA PROCEDURE SYSPROC.COMMAND SCOPE(GROUP) */ 00180000
/* */ 00190000
PARSE ARG a_ssid a_cmd /* Get the SSID to connect to */ 00200000
/* and the DB2 command to be */ 00210000
/* executed */ 00220000
00230000
debug=0 00240000
debug=1 00250000
00260000
rzid = sysvar(sysnode) 00270000
if debug then say " .. rzid="rzid 00280000
00290000
address tso; 00300000
netid = 'CHSKA000' 00310000
default_schema = 'SYSPROC' 00320000
if rzid = 'RZ1' then conn_ssid = 'DBAF'; 00330000
if rzid = 'RZ2' then conn_ssid = 'DBOF'; 00340000
if rzid = 'RZ4' then conn_ssid = 'DB2I'; 00350000
if rzid = 'RR2' then conn_ssid = 'DBOF'; 00360000
if rzid = 'RR4' then conn_ssid = 'DB2I'; 00370000
00380000
00390000
target_ssid=strip(a_ssid) 00400000
if debug then say 'Target SSID='target_ssid', length='length(ssid) 00410000
target_loc=netid || target_ssid 00420000
target_loc_string=target_loc || '.' || default_schema || '.' 00430000
00440000
target_cmd=strip(a_cmd) 00450000
if debug then say 'DB2 CMD='target_cmd 00460000
00470000
00480000
/****************************************************************/ 00490000
/* Set up the host command environment for SQL calls. */ 00500000
/****************************************************************/ 00510000
"SUBCOM DSNREXX" /* Host cmd env available? */ 00520000
URC=RC 00530000
if debug then say 'RC from SUBCOM='urc 00540000
IF URC THEN /* No--make one */ 00550000
S_RC = RXSUBCOM('ADD','DSNREXX','DSNREXX') 00560000
00570000
00580000
/****************************************************************/ 00590000
/* CAF Connect to the Primary Connection DB2 subsystem. */ 00600000
/****************************************************************/ 00610000
if debug then say 'CONNECT to 'conn_ssid 00620000
ADDRESS DSNREXX "CONNECT "conn_ssid 00630000
IF SQLCODE <> 0 THEN CALL SQLCA 00640000
if debug then say 'Connection to 'conn_ssid' established' 00650000
00660000
00670000
ST_PROC = 'COMMAND' 00680000
00690000
if target_ssid <> conn_ssid then do 00700000
if debug then say 'DRDA CONNECT to 'target_loc 00710000
ADDRESS DSNREXX "EXECSQL CONNECT to "target_loc 00720000
IF SQLCODE < 0 THEN CALL SQLCA 00730000
if debug then say 'DRDA CONNECTION TO 'target_loc' established' 00740000
end 00750000
if debug then say 'Stored Procedure = 'ST_PROC 00760000
00770000
RESULTSIZE = 32703 00780000
RESULT = LEFT(' ',RESULTSIZE,' ') 00790000
00800000
/****************************************************************/ 00810000
/* Call the stored procedure that executes the DB2 command. */ 00820000
/* The input variable (COMMAND) contains the DB2 command. */ 00830000
/* The output variable (RESULT) will contain the return area */ 00840000
/* from the IFI COMMAND call after the stored procedure */ 00850000
/* executes. */ 00860000
/****************************************************************/ 00870000
00880000
ADDRESS DSNREXX "EXECSQL SET CURRENT SQLID='S100447'"; 00890000
IF SQLCODE < 0 THEN CALL SQLCA 00900000
00910000
ADDRESS DSNREXX "EXECSQL" , 00920000
"CALL" ST_PROC "(:TARGET_CMD, :RESULT)" 00930000
00940000
IF SQLCODE < 0 THEN CALL SQLCA 00950000
00960000
if debug then do 00970000
SAY 'RETCODE ='RETCODE 00980000
SAY 'SQLCODE ='SQLCODE 00990000
SAY 'SQLERRMC ='SQLERRMC 01000000
SAY 'SQLERRP ='SQLERRP 01010000
SAY 'SQLERRD ='SQLERRD.1',', 01020000
|| SQLERRD.2',', 01030000
|| SQLERRD.3',', 01040000
|| SQLERRD.4',', 01050000
|| SQLERRD.5',', 01060000
|| SQLERRD.6 01070000
SAY 'SQLWARN ='SQLWARN.0',', 01080000
|| SQLWARN.1',', 01090000
|| SQLWARN.2',', 01100000
|| SQLWARN.3',', 01110000
|| SQLWARN.4',', 01120000
|| SQLWARN.5',', 01130000
|| SQLWARN.6',', 01140000
|| SQLWARN.7',', 01150000
|| SQLWARN.8',', 01160000
|| SQLWARN.9',', 01170000
|| SQLWARN.10 01180000
SAY 'SQLSTATE='SQLSTATE 01190000
SAY C2X(RESULT) "'"||RESULT||"'" 01200000
end 01210000
01220000
/****************************************************************/ 01230000
/* Display the IFI return area in hexadecimal. */ 01240000
/****************************************************************/ 01250000
OFFSET = 4+1 01260000
TOTLEN = LENGTH(RESULT) 01270000
DO WHILE ( OFFSET < TOTLEN ) 01280000
LEN = C2D(SUBSTR(RESULT,OFFSET,2)) 01290000
SAY SUBSTR(RESULT,OFFSET+4,LEN-4-1) 01300000
OFFSET = OFFSET + LEN 01310000
END 01320000
01330000
01340000
/****************************************************************/ 01350000
/* Get information about result sets returned by the */ 01360000
/* stored procedure. */ 01370000
/****************************************************************/ 01380000
ADDRESS DSNREXX "EXECSQL DESCRIBE PROCEDURE :PROC INTO :SQLDA" 01390000
IF SQLCODE <> 0 THEN CALL SQLCA 01400000
01410000
say ' ' 01420000
say ' ' 01430000
say ' ' 01440000
say ' ' 01450000
DO I = 1 TO SQLDA.SQLD 01460000
SAY "SQLDA."I".SQLNAME ="SQLDA.I.SQLNAME";" 01470000
SAY "SQLDA."I".SQLTYPE ="SQLDA.I.SQLTYPE";" 01480000
SAY "SQLDA."I".SQLLOCATOR ="SQLDA.I.SQLLOCATOR";" 01490000
SAY "SQLDA."I".SQLESTIMATE="SQLDA.I.SQLESTIMATE";" 01500000
END I 01510000
01520000
01530000
/****************************************************************/ 01540000
/* Set up a cursor to retrieve the rows from the result */ 01550000
/* set. */ 01560000
/****************************************************************/ 01570000
ADDRESS DSNREXX 01580000
"EXECSQL ASSOCIATE LOCATOR (:RESULT) WITH PROCEDURE :PROC" 01590000
01600000
IF SQLCODE <> 0 THEN CALL SQLCA 01610000
01620000
SAY RESULT 01630000
ADDRESS DSNREXX "EXECSQL ALLOCATE C101 CURSOR FOR RESULT SET :RESULT" 01640000
IF SQLCODE <> 0 THEN CALL SQLCA 01650000
01660000
CURSOR = 'C101' 01670000
ADDRESS DSNREXX "EXECSQL DESCRIBE CURSOR :CURSOR INTO :SQLDA" 01680000
IF SQLCODE <> 0 THEN CALL SQLCA 01690000
01700000
01710000
/****************************************************************/ 01720000
/* Retrieve and display the rows from the result set, which */ 01730000
/* contain the command output message text. */ 01740000
/****************************************************************/ 01750000
DO UNTIL(SQLCODE <> 0) 01760000
ADDRESS DSNREXX "EXECSQL FETCH C101 INTO :SEQNO, :TEXT" 01770000
IF SQLCODE = 0 THEN DO 01780000
SAY TEXT 01790000
END 01800000
END 01810000
01820000
IF SQLCODE <> 0 THEN CALL SQLCA 01830000
ADDRESS DSNREXX "EXECSQL CLOSE C101" 01840000
IF SQLCODE <> 0 THEN CALL SQLCA 01850000
01860000
ADDRESS DSNREXX "EXECSQL COMMIT" 01870000
IF SQLCODE <> 0 THEN CALL SQLCA 01880000
01890000
01900000
/****************************************************************/ 01910000
/* Disconnect from the DB2 subsystem. */ 01920000
/****************************************************************/ 01930000
ADDRESS DSNREXX "DISCONNECT" 01940000
IF SQLCODE <> 0 THEN CALL SQLCA 01950000
01960000
01970000
/****************************************************************/ 01980000
/* Delete the host command environment for SQL. */ 01990000
/****************************************************************/ 02000000
S_RC = RXSUBCOM('DELETE','DSNREXX','DSNREXX') /* REMOVE CMD ENV */ 02010000
RETURN 02020000
02030000
02040000
/****************************************************************/ 02050000
/* Routine to display the SQLCA */ 02060000
/****************************************************************/ 02070000
SQLCA: 02080000
TRACE O 02090000
SAY 'SQLCODE ='SQLCODE 02100000
SAY 'SQLERRMC ='SQLERRMC 02110000
SAY 'SQLERRP ='SQLERRP 02120000
SAY 'SQLERRD ='SQLERRD.1',', 02130000
|| SQLERRD.2',', 02140000
|| SQLERRD.3',', 02150000
|| SQLERRD.4',', 02160000
|| SQLERRD.5',', 02170000
|| SQLERRD.6 02180000
SAY 'SQLWARN ='SQLWARN.0',', 02190000
|| SQLWARN.1',', 02200000
|| SQLWARN.2',', 02210000
|| SQLWARN.3',', 02220000
|| SQLWARN.4',', 02230000
|| SQLWARN.5',', 02240000
|| SQLWARN.6',', 02250000
|| SQLWARN.7',', 02260000
|| SQLWARN.8',', 02270000
|| SQLWARN.9',', 02280000
|| SQLWARN.10 02290000
SAY 'SQLSTATE='SQLSTATE ; 02300000
EXIT; 02310000
}¢--- A540769.WK.REXX(II) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 -------
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DP4G DBOL'
m.ii_rzDbCsmF = 'RZ2/DVBP RR2/DVBP' /* 'RQ2/DVBP' */ ,
'RZZ/DEVG RZY/DEVG RZX/DEVG'
m.ii_rzDbCsmT = 'S25/DVBP R25/DVBP' /* 'Q25/DVBP' */ ,
'Z25/DEVG Y25/DEVG X25/DEVG'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiRz2Sys: procedure expose m.
parse arg rz
return iiGet(rz2sys, rz)
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
call iiIni
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
ii2RzDb:procedure expose m.
parse arg a, forCsm
r = ii2rzDbS(a, forCsm)
if r \== '' then
return r
else
return err('i}no rz/dbSys for' a)
ii2RzDbS:procedure expose m.
parse upper arg a, forCsm
if pos('/', a) > 0 then
parse var a r '/' d
else if length(a) == 2 then
parse var a r 2 d
else
parse var a d r
myRz = sysvar(sysnode)
call iiIni
if r == '' then
r2 = myRz
else if length(r) <> 1 then
r2 = r
else do
r2 = iiGet(plex2rz, r, '^')
if r2 == '' then
r2 = iiGet(c2rz, r, '^')
end
if length(d) == 4 then
d2 = d
else do
if symbol('m.ii_rz2db.r2') \== 'VAR' then
return ''
if d == '' then do
if myRz == 'RZ4' then
d2 = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
d2 = 'DX0G'
else
return ''
end
else do
x = pos(d, m.ii_rz2db.r2)
if x < 1 then
return ''
d2 = substr(m.ii_rz2db.r2,
, lastPos(' ', m.ii_rz2db.r2, x)+1,4)
end
end
if r2 = myRz then
return '*/'d2
res = translate(r2'/'d2)
if forCsm \==1 | wordPos(res, m.ii_rzDbCsmF) < 1 then
return res
else
return word(m.ii_rzDbCsmT, wordPos(res, m.ii_rzDbCsmF))
endProcedure ii2RzDbS
/* copy ii end ********* Installation Info *************************/
}¢--- A540769.WK.REXX(IICONFIG) cre=2016-04-17 mod=2016-04-17-17.12.44 A540769 ---
iiConfig 1.0
rz
RZ0 0 T S0 DBTC DBIA
RZX X X X2 DE0G DEVG DX0G DPXG
RZY Y Y Y2 DE0G DEVG DPYG
RZZ Z Z Z2 DE0G DEVG DPZG
RQ2 Q Q Q2 DBOF DVBP DP2G
RR2 R R R2 DBOF DVBP DP2G
RZ2 2 B S2 DBOF DVBP DP2G
RZ4 4 D S4 DBOL DP4G
ds
org ORG.U0009.B0106.KLEM43
db2 DSN.DB2
dbSys
DBTC B DBT DBIA A DIA
DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0
DPYG Y DPY DPZG N DPZ
DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4
runStatsProfile RZX
}¢--- A540769.WK.REXX(INC) cre=2013-04-17 mod=2015-08-20-08.16.50 A540769 ------
/* REXX *************************************************************
include macro:
inc : replace all lines between
<commentStart> copy <mbr> begin .....
and
<commentStart> copy <mbr> end ....
by the contents of member <mbr>
inc e: extract included members to tmp.inc(*) (is emptied before)
currently no nesting allowed
6. 7.15 wk: transfor2 for scan --> scanSB
**********************************************************************/
call errReset 'hi'
call adrEdit 'macro (args)'
if pos('?', args) > 0 then
return help()
m.isExtracting = pos('E', translate(args)) > 0
m.extDsn = userid()'.tmp.inc'
call adrEdit "(myDS) = dataset"
m.dsn = myDs
if m.isExtracting then do
say "macro inc Extracting copies to '"m.extDsn"(*)'"
call adrTso "del '"m.extDsn"(*)'"
end
else do
say 'macro inc including from' m.dsn
end
call adrEdit "(myCuL myCuC) = cursor"
call adrEdit "(myMb) = member"
m.mbr = myMb
call adrEdit "cursor = .zf"
fnd = 'copy'
begMbr = ''
do forever
if 0 then call curSay 'do'
if adrEdit("find '"fnd"'", 0 4) ^= 0 then
leave
if 0 then call curSay 'found'
call adrEdit "(lNr) = linenum .zcsr"
call adrEdit "(li) = line .zcsr"
upper li
if left(word(li, 1), 2) <> '/*' | word(li, 2) <> 'COPY' ,
| wordPos(word(li, 4), 'BEGIN END') < 1 then
nop
else if word(li, 4) = 'BEGIN' then do
begLx = lNr
begMbr = word(li, 3)
end
else if word(li, 3) = begMbr then do
call replace begMbr begLx lNr
begMbr = ''
end
else do
say '***** unpaired end after '''begMbr'''' lNr':' li
end
if 0 then call curSay 'after'
call adrEdit "cursor = .zcsr 80"
end
say 'end macro inc'
call adrEdit "(lx) = linenum .zl"
if lx > 0 & myCuL <= lx then
call adrEdit "cursor =" myCuL myCuC
exit
curSay: procedure expose m.
parse arg msg
call adrEdit "(cL cC) = cursor"
call adrEdit "(ll) = linenum .zl"
say '??? cursor' cL cC', zl' ll msg
call adrEdit "(li) = line" cL
say cL':' strip(li)
return
replace: procedure expose m.
parse upper arg mbr fx tx
if mbr = m.mbr then do
say 'not replacing recursive' mbr
return
end
if m.isExtracting then
return extract(mbr, fx, tx)
call adrEdit "(laX) = linenum .zl"
say 'replacing' mbr "lines" fx tx "last" laX
if laX > tx then
loc = "before .zcsr"
else
loc = "after .zl"
call adrEdit "delete" fx tx
if adrEdit("copy" mbr loc, '*') <> 0 then
call err "***** could not copy" mbr loc
call adrEdit "(laY) = linenum .zl"
/* auf letzte Zeile des eingefügten Copies positionieren */
call adrEdit "cursor =" (tx -laX + laY)
return
endProcedure replace
extract: procedure expose m.
parse arg mbr, fr, to
say 'extracting' fr'-'to 'to' "'"m.extDsn"("mbr")'"
call adrEdit 'create' "'"m.extDsn"("mbr")'" fr to
if mbr == 'SQLRX' then
call mbrTransform fr, to, mbr, 'SQL', 'sqlRx', 'sql'
else if mbr == 'SCAN' then
call mbrTransfor2 fr, to, mbr, 'scanSB', 'scanIsBasic'
return 0
endProcedure extract
mbrTransform: procedure expose m.
parse arg fx, tx, oldMbr, newMbr, cFr, cTo
oy = tx-fx+1
do ox=1 to oy
call adrEdit "(li) = line" (ox+fx-1)
if ox = 1 | ox = oy then
o.ox = space(repAl2(li, translate(li),
, translate(oldMbr), newMbr), 1)
else if ox=2 & abbrev(translate(word(li, 1)), 'ACHTUNG') then
o.ox = li
else
o.ox = repAl2(li, translate(li), translate(cFr), cTo)
end
call writeDsn m.extDsn"("newMbr")", o., oy, 1
return
endProcedure mbrTransform
mbrTransfor2: procedure expose m.
parse arg fx, tx, oldMbr, newMbr, cVar
ox = 0
isCo = 1
do ix=fx to tx
call adrEdit "(li) = line" (ix)
if ix = fx | ix = tx then
li = space(repAl2(li, translate(li),
, translate(oldMbr), newMbr), 1)
else if isCo < 0 | (ix=fx+1 ,
& abbrev(translate(word(li, 1)), 'ACHTUNG')) then
nop
else if \ isCo then
isCo = abbrev(li, 'endProcedure')
else if pos(cVar, li) = 0 then
nop
else if pos(cVar, word(li, 1)) > 0 & word(li,2) == '=' then
li = '/* assignment deleted by inc#mbrTransfor2 */'
else if subWord(li, 1, 3) = 'if m.m.'cVar 'then' then do
li = '/* if deleted by inc#mbrTransfor2 */'
isCo = -2
end
else if subWord(li, 1, 4) = 'else if m.m.'cVar 'then' then do
li = left(li, wordIndex(li, 2) - 2) ,
'/* if deleted by inc#mbrTransfor2 */'
isCo = -2
end
else
call err 'bad cVar line' ix':' li
if isCo <> 0 then do
ox = ox + 1
o.ox = li
if length(li) > 80 then
say ix length(li)':' li
if isCo < 0 then
isCo = isCo + 1
end
end
call writeDsn m.extDsn"("newMbr")", o., ox, 1
return
endProcedure mbrTransform
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd)
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse arg dd, f
if m.err.ispf then
call adrIsp 'vget wshTsoDD shared', 0 8
else if symbol('m.tso.tsoDD') == 'VAR' then
wshTsoDD = m.tso.tsoDD
else
wshTsoDD = ''
if f == '-' then do
px = wordPos(dd, wshTsoDD)
if px < 1 then
call err 'tsoDD dd' dd 'not used' wshTsoDD
wshTsoDD = strip(subword(wshTsoDD, 1, px-1) ,
subWord(wshTsoDD, px+1))
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'wshTsoDD)
if cx < 1 then
dd = dd'1'
else do
old = word(substr(wshTsoDD, cx), 1)
if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, wshTsoDD) > 0 then
call err 'tsoDD dd' dd 'already used' wshTsoDD
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
call adrIsp 'vPut wshTsoDD shared'
m.tso.tsoDD = wshTsoDD
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(10, 1000) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = ''
if m.err.os \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut.ini == 1 then
return
m.ut.ini = 1
m.ut.digits = '0123456789'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
m.ut.alfNum = m.ut.alfa || m.ut.digits
m.ut.alfDot = m.ut.alfNum || '.'
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut.alfLc, m.ut.alfUc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut.digits) > 0 then
return 1
else
return verify(src, m.mId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(J) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 --------
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = '%##fCatFmt' fmt
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%#0')
end
res = f(f2'%#1', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res || f(f2'%#r')
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'" ,
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 <> 0" ,
"| m.qStem.0 < m.m.bufMax / 2 then do;" ,
"call mAddSt m''.BUF'', qStem;" ,
"if m.m.buf.0 > m.m.bufMax then do;'" ,
"classMet(cl, 'jWriteMax')'; end; end;",
"else do; wStem = qStem;' classMet(cl, 'jWrite') ';end'",
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite do wx=1 to m.wStem.0;say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \=='<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* copy j end ********************************************************/
}¢--- A540769.WK.REXX(JAVA) cre=2011-06-29 mod=2011-07-27-16.41.33 A540769 -----
/* rexx ****************************************************************
java compile and run
--- history ------------------------------------------------------------------
29. 6.11 w.keller new
********/ /*** end of help ******* ¢!****** ¢! **** ¢! ****************
public class cEins {
****************************************************** ¢! ** ¢! *******/
/*--- main code java -------------------------------------------------*/
ussDir = 'tst'
ussTransZ = '4a5a4fbb'x /* '¢!|¨' */
ussTransU = 'adbd5a4f'x /* !| */
call errReset 'hI'
say java
call adrEdit 'macro (spec)'
upper spec
if spec = 'Z' then
return transUZ(1)
call adrEdit "(staCur) = cursor"
call adrEdit '(ds) = dataset'
call adrEdit '(mb) = member'
dsn = dsnSetMbr(ds, mb)
call transUZ 0
cla = findClass()
if findSqlJ() then
cmd = 'sqlj'
else
cmd = 'javac'
llq = left(cmd, 4)
src = ussDir'/'cla'.'llq
say 'copying to uss' src
call adrEdit 'save', 4
call adrTso "oPut '"dsn"' '"src"' text"
call transUZ 1
i.0 = 0
jcc = cmd 'compile code'
/*sh = '. /etc/profile;echo path nach /etc/profile $PATH;',
'. .profile0; echo path nach profile0 $PATH;',
*/sh = '. /etc/profile; . .profile0; cd' ussDir';' ,
cmd cla'.'llq'; jc=$?; echo' jcc '$jc;' ,
'if test "$jc" != "0" ; then ; exit $jc ; fi ;'
/* 'java -verbose -version' cla';', USS stuerzt ab |
'echo run java -v -v' cla 'rc $?' */
say sh
rb = bpxwunix(sh, i. , o., e.)
say 'bpxwUnix rc' rb 'o' o.0 o.1
call adrEdit 'reset'
call adrEdit "(zLa) = lineNum .zl"
do y=1 to o.0 until abbrev(o.y, jcc)
end
if y > o.0 then
call err jjOut(jcc 'not found in bpxwUnix output')
cc = word(o.y, words(jcc) + 1)
if cc = 0 then do
say 'compile ok:' cc':'o.y
call adrEdit "cursor =" staCur
/* call jjOut 'run ...', y+1
if spec == 'D' then
call jjOut 'debug listing output'
*/ return
end
trg = 'line_before .zf'
trgLi = '?'
trgFi = '9e99'
src = cla'.java'
do y=1 to e.0
if abbrev(e.y, src':') then do
trg = substr(e.y, length(src)+2)
trg = left(trg, pos(':', trg)-1)
trgFi = min(trgFi, trg)
if trg < zLa then do
call adrEdit '(trgLi) = line' trg
trg = 'line_before' trg+1
end
else do
trg = 'line_after .zl'
trgLi = '?'
end
end
msg = translate(e.y, ussTransZ, ussTransU)
if msg \= trgLi then
if adrEdit(trg '= infoline (msg)', 4) = 4 then
say 'truncated' msg
end
if spec == 'D' then
call jjOut 'debug listing output'
call adrEdit "cursor =" if(trgFi=9e99, .zf, max(trgFi-10,1))
exit
transUZ: procedure expose m. ussTransZ ussTransU
parse arg u2z
if u2z then
do x=length(ussTransZ) by -1 to 1
call adrEdit "change x'"c2x(substr(ussTransU, x, 1))"'" ,
"x'"c2x(substr(ussTransZ, x, 1))"' all", 4
end
else
do x=1 to length(ussTransZ)
call adrEdit "change x'"c2x(substr(ussTransZ, x, 1))"'" ,
"x'"c2x(substr(ussTransU, x, 1))"' all", 4
end
return 0
endProcedure trans
jjOut: procedure expose m. e. o.
parse arg msg, o1x
say msg
say e.0 'errorLines'
do y=1 to e.0
say ' ' e.y
end
say o.0 'outputLines'
do y=nn(o1x, 1) to o.0
say ' ' o.y
end
return msg
endProcedure jjOut
findClass: procedure expose m.
call adrEdit "cursor = .zf"
do while adrEdit("find class word", 4) = 0
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
wx = 1
if word(li, wx) == 'public' then
wx = wx + 1;
if word(li, wx) \== 'class' then do
say 'bad class line' rFi':' li
iterate
end
cn = word(li, wx+1)
nw = word(li, wx+2)
if pos('{', cn) > 0 then
cn = left(cn, pos('{', cn)-1)
else if nw \== '' & \ abbrev(nw, '{') then do
say 'strange class line' rFi':' li '?w' (wx+2) nw
iterate
end
return cn
end
call err 'no class found'
endProcedure findClass
findSqlJ: procedure expose m.
return adrEdit("find #sql word first", 4) = 0
endProcedure findSqlJ
----- old ????????????????
call errReset 'hI'
m.wsh.version = 2.2
parse arg spec
if spec = '?' then
return help('wsh version' m.wsh.version)
os = errOS()
isEdit = 0
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
if sysvar('sysISPF') = 'ACTIVE' then
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
if spec = '?' then
return help('version' m.wsh.version)
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & m.editDsn = 'A540769.WK.REXX(WSH)' then
spec = 't'
end
end
call scanIni
f1 = spec
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(JJ) cre=2014-02-05 mod=2014-02-06-08.01.12 A540769 -------
//A540769Z JOB (CP00,KE50), 00010001
// MSGCLASS=T,TIME=1440,
// NOTIFY=A540769
//*MAIN CLASS=LOG0 SYSTEM=S12
//S01 EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99 00020001
//SYSTSIN DD *
DSN SYSTEM(DP4G)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//*YSIN DD DISP=SHR,DSN=A540769.WK.SQL(GBLIMIT)
//SYSIN DD *
-- Control Summary SQL für RZ4/DP4G job QMW0016P
-- generiert am 14/02/05 18:11:10
-- durch rz1/dsn.source.tecSv(conSumGe)
-- ||| alle Aenderung dortdrin ||||||
--************************************************************
-- Identifikation
--************************************************************
select current timestamp "now", current server "currentServer"
from sysibm.sysDummy1
;
--************************************************************
--$$ fehlende Fullcopies Tablespaces, letzte 8 Tage:
--************************************************************
---- begin @proc missFUllcopies1: fehlende Fullcopies -----------------
SELECT SUBSTR(PT.DBNAME,1,8) AS DBNAME
,SUBSTR(PT.TSNAME,1,8) AS TSNAME
,PT.PARTITION
,DATE(TS.CREATEDTS) AS CREATEDATE
FROM SYSIBM.SYSDATABASE DB,
SYSIBM.SYSTABLESPACE TS,
SYSIBM.SYSTABLEPART PT
WHERE DB.NAME = PT.DBNAME
AND DB.NAME = TS.DBNAME
AND TS.NAME = PT.TSNAME
---- end @proc missFUllcopies1: fehlende Fullcopies -----------------
----- begin @proc exclude: gemeinsame excludes --- * ----------------
AND NOT (PT.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (PT.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (PT.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (PT.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (PT.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (PT.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(PT.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (PT.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (PT.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (PT.DBNAME like 'CSQ%' AND PT.TSNAME like 'TSBLOB%' )
-- M-QUEUE DATENBANK
AND NOT (PT.DBNAME = 'DB2PDB') -- performance DB
AND NOT (PT.DBNAME = 'DB2XML') -- performance DB
AND NOT (PT.DBNAME like 'DSN%')
---- end @proc exclude: gemeinsame excludes --- * ----------------
AND DB.TYPE NOT IN ('T','W')
---- begin @proc missFUllcopies2: fehlende Fullcopies -----------------
AND TS.NTABLES <> 0
AND PT.SPACEF <> -1 -- attention space is sometimes wrong|
AND NOT EXISTS (
---- begin @proc selFUllCopy: select fullcopy etc. --------------------
SELECT ' '
FROM SYSIBM.SYSCOPY CP
WHERE PT.DBNAME = CP.DBNAME
AND PT.TSNAME = CP.TSNAME
AND cp.dsNum in (PT.PARTITION, 0)
AND (( CP.ICTYPE IN ('F','R','X') -- fullcopy or fullLog
AND CP.TIMESTAMP > CURRENT TIMESTAMP - 8 DAYS
) or ((CP.ICTYPE = 'C' -- created today
-- part added today
or (CP.ICTYPE = 'A' and CP.sType = 'A')
) and date(cp.timestamp) >= current date
) )
---- end @proc selFUllCopy: select fullcopy etc. --------------------
)
ORDER BY DBNAME, TSNAME, PT.PARTITION
WITH UR;
---- end @proc missFUllcopies2: fehlende Fullcopies -----------------
commit;
--- temporary table fuer syscopy -------------------------------------
declare global temporary table session.copy
( db char(8), ts char(8), paFr smallInt, paTo smallInt
, dsNum smallInt, icType char(1), tst timestamp
) on commit preserve rows;
create unique index session.txIx on session.copy (db,ts, paFr, paTo)
include (dsNum, icType, tst)
;
insert into session.copy
with l as
(
select c.dbName db, c.tsName ts, c.dsNum, c.icType, c.timestamp tst
, case when s.partitions = 0 then 0
when c.lowDsNum <= 0 then c.dsNum
when c.highDsNum <= 0 then c.dsNum
else c.lowDsNum
end paFr
, case when s.partitions = 0 then 0
when c.lowDsNum <= 0 then c.dsNum
when c.highDsNum <= 0 then c.dsNum
else c.highDsNum
end paTo
from sysibm.sysCopy c
join sysibm.sysTableSpace s
on c.dbName = s.dbName and c.tsName = s.name
where ICTYPE IN ('C', 'F', 'S', 'W', 'Y')
or (ICTYPE = 'A' and sType = 'A') -- part added
)
, g as
(
select db, ts, paFr, paTo
, max(char(tst) || ictype || dsNum) last
from l
group by db, ts, paFr, paTo
)
select db, ts, paFr, paTo
, smallInt(substr(last, 28)) dsNum
, substr(last, 27, 1) icType
, timestamp(substr(last, 1, 26)) tst
from g
;
select count(*) "copy count"
, count(distinct db || '.' || ts) "copy TS's"
, count(distinct db ) "copy DB's"
from session.copy
;
commit;
--************************************************************
--$$ fehlende Fullcopies/Recoverybase, letzte 8 Tage:
--************************************************************
with l as
(
select p.dbName db, p.tsName ts, p.partition pa
, ( select max(char(tst) || icType || char(dsNum))
from session.copy c
where p.dbName = c.db and p.tsName = c.ts
and (p.partition between c.paFr and c.paTo
or c.paFr = 0)
) last
from sysibm.sysTablePart p
join sysibm.sysTablespace s
on p.dbName = s.dbName and p.tsName = s.name
join sysibm.sysDatabase db
on p.dbName = db.name
where s.ntables <> 0
and p.spacef <> -1 -- define=no, space is sometimes wrong
and db.type not in ('T','W')
----- begin @proc exclude: gemeinsame excludes --- * ----------------
AND NOT (P.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (P.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (P.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (P.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (P.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (P.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(P.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (P.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (P.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (P.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (P.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (P.DBNAME like 'CSQ%' AND P.TSNAME like 'TSBLOB%' )
-- M-QUEUE DATENBANK
AND NOT (P.DBNAME = 'DB2PDB') -- performance DB
AND NOT (P.DBNAME = 'DB2XML') -- performance DB
AND NOT (P.DBNAME like 'DSN%')
---- end @proc exclude: gemeinsame excludes --- * ----------------
)
, m as
(
select l.*
, substr(last, 27, 1) ty
, smallint(substr(last, 28)) dsNum
, timestamp(substr(last, 1, 26)) tst
from l
)
select db, ts, pa, ty, dsNum, tst
from m
where ty is null or not
((ty = 'F' and tst > current timestamp - 8 DAYS )
or (ty in ('C', 'A') and tst > current timestamp - 24 hours))
order by 1, 2, 3
with ur
;
commit;
--************************************************************
--$$ fehlende Fullcopies Indexspaces, letzte 8 Tage:
--************************************************************
SELECT SUBSTR(IX.CREATOR,1,8) AS CREATOR
,SUBSTR(IX.NAME,1,8) AS IXNAME
,SUBSTR(IX.DBNAME,1,8) AS DBNAME
,SUBSTR(IX.INDEXSPACE,1,8) AS IXSPACE
,IP.PARTITION
,DATE(IX.CREATEDTS) AS CREATEDATE
FROM SYSIBM.SYSINDEXES IX,
SYSIBM.SYSINDEXPART IP
WHERE IX.CREATOR = IP.IXCREATOR
AND IX.NAME = IP.IXNAME
AND IX.COPY = 'Y'
AND IP.SPACEF <> -1 -- attention space is sometimes wrong|
----- begin @proc exclude: gemeinsame excludes --- * K ----------------
AND NOT (IX.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (IX.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (IX.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (IX.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (IX.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (IX.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(IX.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (IX.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (IX.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (IX.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (IX.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (IX.DBNAME = 'DB2PDB') -- performance DB
AND NOT (IX.DBNAME = 'DB2XML') -- performance DB
AND NOT (IX.DBNAME like 'DSN%')
---- end @proc exclude: gemeinsame excludes --- * K ----------------
AND NOT EXISTS (
---- begin @proc selFUllCopy: select fullcopy etc. --------------------
SELECT ' '
FROM SYSIBM.SYSCOPY CP
WHERE IX.DBNAME = CP.DBNAME
AND IX.INDEXSPACE = CP.TSNAME
AND cp.dsNum in (IP.PARTITION, 0)
AND (( CP.ICTYPE IN ('F','R','X') -- fullcopy or fullLog
AND CP.TIMESTAMP > CURRENT TIMESTAMP - 8 DAYS
) or ((CP.ICTYPE = 'C' -- created today
-- part added today
or (CP.ICTYPE = 'A' and CP.sType = 'A')
) and date(cp.timestamp) >= current date
) )
---- end @proc selFUllCopy: select fullcopy etc. --------------------
)
ORDER BY CREATOR, IXNAME, IP.PARTITION
WITH UR;
commit;
--************************************************************
--$$ Imagecopy Datasets die nicht katalogisiert sind:
--************************************************************
WITH DS AS
(
SELECT DBNAME, TSNAME, DSNUM
,MAX(ICDATE) ICDATE
,MAX(JOBNAME)JOBNAME
,DSNAME
FROM SYSIBM.SYSCOPY C
WHERE ICTYPE IN ('F','I')
AND C.TIMESTAMP >= CURRENT TIMESTAMP - 21 DAYS
----- begin @proc exclude: gemeinsame excludes --- K ----------------
AND NOT (C.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (C.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (C.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (C.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (C.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (C.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(C.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (C.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (C.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (C.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (C.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (C.DBNAME like 'CSQ%' AND C.TSNAME like 'TSBLOB%' )
-- M-QUEUE DATENBANK
AND NOT (C.DBNAME = 'DB2PDB') -- performance DB
AND NOT (C.DBNAME = 'DB2XML') -- performance DB
AND NOT (C.DBNAME like 'DSN%')
---- end @proc exclude: gemeinsame excludes --- K ----------------
GROUP BY DBNAME, TSNAME, DSNUM, DSNAME
)
SELECT SUBSTR(DBNAME,1,8) AS DBNAME
,SUBSTR(TSNAME,1,8) AS TSNAME
,CHAR(DSNUM) AS PART
,ICDATE, JOBNAME, DSNAME
FROM DS
where S100447.DSLOCATE(DSNAME) IS NULL
ORDER BY DBNAME, TSNAME, PART
WITH UR;
commit;
--************************************************************
--$$ LOB-Tablespaces mit falschen Spezifikationen:
--************************************************************
SELECT SUBSTR(DBNAME,1,8) AS DBNAME
,SUBSTR(NAME,1,8) AS TSNAME
,BPOOL
,LOG
FROM SYSIBM.SYSTABLESPACE S
WHERE TYPE = 'O'
AND (BPOOL NOT IN('BP8','BP32K') OR LOG = 'N')
----- begin @proc exclude: gemeinsame excludes --- L ----------------
AND NOT (S.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (S.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (S.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (S.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (S.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (S.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(S.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (S.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (S.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (S.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (S.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (S.DBNAME = 'SYSIBMTA') -- engineering
AND NOT (S.DBNAME = 'SYSIBMTS') -- engineering
AND NOT (S.DBNAME = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT (S.DBNAME = 'DB2OSC') -- osc
AND NOT (S.DBNAME like 'DSN%') -- div databases
AND NOT (S.DBNAME like 'DSQ%') -- qmf databse
AND S.DBNAME NOT IN ('DUTILTST','XSN8D71L','DB2XML')
---- end @proc exclude: gemeinsame excludes --- L ----------------
AND DBNAME NOT LIKE 'DB2PLAN%'
AND DBNAME NOT LIKE 'PTDB%'
ORDER BY DBNAME, TSNAME
WITH UR;
commit;
--************************************************************
--$$ Tablespaces mit fehlerhafter Spezifikation:
--************************************************************
SELECT DISTINCT SUBSTR(TS.DBNAME,1,8) AS DBNAME
,SUBSTR(TS.NAME,1,8) AS TSNAME
,TS.BPOOL
,SUBSTR(PT.STORNAME,1,8) AS STORNAME
,PT.STORTYPE
FROM SYSIBM.SYSDATABASE DB,
SYSIBM.SYSTABLESPACE TS,
SYSIBM.SYSTABLEPART PT
WHERE DB.NAME = TS.DBNAME
AND DB.NAME = PT.DBNAME
AND TS.NAME = PT.TSNAME
----- begin @proc exclude: gemeinsame excludes --- F ----------------
AND NOT (PT.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (PT.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (PT.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (PT.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (PT.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (PT.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(PT.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (PT.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (PT.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (PT.DBNAME = 'SYSIBMTA') -- engineering
AND NOT (PT.DBNAME = 'SYSIBMTS') -- engineering
AND NOT (PT.DBNAME = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT (PT.DBNAME = 'DB2OSC') -- osc
AND NOT (PT.DBNAME like 'DSN%') -- div databases
AND NOT (PT.DBNAME like 'DSQ%') -- qmf databse
AND PT.DBNAME NOT IN ('DUTILTST','XSN8D71L','DB2XML')
AND NOT (PT.DBNAME = 'DB2PMPDB'
AND PT.TSNAME like 'ACCS%') -- PMON KITD2
AND NOT (PT.DBNAME = 'DB2PDB') -- performance DB
AND NOT (PT.DBNAME = 'DB2XML') -- performance DB
AND NOT (PT.DBNAME like 'DSN%')
---- end @proc exclude: gemeinsame excludes --- F ----------------
AND DB.TYPE <> 'W'
AND (TS.BPOOL = 'BP0'
OR PT.STORNAME <> 'GSMS'
OR PT.STORTYPE = 'E')
ORDER BY DBNAME, TSNAME
WITH UR;
commit;
--************************************************************
--$$ Indexspaces mit fehlerhafter Spezifikation:
--************************************************************
SELECT DISTINCT SUBSTR(IX.CREATOR,1,8) AS CREATOR
,SUBSTR(IX.NAME,1,8) AS IXNAME
,IX.BPOOL
,SUBSTR(IP.STORNAME,1,8) AS STORNAME
,IP.STORTYPE
FROM SYSIBM.SYSINDEXES IX,
SYSIBM.SYSINDEXPART IP
WHERE IX.CREATOR = IP.IXCREATOR
AND IX.NAME = IP.IXNAME
----- begin @proc exclude: gemeinsame excludes --- F ----------------
AND NOT (IX.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (IX.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (IX.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (IX.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (IX.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (IX.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(IX.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (IX.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (IX.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (IX.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (IX.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (IX.DBNAME = 'SYSIBMTA') -- engineering
AND NOT (IX.DBNAME = 'SYSIBMTS') -- engineering
AND NOT (IX.DBNAME = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT (IX.DBNAME = 'DB2OSC') -- osc
AND NOT (IX.DBNAME like 'DSN%') -- div databases
AND NOT (IX.DBNAME like 'DSQ%') -- qmf databse
AND IX.DBNAME NOT IN ('DUTILTST','XSN8D71L','DB2XML')
AND NOT IX.DBNAME = 'DB2PMPDB' -- PMON KITD2
AND NOT (IX.DBNAME = 'DB2PDB') -- performance DB
AND NOT (IX.DBNAME = 'DB2XML') -- performance DB
AND NOT (IX.DBNAME like 'DSN%')
---- end @proc exclude: gemeinsame excludes --- F ----------------
AND (IX.BPOOL = 'BP0'
OR IP.STORNAME <> 'GSMS'
OR IP.STORTYPE = 'E')
ORDER BY CREATOR, IXNAME
WITH UR;
commit;
--************************************************************
--$$ tableParts mit pri/secQty <> -1 oder vielen extents
--************************************************************
SELECT SUBSTR(PT.DBNAME,1,8) "db"
,SUBSTR(PT.TSNAME,1,8) "ts"
,PT.PARTITION "part"
,pt.pQty "priQty"
,pt.sQty "secQty"
,r.extents
FROM
SYSIBM.SYSTableSpace ts
join SYSIBM.SYSTABLEPART pt
on pt.dbName = ts.dbName and pt.tsname = ts.name
left join sysibm.sysTableSpaceStats r
on pt.dbNAME = r.DBNAME
AND pt.tsName = r.NAME
AND ts.dbid = r.dbid
AND ts.psid = r.psid
AND pt.partition = r.partition
WHERE (pt.pQty <> -1 or pt.sQty <> -1 or r.extents > 300)
----- begin @proc exclude: gemeinsame excludes --- L ----------------
AND NOT (PT.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (PT.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (PT.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (PT.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (PT.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (PT.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(PT.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (PT.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (PT.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (PT.DBNAME = 'SYSIBMTA') -- engineering
AND NOT (PT.DBNAME = 'SYSIBMTS') -- engineering
AND NOT (PT.DBNAME = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT (PT.DBNAME = 'DB2OSC') -- osc
AND NOT (PT.DBNAME like 'DSN%') -- div databases
AND NOT (PT.DBNAME like 'DSQ%') -- qmf databse
AND PT.DBNAME NOT IN ('DUTILTST','XSN8D71L','DB2XML')
---- end @proc exclude: gemeinsame excludes --- L ----------------
ORDER BY pt.DBNAME, pt.tsNAME, PT.PARTITION
fetch first 999 rows only
WITH UR;
commit;
--************************************************************
--$$ IndexParts mit pri/secQty <> -1 oder vielen extents
--************************************************************
SELECT SUBSTR(Ip.ixCREATOR,1,8) AS CREATOR
,SUBSTR(Ip.ixNAME,1,16) AS IXNAME
,IP.PARTITION
,ip.pQty "priQty"
,ip.sQty "secQty"
,ip.extents
FROM
SYSIBM.SYSINDEXES Ix
join SYSIBM.SYSINDEXPART IP
on ix.creator = ip.ixCreator and ix.name = ip.ixName
left join SYSIBM.SYSINDEXSpaceStats r
on ix.creator = r.creator and ix.name = r.creator
and ix.dbid = r.dbid and ix.isobid = r.isobid
and ip.partition = r.partition
WHERE (ip.pQty <> -1 or ip.sQty <> -1 or r.extents > 300)
----- begin @proc exclude: gemeinsame excludes --- L ----------------
AND NOT (IX.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (IX.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (IX.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (IX.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (IX.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (IX.DBNAME LIKE 'DB2PLAN%') -- explain tables
and not translate(IX.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (IX.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (IX.DBNAME LIKE 'DB2POOL%') -- DB2 STOR.POOL WIESI
AND NOT (IX.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (IX.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (IX.DBNAME = 'SYSIBMTA') -- engineering
AND NOT (IX.DBNAME = 'SYSIBMTS') -- engineering
AND NOT (IX.DBNAME = 'DB2PM') -- PERF.EXPERT DATABASE
AND NOT (IX.DBNAME = 'DB2OSC') -- osc
AND NOT (IX.DBNAME like 'DSN%') -- div databases
AND NOT (IX.DBNAME like 'DSQ%') -- qmf databse
AND IX.DBNAME NOT IN ('DUTILTST','XSN8D71L','DB2XML')
---- end @proc exclude: gemeinsame excludes --- L ----------------
order by ix.creator, ix.name, ip.partition
fetch first 999 rows only
WITH UR;
}¢--- A540769.WK.REXX(LA) cre=2010-09-13 mod=2010-09-22-22.06.30 A540769 -------
/* rexx ***************************************************************
regression tool for reoTime Formula
fun = 'r': read in matrix and linear regression
fun = 'e': read in matrix and evualte different formulas
read in matrix: first line contains column names,
use a clustering algo to find filed widths
remove rows with negative values in it
put it to matrix rA
linear regressions:
iteratly remove columnn with smallest contribution
i.e. first big negative coefficients
evaluate: apply each formula defined in loadCols to each row
for each formula build a 2 dimensional table
range of calculatedTime/measuredTime
* for different minima of calculatedTime
these tables are concatented and written to the output file
la linear algebra
a matrix m, m.dim.0 = #dimension m.dim.1 = first dimension etc.
m.i.j (matrix element i, j9
linear regression: gesucht x mit
y=Ax bzw. t(y-Ax) * (a-Ax) minimal (t=transpose)
x = inverse(t(A) * A) * t(A) * y
tA = t(A) = transpose of A
ideas:
do a regression for predefined columns
remove the debug say
to regression in three steps:
regr2Square: (A, y) ==> (tA * A, tA * y)
or better, do that directly in input processing
remove unwanted rows/colums
solve y = tA*A * y or return matrixes for linear dep etc.
(simple linear equation| )
nice formatting
***********************************************************************/
call errReset 'h'
if 0 then exit eval()
if 0 then exit tstLa()
numeric digits 30
withConst = 1
fun = 'e'
ty = 'i' /* t=TS, i=index */
m.inDsn = 'A540769.WK.TEXW(CHECKRTi)'
m.outDsn = 'A540769.WK.TEXW(CHECKRTO)'
nms = 'Y XFI XLA'
if ty == 't' then
lbs = reotime tsParts I0SPCLOGMAX
else if ty == 'i' then
lbs = reotime Parts SPCLOGMAX
call readDsn m.inDsn, 'M.I.'
say m.i.0 'rows read from' m.inDsn
call findCols c, i
do cx = 1 to m.c.0 /*find col Indexes for y, xFi, xLa */
w1 = m.c.cx
wx = wordPos(w1, lbs)
if wx > 0 then do
n1 = word(nms, wx)
if symbol('m.cn.n1') == 'VAR' then
call err w1 c1 'duplicate' cx m.cn.n1
else
m.cn.n1 = cx
end
end
do nx=1 to words(nms) /*say limiting names */
n1 = word(nms, nx)
v1 = m.cn.n1
if symbol('m.cn.n1') == 'VAR' then
say n1 v1 m.c.v1 m.c.v1.fx'-'m.c.v1.tx
else
call err word(lbs, nx) 'not found for' n1
end
cY = m.cn.y
cFi = m.cn.xFi
cLa = m.cn.xLa
m.rY.dim.0 = 1
m.rA.dim.0 = 2
m.rA.dim.2 = cLa+1-cFi+withConst
m.rn.0 = cLa+1-cFi+withConst
do rx=1 to m.rn.0 /* ini the column info table */
cx = rx+cFi-1
m.rn.map.rx = rx
m.rn.rx.name = m.c.cx
call laInfo0 rn'.'rx
end
rLa = m.rn.0
if withConst then
m.rn.rLa.name = 'CONST'
cntNeg = 0
hx = 1
do ix=2 to m.i.0 /* load the good rows into rY and rA */
m.ry.hx = max(0, colVal(c, cy, m.i.ix))
hasNeg = m.ry.hx < 0
do cx=cFi to cLa+withConst
yy = cx + 1 - cFi
if cx > cLa then
m.rA.hx.yy = 1 /* constant */
else
m.rA.hx.yy = colVal(c, cx, m.i.ix)
if m.rA.hx.yy < 0 then
hasNeg = 1
else
call laInfo1 rn'.'yy, m.rA.hx.yy
end
if hasNeg then
cntNeg = cntNeg + 1
else
hx = hx+1
end
say (hx-1) 'good rows,' cntNeg 'rows with negatives removed'
m.rY.dim.1 = hx-1
m.rA.dim.1 = hx-1
do rx=1 to - m.rn.0
say 'rn.'rx m.rn.rx.name '0='m.rn.rx.cZero 'pos='m.rn.rx.cPos,
m.rn.rx.min '-' m.rn.rx.max
end
/* now, do the work */
if fun == 'e' then do
call eval ty, rn, ra, ry
end
else do
do while m.Ra.dim.2 > 0 /* regression loop */
dp = laRegression(rX, rA, rY)
pos = ''
mi = '?'
if dp \= rX then do
amb = -99
m.dp.amb.1 = 0
amx = 1
do dx=2 to m.dp.dim.1
if abs(m.dp.dx.1) > abs(m.dp.amx.1) then do
amb = amx
amx = dx
end
else if abs(m.dp.dx.1) > abs(m.dp.amb.1) then do
amb = dx
end
end
amy = m.rn.map.amx
amc = m.rn.map.amb
say 'linear dependent|||' m.rn.amy.name m.dp.amx.1 ,
'>' m.rn.amc.name m.dp.amb.1
end
else do
call laSayWithRN rn, 'found x',rX
mi = 999e999
mix = 0
do x=1 to m.rx.dim.1
y = m.rn.map.x
if m.rx.x * m.rn.y.max < mi then do
mix = x
mi = m.rx.x * m.rn.y.max
end
end
if mi >= 0 then
pos = 'nonNegative|||'
amx = mix
end
amy = m.rn.map.amx
say 'removing' m.rn.amy.name 'x.'amx'='mi pos
say ' max =' m.rn.amy.max '*x=' mi
call mCp rn'.'map, amx+1, m.rn.0, rn'.'map, -1
m.rn.0 = m.rn.0-1
call laRmR rA, amx
end
end
exit
tstLa: procedure expose m.
parse value '2 2 3' with m.a1.dim.0 m.a1.dim.1 m.a1.dim.2
parse value '1 2 3' with m.a1.1.1 m.a1.1.2 m.a1.1.3
parse value '4 5 6' with m.a1.2.1 m.a1.2.2 m.a1.2.3
if 0 then call laSay a1, 5
parse value '2 3 2' with m.a2.dim.0 m.a2.dim.1 m.a2.dim.2
parse value '4 5' with m.a2.1.1 m.a2.1.2
parse value '6 7' with m.a2.2.1 m.a2.2.2
parse value '8 9' with m.a2.3.1 m.a2.3.2
if 0 then call laSay a2, 5
call laMbyM a3, a1, a2
if 0 then call laSay a3, 5, 'a1 * a2'
call laMbyM a4, a2, a1
if 0 then call laSay a4, 5, 'a2 * a1'
call laSwapRow a4, 2, 3
if 0 then call laSay a4, 5, 'swap 2 3'
call laAdd2Row a4, 2, 3, -1
if 0 then call laSay a4, 5, 'add2row 2 3 -1'
call laUnit a5, 7
if 0 then call laSay a5, 5, 'unit 7'
if 1 then call laSay a3, 15, 'a3'
call laInvert a6, a3
if 1 then call laSay a6, 15, 'a6 = invert a3'
if 1 then call laSay laMbyM(a7, a6, a3), 15, 'a6*a3'
if 1 then call laSay laMbyM(a7, a3, a6), 15, 'a3*a6'
m.a4.3.3 = 0
if 0 then call laSay a4, 15, 'changed a4'
call laInvert a6, a4
if 0 then call laSay a6, 15, 'invert a4'
if 0 then call laSay laMbyM(a7, a6, a4), 15, 'a6*a4'
if 0 then call laSay laMbyM(a7, a4, a6), 15, 'a4*a6'
parse value '2 4 4' with m.b1.dim.0 m.b1.dim.1 m.b1.dim.2
parse value '1 2 3 4' with m.b1.1.1 m.b1.1.2 m.b1.1.3 m.b1.1.4
parse value '7 7 7 5' with m.b1.2.1 m.b1.2.2 m.b1.2.3 m.b1.2.4
parse value '0 0 1 3' with m.b1.3.1 m.b1.3.2 m.b1.3.3 m.b1.3.4
parse value '7 8 9 9' with m.b1.4.1 m.b1.4.2 m.b1.4.3 m.b1.4.4
if 1 then call laSay b1, 15, 'b1'
call laInvert bInv, b1
if 1 then call laSay bInv, 15, 'bInv inverse of b1'
if 1 then call laSay laMbyM(bT, bInv, b1), 15, 'bInv * b1'
if 1 then call laSay laMbyM(bT, b1, bInv), 15, 'b1 * bInv'
parse value '1 3 1 3 5' with m.v1.dim.0 m.v1.dim.1 m.v1.1 m.v1.2 m.v1.3
parse value '2 3 2' with m.r1.dim.0 m.r1.dim.1 m.r1.dim.2
parse value '0 1' with m.r1.1.1 m.r1.1.2
parse value '1 1' with m.r1.2.1 m.r1.2.2
parse value '2 1' with m.r1.3.1 m.r1.3.2
parse value '1 3 1 3 5' with m.v1.dim.0 m.v1.dim.1 m.v1.1 m.v1.2 m.v1.3
if 1 then call laSay r1, 15, 'r1'
if 1 then call laSay v1, 15, 'v1'
call laRegression v2, r1, v1
if 1 then call laSay v2, 15, 'regression r1 v1'
return
endProcedure laTest
eval: procedure expose m.
parse arg ty, rn, rA, rY
parse value '0.7 0.8 0.9 1 1.1 1.2 1.5' ,
with m.evS.97 m.evS.98 m.evS.99 ,
m.evS.100 m.evS.101 m.evS.102 m.evS.103
p = 1
f = 2
do i=104 to 199
m.evS.i = f * p
j = 200-i
m.evS.j = 1 / m.evS.i
f = translate(f, '251', '125')
if f = 1 then
p = p * 10
end
if ty == 'i' then
call loadColsIx d
else
call loadCols d
m.ev.0 = m.d.0
do dx=1 to m.d.0
ev = 'EV.'dx
parse value '5 0 1 60 600 3600' with m.ev.0 m.ev.1 m.ev.2,
m.ev.3 m.ev.4 m.ev.5
call evalZero ev
do cx=1 to m.d.dx.0
do rx=1 to m.rn.0
if m.rn.rx.name = m.d.dx.cx.name then
leave
end
if rx > m.rn.0 then
call err 'col' m.d.dx.cx.name 'notfound'
m.d.dx.cx.col = rx
end
m.d.dx.min = 999e999
m.d.dx.max = -999e999
m.d.dx.devSq = 0
m.d.dx.vSq = 0
m.d.dx.wSq = 0
end
do dx=1 to m.d.0
do cx=1 to m.d.dx.0
say 'd.'dx'.'cx m.d.dx.cx.name m.d.dx.cx.col ,
m.d.dx.cx.fact
end
end
do y=1 to m.Ra.dim.1
w = m.rY.y
do dx=1 to m.d.0
v = 0
do cx=1 to m.d.dx.0
ax = m.d.dx.cx.col
v = v + m.d.dx.cx.fact * m.rA.y.ax
end
call eval1 'EV.'dx, v, w
m.d.dx.min = min(m.d.dx.min, v)
m.d.dx.max = max(m.d.dx.max, v)
m.d.dx.devSq = m.d.dx.devSq + (v-w) * (v-w)
m.d.dx.vSq = m.d.dx.vSq + v * v
m.d.dx.wSq = m.d.dx.wSq + w * w
end
end
do dx=1 to m.d.0
ev = 'EV.'dx
m.ev.hdr.1 = m.d.dx
m.ev.hdr.2 = ' rng' format(m.d.dx.min , 2, 4, 2, 0),
'-' format(m.d.dx.max , 2, 4, 2, 0)
m.ev.hdr.3 = 'devSq' format(m.d.dx.devSq, 2, 4, 2, 0)
m.ev.hdr.4 = ' vSq' format(m.d.dx.vSq, 2, 4, 2, 0)
m.ev.hdr.5 = ' wSq' format(m.d.dx.wSq, 2, 4, 2, 0)
m.ev.hdr.0 = 5
end
call evalSay 1, 'EV'
call writeDsn m.outDsn, 'M.OO.', , 1
return
call evalZero ev
call eval1 ev, 0.1, 0.102
call eval1 ev, 1, 1.22
call eval1 ev, 12, 11
call eval1 ev, 66, 6600
call evalSay 0, ev
call evalSay 0, ev, ev
call loadCols d
return
endProcedure eval
loadCols: procedure expose m.
parse arg ed
a = ed'.1'
m.a = 'foAlt'
call loadC1 1 TSPARTS 2.22E+01
call loadC1 2 TSSPCLOGROWS 2.23E-08
call loadC1 3 TSROWSLOG 1.14E-07
call loadC1 4 IXENTLOG 2.66E-07
call loadC1 5 I0PARTS 4.94E+00
call loadC1 6 I0SPC 3.84E-08
call loadC1 7 I0ENTMAX 3.42E-06
a = ed'.2'
m.a = 'auf12k'
call loadC1 1 TSPARTS 2.7147881
call loadC1 2 TSROWS 1.4161175E-05
call loadC1 3 TSSPC 3.2655649E-08
call loadC1 4 TSUDS 5.5643292E-09
call loadC1 5 IXPARTS 8.3169080
call loadC1 6 IXSPC 9.1683081E-09
call loadC1 7 I0PARTS 1.9235028
call loadC1 8 I0SPCMAX 1.1758590E-07
call loadC1 9 I0SPCLOGMAX 4.6308572E-09
a = ed'.3'
m.a = 'aug1k'
call loadC1 1 TSROWSMAX 3.8142598E-06
call loadC1 2 TSSPCLOGROWS 1.0871730E-08
call loadC1 3 IXPARTS 1.0375221
call loadC1 4 IXENT 2.5437853E-06
call loadC1 5 I0PARTS 8.5882393E-01
call loadC1 6 I0SPCLOGMAX 2.2203412E-08
a = ed'.4'
m.a = 'sep6k8v'
call loadC1 1 TSROWS 6.6722887E-06
call loadC1 2 TSSPCLOGROWS 8.5027973E-09
call loadC1 3 TSUDSMAX 6.0607492E-09
call loadC1 4 IXENT 4.4905833E-07
call loadC1 5 I0PARTS 3.2896648
call loadC1 6 I0SPCMAX 2.6521501E-07
call loadC1 7 I0SPCLOGMAX 4.9577450E-10
call loadC1 8 CONST 9.5972874
a = ed'.5'
m.a = 'sep6k3v'
call loadC1 1 TSROWS 5.7890464E-06
call loadC1 2 TSSPCLOGROWS 1.1851404E-08
call loadC1 3 I0SPCMAX 2.7697702E-07
a = ed'.6'
m.a = 'sep6k2v'
call loadC1 1 TSSPCLOGROWS 1.7634377E-08
call loadC1 2 I0SPCMAX 2.8943198E-07
a = ed'.7'
m.a = 'sep16kFirstNNv10'
call loadC1 1 TSPARTS 2.2918106
call loadC1 2 TSROWS 1.1719944E-05
call loadC1 3 TSSPC 4.1178398E-08
call loadC1 4 TSUDS 4.7357392E-09
call loadC1 5 IXPARTS 5.9228624
call loadC1 6 IXSPC 1.1593550E-08
call loadC1 7 I0PARTS 2.8568338
call loadC1 8 I0SPCMAX 1.4917387E-07
call loadC1 9 I0SPCLOGMAX 3.4002310E-09
call loadC1 10 CONST 2.7397410
a = ed'.8'
m.a = 'sep16kv6'
call loadC1 1 TSROWS 1.2138081E-05
call loadC1 2 TSSPC 4.2093887E-08
call loadC1 3 TSUDS 5.0810006E-09
call loadC1 4 IXPARTS 9.5068747
call loadC1 5 I0SPCMAX 1.4627868E-07
call loadC1 6 I0SPCLOGMAX 3.4251123E-09
a = ed'.9'
m.a = 'sep16kv4'
call loadC1 1 TSROWS 1.3982363E-05
call loadC1 2 TSUDS 1.3126219E-08
call loadC1 3 I0SPCMAX 1.5430204E-07
call loadC1 4 I0SPCLOGMAX 3.4788130E-09
a = ed'.10'
m.a = 'sep16kv3'
call loadC1 1 TSROWS 1.6060241E-05
call loadC1 2 I0SPCMAX 1.4972364E-07
call loadC1 3 I0SPCLOGMAX 4.0276130E-09
a = ed'.11'
m.a = 'sep16kv2'
call loadC1 1 TSROWS 1.3603414E-05
call loadC1 2 I0SPCMAX 2.4771465E-07
m.ed.0 = 11
return
endProcedure loadCols
loadColsIx: procedure expose m.
parse arg ed
a = ed'.1'
m.a = 'ixAlt'
call loadC1 1 SPC 3.71E-08
call loadC1 2 ENT 3.42E-06
call loadC1 3 CONST 4.94E+00
/* max(coalesce(4.94E+00 + 3.8E-05 * space
+ 3.42E-06 * totalEntries, 5), 5) reo */
a = ed'.2'
m.a = 'ixAllv6'
call loadC1 1 ENTMAX 1.1831612E-05
call loadC1 '2 ENTLOGMAX -1.2913690E-06'
call loadC1 '3 SPCLOGENT -1.0056636E-07'
call loadC1 '4 SPCMAX -7.2703918E-09'
call loadC1 '5 SPCLOGMAX 9.4707207E-08'
call loadC1 '6 CONST -7.7846842'
a = ed'.3'
m.a = 'ixFirstNNv2'
call loadC1 1 SPCMAX 1.3558420E-07
call loadC1 2 CONST 1.8626988
m.ed.0 = 3
return
endProcedure loadColsIX
loadC1: procedure expose m. a
parse arg x m.a.x.name m.a.x.fact .
m.a.0 = x
return
eval1: procedure expose m.
parse arg ev, v, w
if v = 0 then
f = 999e999
else
f = w/v
if f >= 1 then do i=101 to 198 while f > m.evS.i
end
else do i=99 by -1 to 2 while f < m.evS.i
end
i = i - (f >= 1)
h = i-1
j = i+1
/* say 'v' v 'f' f 'i' i m.evS.h'-'m.evS.i'-'m.evS.j */
do ex=1 to m.ev.0 while m.ev.ex <= v
m.ev.ex.i = m.ev.ex.i + 1
end
return
endProcedure
evalZero: procedure expose m.
parse arg ev
do ex=1 to m.ev.0
do y=0 to 201
m.ev.ex.y = 0
end
end
return ev
endProcedure evalZero
evalSay: procedure expose m.
parse arg isSt, a2
aa = 'LA.SAY'
if isSt then do
do ax=1 to m.a2.0
m.aa.ax = a2'.'ax
end
m.aa.0 = m.a2.0
end
else do
do ax=1 to arg()-1
m.aa.ax = arg(ax-1)
end
m.aa.0 = arg()-1
end
call outPush oo
m.oo.0 = 0
sx=0
h = ''
do ax = 1 to m.aa.0
ev = m.aa.ax
if ax = 1 then
t = right('fact|ti', 9)
else
t = t || ' | '
do hx=1 to m.ev.hdr.0
if symbol('h.hx') \== 'VAR' then do
h.hx = ''
h.0 = m.ev.hdr.0
end
h.hx = left(h.hx, length(t))m.ev.hdr.hx
end
do y=1 to m.ev.0
t = t right(m.ev.y, 5)
tot.ev.y = 0
end
end
do hx=1 to h.0
call out h.hx
end
call out t
do i = 1 to 200
h = i-1
do ax = 1 to m.aa.0
ev = m.aa.ax
if m.ev.1.i \= 0 | m.ev.1.h \= 0 then
leave
end
if ax > m.aa.0 then
iterate
do ax = 1 to m.aa.0
if ax = 1 then
t = '>='right(m.evS.i, 7)
else
t = t || ' | '
ev = m.aa.ax
do y=1 to m.ev.0
t = t right(m.ev.y.i, 5)
tot.ev.y = tot.ev.y+ m.ev.y.i
end
end
call out t
end
do ax = 1 to m.aa.0
if ax = 1 then
t = left('total' , 9)
else
t = t || ' | '
ev = m.aa.ax
do y=1 to m.ev.0
t = t right(tot.ev.y, 5)
end
end
call out t
call outPush
do ox=1 to m.oo.0
say m.oo.ox
end
return
endProcedure evalSay
/*--- get the value of a column --------------------------------------*/
colVal: procedure expose m.
parse arg c, y, li
x = y - 1
z = y + 1
if y > 1 then
if substr(li, m.c.x.tx, m.c.y.fx-m.c.x.tx) \= '' then
call err 'before col' y m.c.y 'not empty:' li
if y < m.c.0 then
if substr(li, m.c.y.tx, m.c.z.fx-m.c.y.tx) \= '' then
call err 'after col' y m.c.y 'not empty:' li
if y = m.c.0 then
if substr(li, m.c.y.tx) \= '' then
call err 'after col' y m.c.y 'not empty:' li
v = substr(li, m.c.y.fx, m.c.y.tx-m.c.y.fx)
if datatype(v, 'n') then
return strip(v)
if words(v) = 2 & word(v, 1) = 0 & word(v, 2) = 'E+00' then
return 0
call err 'bad value' v 'in col' y m.c.y 'in line:' li
endProcedure colVal
/*--- find the columns width: incremently cluster --------------------*/
findCols: procedure expose m.
parse arg c, i
spc = ' '
m.c.0 = 0
ex = 1
do forever
bx = verify(m.i.1, spc, 'n', ex)
if bx < 1 then
leave
ex = verify(m.i.1, spc, 'm', bx)
if ex <= bx then
ex = length(m.i.1)+1
m.c.0 = m.c.0 + 1
r = c'.'m.c.0
m.r = substr(m.i.1, bx, ex-bx)
m.r.fx = bx
m.r.tx = ex
m.r.expLe = 0
m.r.expRi = 0
end
redo = ''
do ix=2 to m.i.0
r1 = findColsExp1(c, m.i.ix, spc)
again = pos('e', r1) > 0 & redo \== ''
if pos('o', r1) > 0 then
redo = redo ix
do while again
say 'redoing' redo
again = 0
rx = 1
do forever
ri = word(redo, rx)
if ri == '' then
leave
r2 = findColsExp1(c, m.i.ri, spc)
if pos('e', r2) > 0 then
again = 1
if pos('o', r2) > 0 then
rx = rx + 1
else
redo = subword(redo, 1, rx-1) subword(redo, rx+1)
end
end
end
say 'redo is' redo
do cx=1 to m.c.0
say cx m.c.cx.expLe m.c.cx.expRi m.c.cx.fx'-'m.c.cx.tx m.c.cx
end
return
endProcedure findCols
findColsExp1: procedure expose m.
parse arg c, li, spc
hasOut = ''
hasExp = ''
rx = 1
ex=1
do forever
bx = verify(li, spc, 'n', ex)
if bx < 1 then
leave
ex = verify(li, spc, 'm', bx)
if ex <= bx then
ex = length(li)+1
do rx=rx to m.c.0-1 while bx > m.c.rx.tx
end
rtx = rx m.c.rx.fx'-'m.c.rx.tx m.c.rx
if ex <= m.c.rx.fx | bx > m.c.rx.tx then do
/* say bx'-'ex 'outside ' rtx */
hasOut = 'o'
end
else do
if bx < m.c.rx.fx then do
ry = rx-1
if rx > 1 & bx < m.c.ry.tx then
say bx'-'ex 'leftConflict ' rtx
else do
say bx'-'ex 'extLeft ' rtx
m.c.rx.fx = bx
m.c.rx.expLe = 1
hasExp = 'e'
end
end
if ex > m.c.rx.tx then do
ry = rx+1
if rx < m.c.0 & tx > m.c.ry.fx then
say bx'-'ex 'rightConflict ' rtx
else do
say bx'-'ex 'extRight' rtx
m.c.rx.tx = ex
m.c.rx.expRi = 1
hasExp = 'e'
end
end
end
end
return hasOut || hasExp
endProcedure findColsExp1
laRegression: procedure expose m.
parse arg x, A, y
say 'regression' m.A.dim.0 m.A.dim.1 m.A.dim.2
say 'regression' m.A.1.1 m.A.2.2 m.A.3.3
call laSayInfos A, 'A'
call laSayInfos Y, 'Y'
tA = laTranspose(la'.'regr1, A)
tAA = laMbyM(la'.'regr2, tA, A)
call laSayInfos tAA, 'tA * A'
inv = laInvert(la'.'regr3, tAA, 1)
if m.inv.zero \== 0 then do
say 'linear dependency' m.inv.zero
call laSayInfos inv'.ZERO'
call laSayWithRN rn, 'depend r',inv'.ZERO'
tzz = laMbyM(la'.'regrZZ, tAA, inv'.ZERO')
call laSayInfos tzz, 'tAA * zero'
return inv'.ZERO'
end
call laSayInfos inv, 'inverse'
call laSayInfos laMbyM(la'.regTst', tAA, inv), 'tAA * inv'
/*call laSay y, 7, 'y' */
tAy = laMbyC(la'.'vect4, tA, y)
/* call laSay tAy, 7, 'tA * y' */
call laMbyC x, inv , tAy
call laSayInfos x, 'x = regression'
yy = laRbyC(y, y)
xtAAx = laRbyC(x, laMbyC(la'.retTs2', tAA, x))
xtAy = laRbyC(x, tAy)
say '***(y-Ax)**2='format(yy+xtAAx-2*xtAy, 2, 7, 2, 0),
'yy='format(yy , 2, 7, 2, 0)
return x
endProcedure laRegression
laTranspose: procedure expose m.
parse arg t, m
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laTranspose('t',' m')'
m.t.dim.0 = 2
m.t.dim.1 = m.m.dim.2
m.t.dim.2 = m.m.dim.1
do x=1 to m.m.dim.1
do y=1 to m.m.dim.2
m.t.y.x = m.m.x.y
end
end
return t
endProcedure laTranspose
laInvert: procedure expose m.
parse arg i, oo, absZero
/* idea: calculate L and R with LAR = 1
L exchanges rows or adds the f * row to another row
R exchanges cols or adds the f * col to another col
with the factor f having abs(f) <= 1
the diagonal elements are muliplied to 1 only at the end
a linear dependency is reported, if all remaining eles
have abs(e) absZero
******************************************/
m = laCopy(la'.'invert, oo)
if m.m.dim.0 <> 2 | m.m.dim.1 <> m.m.dim.2 then
call err 'not square' m.m.dim.0 m.m.dim.1 m.m.dim.2,
'in laInvert('i',' m')'
d = m.m.dim.1
l = laUnit(i'.lef', d)
r = laUnit(i'.rig', d)
do dx = 1 to d
am = 0
do y=dx to d
do x=dx to d
if abs(m.M.y.x) > am then do
am = abs(m.M.y.x)
amy = y
amx = x
end
end
end
if am <= absZero then do
m.i.zero = d + 1 - dx
m.i.zero.dim.0 = 2
m.i.zero.dim.1 = d
m.i.zero.dim.2 = d + 1 - dx
do y=dx to d
call laCopyCol i'.ZERO', y+1-dx, R, y, d
end
return i
end
else if am = 0 then do
trace ?r
say err 'rest of matrix 0'
say m m.m.dim.1 m.m.dim.2 d
say m.m.d.d
call err 'rest of matrix 0'
end
if abs(m.m.amy.amx) <> am then
call err 'mismatch'
am = m.m.amy.amx
call laSwapRow m, amy, dx
call laSwapRow l, amy, dx
call laSwapCol m, amx, dx
call laSwapCol r, amx, dx
if m.m.dx.dx <> am then
call err 'mismatch'
/* clean col below and row right of dx,dx */
do y=dx+1 to d
call laAdd2Row L, y, dx, -m.m.y.dx/am /* downwards */
call laAdd2Row M, y, dx, -m.m.y.dx/am
call laAdd2Col R, y, dx, -m.m.dx.y/am /* to the right */
call laAdd2Col M, y, dx, -m.m.dx.y/am
end
/* call laSay M, 15, 'M after clean row below' dx','dx */
end
do y = 1 to d /* make diag to 1 */
call laMultRow L, y, 1/m.M.y.y
end
m.i.zero = 0
return laMbyM(i, R, L)
endProcedure laInvert
laInvertV1: procedure expose m.
/* idea: calculate I with IA = 1 */
parse arg i, oo
m = laCopy(la'.'invert, oo)
if m.m.dim.0 <> 2 | m.m.dim.1 <> m.m.dim.2 then
call err 'not square' m.m.dim.0 m.m.dim.1 m.m.dim.2,
'in laInvert('i',' m')'
d = m.m.dim.1
call laUnit i, d
do x = 1 to d
/* call laSayInfos i, 'laRegr i before' x */
k = x
do y=x+1 to d
if abs(m.m.k.x) < abs(m.m.y.x) then
k = y
end
if k <> x then do
call laSwapRow m, k, x
call laSwapRow i, k, x
end
call laAdd2Row i, x, x, (1-m.m.x.x)/m.m.x.x
call laAdd2Row m, x, x, (1-m.m.x.x)/m.m.x.x
do y=1 to d
if x=y | m.m.y.x = 0 then
iterate
/* say y x m.m.y.x */
call laAdd2Row i, y, x, -m.m.y.x
call laAdd2Row m, y, x, -m.m.y.x
end
/* call laSay m, 15, 'm after' x 'of' d
call laSay laMbyM('x', i, oo), 15, 'i*oo after' x 'of' d */
end
return i
endProcedure laInvert
/*--- copy a matrix --------------------------------------------------*/
laCopy: procedure expose m.
parse arg c, m
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laCopy('c',' m')'
m.c.dim.0 = 2
m.c.dim.1 = m.m.dim.1
m.c.dim.2 = m.m.dim.2
do x=1 to m.m.dim.1
do y=1 to m.m.dim.2
m.c.x.y = m.m.x.y
end
end
return c
endProcedure laCopy
laCopyCol: procedure expose m.
parse arg c, cSuf, f, fSuf, d
do y=1 to d
m.c.y.cSuf = m.f.y.fSuf
end
return c
endProcedure laCopyCol
/*--- set m to a unit matrix of dimension d --------------------------*/
laUnit: procedure expose m.
parse arg m, d
m.m.dim.0 = 2
m.m.dim.1 = d
m.m.dim.2 = d
call laSetAll m, 0
do x=1 to d
m.m.x.x = 1
end
return m
endProcedure laUnit
laSetAll: procedure expose m.
parse arg m, v
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do x=1 to m.m.dim.1
do y=1 to m.m.dim.2
m.m.x.y = v
end
end
return m
endProcedure laSwapRow
laAdd2Row: procedure expose m.
parse arg m, i, k, f
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do x=1 to m.m.dim.2
m.m.i.x = m.m.i.x + m.m.k.x * f
end
return m
endProcedure laAdd2Row
laMultRow: procedure expose m.
parse arg m, i, f
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do x=1 to m.m.dim.2
m.m.i.x = m.m.i.x * f
end
return m
endProcedure laMultRow
laAdd2Col: procedure expose m.
parse arg m, i, k, f
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do y=1 to m.m.dim.1
m.m.y.i = m.m.y.i + m.m.y.k * f
end
return m
endProcedure laAdd2Col
laSwapRow: procedure expose m.
parse arg m, i, k
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
if i=k then
return m
do x=1 to m.m.dim.2
o = m.m.i.x
m.m.i.x = m.m.k.x
m.m.k.x = o
end
return m
endProcedure laSwapRow
laSwapCol: procedure expose m.
parse arg m, i, k
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapCol('m',' i',' k')'
if i=k then
return m
do y=1 to m.m.dim.1
o = m.m.y.i
m.m.y.i = m.m.y.k
m.m.y.k = o
end
return m
endProcedure laSwapCol
/*--- multiply the matrices L and R and put the result into P --------*/
laMbyM: procedure expose m.
parse arg p, l, r
if m.l.dim.0 <> 2 | m.r.dim.0 <> 2 then
call err 'bad dim.0' m.l.dim.0 m.r.dim.0 ,
'in laMbyM('p',' l',' r')'
if m.l.dim.2 <> m.r.dim.1 then
call err 'l.dim.2' m.l.dim.2 '<> r.dim.1' m.r.dim.1 ,
'in laMbyM('p',' l',' r')'
m.p.dim.0 = 2
m.p.dim.1 = m.l.dim.1
m.p.dim.2 = m.r.dim.2
do x=1 to m.p.dim.1
do y=1 to m.p.dim.2
q = 0
do z=1 to m.r.dim.1
q = q + m.l.x.z * m.r.z.y
end
m.p.x.y = q
end
end
return p
endProcedure laMbyM
/*--- multiply the matrix M by Column vector C into p ----------------*/
laMbyC: procedure expose m.
parse arg p, L, r
if m.L.dim.0 <> 2 | m.r.dim.0 <> 1 then
call err 'bad dim.0' m.L.dim.0 m.r.dim.0 ,
'in laMbyC('p',' L',' r')'
if m.L.dim.2 <> m.r.dim.1 then
call err 'L.dim.2' m.L.dim.2 '<> r.dim.1' m.r.dim.1 ,
'in laMbyC('p',' L',' r')'
m.p.dim.0 = 1
m.p.dim.1 = m.L.dim.1
do y=1 to m.p.dim.1
q = 0
do z=1 to m.r.dim.1
q = q + m.L.y.z * m.r.z
end
m.p.y = q
end
return p
endProcedure laMbyC
/*--- return scalar product of vectors r and c ----------------------*/
laRbyC: procedure expose m.
parse arg r, c
if m.r.dim.0 <> 1 | m.c.dim.0 <> 1 then
call err 'bad dim.0' m.L.dim.0 m.r.dim.0 ,
'in laRbyC(' r',' c')'
if m.r.dim.1 <> m.c.dim.1 then
call err 'L.dim.2' m.L.dim.2 '<> r.dim.1' m.r.dim.1 ,
'in laMbyC('p',' L',' r')'
p = 0
do x=1 to m.r.dim.1
p = p + m.r.x * m.c.x
end
return p
endProcedure laRbyC
/*--- remove row k from Matrx m -------------------------------------*/
laRmR: procedure expose m.
parse arg m, k
if m.m.dim.0 = 2 then do
do y=1 to m.m.dim.1
call mCp m'.'y, k+1, m.m.dim.2, m'.'y, -1
end
m.m.dim.2 = m.m.dim.2 - 1
end
else do
call err 'bad dim' m.m.dim.0
end
return
endProcedure laRmR
/*--- remove row k and column k from matrix M -----------------------*/
laRmRC: procedure expose m.
parse arg m, k
if m.m.dim.0 = 1 then do
call mCp m, k+1, m.m.dim.1, m, -1
m.m.dim.1 = m.m.dim.1 - 1
end
else if m.m.dim.0 = 2 then do
do y=1 to k-1
call mCp m'.'y, k+1, m.m.dim.2, m'.'y, -1
end
do y=k+1 to m.m.dim.1
z=y-1
call mCp m'.'y, 1, k-1, m'.'z, 0
call mCp m'.'y, k+1, m.m.dim.2, m'.'z, -1
end
m.m.dim.1 = m.m.dim.1 - 1
m.m.dim.2 = m.m.dim.2 - 1
end
else do
call err 'bad dim' m.m.dim.0
end
return
endProcedure laRmRC
mCp: procedure expose m.
parse arg src, xF, xT, dst, dlt
do x=xF to xT
y=x+dlt
m.dst.y = m.src.x
end
return
endProcedure mCp
/*--- say matrix m, with width w and message msg --------------------*/
laSay: procedure expose m.
parse arg m, w, msg
if m.m.dim.0 = 1 then do
say m':' m.m.dim.1':' msg
r = ''
do y= 1 to m.m.dim.1
r = r || right(m.m.y, w)
end
say r
end
else if m.m.dim.0 = 2 then do
say m':' m.m.dim.1 'x' m.m.dim.2':' msg
do x=1 to m.m.dim.1
r = ''
do y= 1 to m.m.dim.2
r = r || right(m.m.x.y, w)
end
say r
end
end
else
call err 'dim' m.m.dim.0 '<> 2 in laSay('m',' w',' msg')'
return
endProcedure laSay
laSayInfos: procedure expose m.
parse arg m, msg
say 'infos' m 'dim.0' m.m.dim.0':' m.m.dim.1'x'm.m.dim.2':' msg
call laInfo m
say ' counts 0='m.m.info.cZero', pos='m.m.info.cPos ,
|| ', neg='m.m.info.cNeg
say ' sum='m.m.info.sum', sumSquare='m.m.info.sq
say ' absolut min='m.m.info.absMin', max='m.m.info.absMax
return m
endProcedure laSysInfos
laSayWithRN: procedure expose m.
parse arg rn, txt
a1 = 3
say 'laSayWithCols' txt
rws = m.rn.0
do ax=a1 to arg()
a = arg(ax)
call laSayInfos a, 'arg' (ax+1-a1)
if \ (m.a.dim.0 == 1 | m.a.dim.0 == 2) then
call err 'dim not 1 or 2:' m.a.dim.0
if m.a.dim.1 <> rws then
call err 'rows not' rws':' m.a.dim.1
end
do rx=1 to rws
y = m.rn.map.rx
txt = right(rx, 3) left(m.rn.y.name, 15)
do ax=a1 to arg()
a = arg(ax)
if m.a.dim.0 = 1 then do
txt = txt format(m.a.rx, 2, 7, 2, 0)
end
else do cx=1 to m.a.dim.2
txt = txt format(m.a.rx.cx, 2, 7, 2, 0)
end
end
say txt
end
return
endProcedure laSayWithRN
laInfo: procedure expose m.
parse arg m
o = m'.INFO'
call laInfo0 o
if m.m.dim.0 = 1 then do
do y=1 to m.m.dim.1
call laInfo1 o, m.m.y
end
end
else if m.m.dim.0 = 2 then do
do y=1 to m.m.dim.1
do x=1 to m.m.dim.2
call laInfo1 o, m.m.y.x
end
end
end
else
call err 'laSayInfos bad dim' m.m.dim.0
return m
endProdcedure laInfo
laInfo0: procedure expose m.
parse arg o
m.o.cZero = 0
m.o.cPos = 0
m.o.cNeg = 0
m.o.sum = 0
m.o.sq = 0
m.o.min = 999e999
m.o.max = -999e999
m.o.absMin = 999e999
m.o.absMax = -999e999
return o
endProcedure laInfo0
laInfo1: procedure expose m.
parse arg o, v
m.o.min = min(m.o.min, v)
m.o.max = max(m.o.max, v)
if v = 0 then do
m.o.cZero = m.o.cZero + 1
return
end
if v > 0 then
m.o.cPos = m.o.cPos + 1
else
m.o.cNeg = m.o.cNeg + 1
m.o.sum = m.o.sum + v
m.o.sq = m.o.sq + v * v
m.o.absMin = min(m.o.absMin, abs(v))
m.o.absMax = max(m.o.absMax, abs(v))
return
endProdcedure laInfo1
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
oldTrap = outtrap()
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
if oldTrap = '' then
call outtrap off
else
call outtrap oldTrap append
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(LISTDSI) cre=2010-12-15 mod=2012-09-26-09.48.10 A540769 ---
/* rexx
**********************************************************************/
say '9999 -> ' dsnArc(A540769.zzz.save9999)
say '9991 -> ' dsnArc(A540769.zzz.save9991)
say '9591 -> ' dsnArc(A540769.zzz.save9591)
say '9591 -> ' dsnArc(A5407.zzz.save9591)
say 'yzzz -> ' dsnArc(A5407yzzz.save9591)
exit
dsnArc: procedure expose m.
parse arg dsn
lc = listDsi("'"dsn"' noRecall")
if lc = 0 then
return ''
else if lc=16 & sysReason = 9 then
return 'arc'
else if lc=16 & sysReason = 5 then
return 'notCat'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
call findHalfTrackSize 6
exit
findHalfTrackSize:
parse arg lim
lMin = 0
len = 32760
do forEver
address tso 'alloc dd(f1) recfm(f b) lRecl('len')',
'blksize('len')'
say 'len' len 'alloc' rc
rc = listdsi(f1 file)
say varExp('sysReason sysMsgLvl1 sysMsgLvl2')
say varExp('sysLRecL sysBlkSize sysKeyLen')
say varExp('sysUnit sysTrksCyl sysBlksTrk sysUnits sysUsed')
say 'listDsi rc' rc 'for' w sysdsname
address tso 'free dd(f1)'
if sysBlksTrk < lim then
lMax = len
else
lMin = len
len = trunc((lMax + lMin) / 2)
say '***** min' lMin 'max' lMax 'len' len
if len = lMin then
leave
end
say lim 'blocks' lMin 'track' (lim * lMin)
return lMin
endProcedure findHalfTrackSize
/* if rc ^= 0 then */
say varExp('sysReason sysMsgLvl1 sysMsgLvl2')
say varExp('sysLRecL sysBlkSize sysKeyLen')
say varExp('sysUnit sysTrksCyl sysBlksTrk sysUnits sysUsed')
exit
w = sysexec file
w = "'A540769.WK.TEXV'"
rc = listdsi(w)
say 'listDsi rc' rc 'for' w sysdsname
/* if rc ^= 0 then */
say varExp('sysReason sysMsgLvl1 sysMsgLvl2')
say varExp('sysLRecL sysBlkSize sysKeyLen')
say varExp('sysUnit sysTrksCyl sysBlksTrk sysUnits sysUsed')
exit
parse arg dsns
if dsns = '' then
dsns = "'DBOF.MF01A1P.A150A.P0003.D08014.T090323' wk.rexx"
do wx = 1 to words(dsns)
w = word(dsns, wx)
rc = listdsi(w)
say 'listDsi rc' rc 'for' w
if rc ^= 0 then do
say varExp('sysReason sysMsgLvl1 sysMsgLvl2')
end
say varExp('sysLRecL sysBlkSize sysKeyLen')
say varExp('sysUnit sysTrksCyl sysBlksTrk sysUnits sysUsed')
if sysUnits = 'CYLINDER' then
cy = sysUsed
else if sysUnits = 'TRACK' then
cy = sysUsed / sysTrksCyl
else if sysUnits = 'BLOCK' then
cy = sysUsed / sysTrksCyl / sysBlksTrk
else cy = sysUnits '????'
say 'cylinders' cy
end
exit
varExp:
parse arg ggVarExpVars
ggVarExp = ''
do ggVarExpIx = 1 to words(ggVarExpVars)
ggVarExp1 = word(ggVarExpVars, ggVarExpIx)
ggVarExp = ggVarExp ggVarExp1':' value(ggVarExp1)
end
return ggVarExp
endSubroutine varExp
}¢--- A540769.WK.REXX(LOGG) cre=2009-07-22 mod=2009-09-11-08.46.17 A540769 -----
/* rexx
nur start - end time und retries ausgeben
*/
call errReset 'h'
if arg() = 0 then
call logg A540769.tmp.logg, 'zeile eins', 'zeile zwei'
else
call logg A540769.tmp.logg, arg(1)
exit
/*--- append a message to a seq DS if available
otherwise isssue a message ----------------------------*/
logg: procedure expose m.
parse arg dsn
o.1 = ''
do x=1 to arg()-1
o.x = ' ' strip(arg(x+1), t)
end
x = max(1, arg() - 1)
call dsnAllocWait "dd(logg) mod '"dsn"'",,,55
o.1 = date(s) time() strip(o.1) '*'rt
address tso 'execio' x 'diskw logg (stem o. finis)'
if rc <> 0 then
say 'execio logg rc' rc dsn
call sleep 0 , 1
address tso 'free dd(logg)'
say 'after free rc=' rc date(s) time() dsn
if rc <> 0 then
say 'logg free rc' rc
return
endProcedure logg
loggOld: procedure expose m.
parse arg dsn
o.1 = ''
do x=1 to arg()-1
o.x = ' ' strip(arg(x+1), t)
end
x = max(1, arg() - 1)
do rt=0
say 'before' rt 'alloc' date(s) time() dsn
x.1 = ''
x.2 = ''
x.3 = ''
call outtrap x., '*'
address tso "alloc dd(logg) mod dsn('"dsn"') MGMTCLAS(COM#A092)"
alRc = rc
call outtrap off
say 'after alloc rc=' rc date(s) time() dsn
if rc = 0 then
leave
if rt > 100 then
return err('timeout allocating logg' dsn 'rc' alRc time(),
'\n'x.1'\n'x.2'\n'x.3)
if pos('DATA SET IS ALLOCATED TO ANOTHER', x.1 x.2 x.3) < 1 then
return err('rc' alRc 'allocating' dsn'\n'x.1'\n'x.2'\n'x.3)
call sleep 1
end
o.1 = date(s) time() strip(o.1) '*'rt
address tso 'execio' x 'diskw logg (stem o. finis)'
if rc <> 0 then
say 'execio logg rc' rc dsn
call sleep 0 , 1
address tso 'free dd(logg)'
say 'after free rc=' rc date(s) time() dsn
if rc <> 0 then
say 'logg free rc' rc
return
endProcedure logg
/* rexx */
parse arg s
if s = '' then
call sleep 5
else
call sleep s
exit
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep begin ***************************************************/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep end *****************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt call return
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errCallHandler m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errCallHandler:
parse arg code
interpret code
m.err.return = 0
return
endProcedure errCallHandler
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(M) cre=2016-08-09 mod=2016-08-09-10.24.49 A540769 --------
/* copy m begin *******************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
}¢--- A540769.WK.REXX(MAIL) cre=2016-07-11 mod=2016-07-11-11.46.31 A540769 -----
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a ----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
}¢--- A540769.WK.REXX(MAILOLD) cre=2015-06-11 mod=2015-06-11-16.20.22 A540769 ---
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'SUBJECT ' subj
m.m.2 = 'RECPLIST ' rec
m.m.3 = 'SENDERID ' if(snd=='', userid(), snd)
m.m.4 = 'SENDERIDCC N'
m.m.5 = 'DOCTEXT'
m.m.0 = 5
return m
endProcedure mailHead
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m, 'DOCTEXTEND'
if dsn == '' then
call dsnAlloc 'dd(iemapi) new ::v255'
else
call dsnAlloc 'dd(iemapi) shr' dsn
call writeDD iemapi, 'M.'m'.'
call tsoClose iemapi
call dsnAlloc 'dd(iemlog) sysout(*)'
call adrTso "call *(os3550)", '*'
if rc \== 0 then
say 'error os3550 rc='rc 'mail not sent|||||'
call tsoFree iemlog iemapi
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
}¢--- A540769.WK.REXX(MAILTXT) cre=2014-01-14 mod=2014-01-22-17.32.16 A540769 ---
*---+----1----+----2----+----3----+----4 ===> Kommentar Re
SUBJECT 1 test-von mailTxt rexx
RECPLIST OAS
SENDERID A540769
SENDERIDCC N
DOCTEXT
SSW:
*
to smtp = walter.keller@credit-suisse.com
*
*
SSW:
nach leerZeile .............xt Mail-Text Mail-Text Mail-Text
Das Mail kann an 1 bis n Empfänger gesendet werden, für jeden Empfän
muss ein "to smtp = INTERNET ADRESSE " Record eingefügt werden.
Es dürfen KEINE Zeilenmummern hinter der Adresse vorhanden sein.
und eine LeerZeile
und 2 LeerZeilen
und ein Link
<https://web-pd-sec.csintra.net/MVSDS/%27A540769.WK.REXX%27>
und fertig
DOCTEXTEND
}¢--- A540769.WK.REXX(MAILTX2) cre=2014-01-22 mod=2014-01-22-17.43.31 A540769 ---
SUBJECT 1 test-von mailTx2 rexx
RECPLIST A540769
GGDB2
SENDERID GGDB2
SENDERIDCC N
DOCTEXT
*---+----1----+----2----+----3----+----4 ===> Kommentar Re
nach leerZeile .............xt Mail-Text Mail-Text Mail-Text
Das Mail kann an 1 bis n Empfänger gesendet werden, für jeden Empfän
muss ein "to smtp = INTERNET ADRESSE " Record eingefügt werden.
Es dürfen KEINE Zeilenmummern hinter der Adresse vorhanden sein.
und eine LeerZeile
und 2 LeerZeilen
und ein Link
<https://web-pd-sec.csintra.net/MVSDS/%27A540769.WK.REXX%27>
und ein langer link
<https://web-pd-sec.csintra.net/
DSN.ABUB.TECSV.RZ2.DBOF.E.CONTSUM(B2215565)>
und fertig
DOCTEXTEND
}¢--- A540769.WK.REXX(MAP) cre=2016-08-09 mod=2016-08-09-10.24.49 A540769 ------
/* copy map begin *****************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end ******************************************************/
}¢--- A540769.WK.REXX(MAPEXP) cre=2016-07-11 mod=2016-07-11-11.46.32 A540769 ---
/* copy mapExp begin *************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ***************************************************/
}¢--- A540769.WK.REXX(MARC) cre=2009-05-28 mod=2009-05-28-15.28.24 F540769 -----
/* rexx ****************************************************************
call marec in the library it is installed
switch back altlib afterwards
pass forward any arguments, return the return value
***********************************************************************/
parse arg a1, a2, a3
say 'wk.rexx(marec) with' a1',' a2',' a3
call errReset 'hI'
say 'macro rc' rc 'arg' arg
address tso "altlib disp"
say 'altlib'
call adrtso "altlib activate application(exec)" ,
"dataset('DSN.MAREC.EXEC') uncond"
address tso "altlib disp"
signal on syntax name onSyntax
res = marec(a1, a2, a3)
say 'marec returned' res 'altlib deact(exec)'
if 0 then
onSyntax:
do
say '*** syntax on call marec, is it not present?'
res = 12
end
call adrtso "altlib deact application(exec)"
address tso "altlib disp"
say 'exit' res
exit res
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi ^== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na ^== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return ' ' alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(MAREC) cre=2011-04-11 mod=2013-06-13-10.04.19 A540769 ----
/* rexx ****************************************************************
maRec massRecovery Driver
call from tso:
tso maRec new dsnLib
tso maRec lib(phaMbr) opt?
call as editmacro, editing lib(phaMbr)
maRec opt?
autopilot: marec meist ohne Parameter,
lesen, jobs submitten
zurueck in controlMember mit PF3 und mit marec weiter
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Mrc
Referenz http://chw20025641/host/db2wiki/pmwiki.php?n=Main.MrcRef
* history **************************************************************
* marecCfg durch alib ersetzt
27. 4.11 version 2.0
*****/ /****************************************************************
1.12.09 smsSG heisst richtig db2Nmr
Ideen, todo
* exit mit message set ohne says
* marec in tso library einbauen und beim ersten Aufruf switch + deal
phaseNew/Ini auftrennen in general Teil und application phase
***********************************************************************/
parse arg opt
if 0 then
opt = 'l DSN.MAREC.D110411.T160818.P45 001 YMRCO001 start'
call errReset 'hI'
call wshIni
call phaseIni
call envPutO 'ctl', mNew('Ctl')
if 0 then do
call envPut 'ctl.dbSub', 'DBAF'
call phaseObjImpl , jBuf('tb a540769 twk600a012 3- 34,77',
, ' *' , '7 - 9', 'ts DA540769.A600A007 6,3',
, 'tb iwk__789_ 1,9', ' tb twk600A018 '),
, 'ts is'
exit
end
m.isEditing = 0
m.ctlMbr = ''
if opt == '' & sysVar('sysISPF') = 'ACTIVE' then do
/* if we are an editMacro, get macro args */
if adrEdit('macro (opt)', '*') == 0 then do
call adrEdit '(mbr) = member'
call adrEdit '(pds) = dataset'
m.ctlMbr = pds'('mbr')'
m.isEditing = 1
do sx=1
call adrEdit '(cha) = data_changed'
if sx > 3 then
call errEx 'cannot save member'
if cha = 'NO' then
leave
say '...saving member' m.ctlMbr
call adrEdit 'save', '*'
end
end
end
/* first word could be ctlMbr */
w1 = word(opt, 1)
if pos('(', w1) > 0 then do
m.ctlMbr = dsn2jcl(w1)
m.isEditing = 0
opt = subword(opt, 2)
end
m.ctlMbr = dsn2jcl(m.ctlMbr)
/* the real parameters in mixed and uppercase */
parse var opt o1 o2
parse upper var opt u1 u2
/* handle special cases */
if abbrev(u1, '?') then
return help('installation rexx ' cfgRexx(),
,' skels' cfgSkels())
else if abbrev(u1, 'T') then
return tst(substr(o1, 2) o2)
else if u1 = 'N' then
return phaseNewWorker(o2)
else if u1 = 'L' then
return maRecLogJob(o2)
/* read cltMbr and run ctlMbr */
cMbr = dsnGetMbr(m.ctlMbr)
if \ (cMbr >= 'A' & cMbr < 'P') then
call err 'memberName' cMbr 'of controlMember not >= A and < P'
call readDsn m.ctlMbr, 'M.CI.'
ctlInB = jBufWriteStem(jBuf(), ci)
call envPushName 'ctl', 'as1'
call compRun ':', ctlInB
call envPopWith
/* call objOut envGetO('ctl') */
/* read history */
call histRead
/* and do the work */
if u1 == '' | abbrev(u1, '-') then
call marecAutoPilote opt
else
call marecFunction opt
exit 0
endOf Main
/**** marec: userInterface ********************************************/
/*--- execute a single function or phase -----------------------------*/
marecFunction: procedure expose m.
parse arg o1 o2
parse upper arg u1 u2
if u1 == 'C' then
return marecContinue(o2)
else if u1 == 'E' | u1 == 'V' then
return phaseEdit( ,o1, o2)
else if u1 = 'I' then
return phaseInfo(o2)
else if u1 = 'LINK' then
return phaseLink(o2)
else if o1 == '' then
call err 'empty fun'
laPh = m.zHist.phase
dsc = phaseDescGet(o1)
do fx=1 to m.dsc.io.0
f = m.dsc.io.fx
if m.f.io \== 'i' then
iterate
if phaseIoFind(laPh, m.f.type, 'o', 'r') \== '' then
iterate
if \ (m.f.type = 'obj' | m.f.type = 'vcatSpec') then
return erI('no ouput' m.f.type 'generated in history')
return ctlMbrExpand(m.f.type, , 1)
end
call marecPrepare dsc
cont = marecWorkWri(dsc, o2)
return phasePostWork( , cont)
endProcedure marecFunction
marecPrepare: procedure expose m.
parse arg dsc
fun = m.dsc.name
if fun == 'pra' | fun == 'ala' then
return marecWork(phaseDescGet('obj'), 'tb ix')
else if fun == 'maRec' | fun == 'pitRe' then
return marecWork(phaseDescGet('obj'), 'ts is')
return
endProcedure marecPrepare
/*--- make phase, phase doWork, write history+ctlMbr -----------------*/
marecWorkWri: procedure expose m.
parse arg dsc, opt
cont = marecWork(dsc, opt)
call histWrite
call ctlMbrUpdate
return cont
endProcedure marecWorkWri
/*--- make phase, phase doWork, with history -------------------------*/
marecWork: procedure expose m.
parse arg dsc, opt
ph = phaseDescMake(dsc, histNext(), m.zHist.phase, opt)
cont = phaseDoWork(ph)
call histAdd ph
return cont
endProcedure marecWork
/*--- continue: continue work for phase ------------------------------*/
marecContinue: procedure expose m.
parse arg phaId args
u1 = translate(phaId)
if length(u1) == 3 & u1 >= 'P' & u1 < 'Z' ,
& verify(substr(u1, 2), '0123456789') == 0 then do
ph = phaseById(phaId)
end
else do
ph = m.zHist.phase
args = phaId args
end
cont = phaseCont(ph, args)
return phasePostWork(ph, cont)
endProcedure marecContinue
/*--- autoPilote: continue last phase
guess and execute next function -------------------*/
marecAutoPilote: procedure expose m.
parse arg args
aft = marecContinue(args)
if aft == 'q' then
exit
else if aft \== '' then
call err 'bad after' aft
goal = envGet('ctl.goal')
if goal = '' then
exit erI('bitte goal setzen oder marec mit Funktion aufrufen')
fun = funGoalSearch(goal)
cont = marecFunction(fun)
ret = phasePostWork(m.zHist.phase, cont)
if ret == 'c' then
call marecAutoPilote
else if ret \== '' then
call err 'bad ret' ret
return
endProcedure marecAutoPilote
/*--- get marec configuration infos ----------------------------------*/
cfgRexx: procedure expose m.
if m.cfg.ini \== 1 then do
parse value alib('returnRexxlibSkels') ,
with m.cfg.rexxLib m.cfg.skels
m.cfg.ini = 1
end
return m.cfg.rexxLib
endProcedure cfgRexx
cfgSkels: procedure expose m.
if m.cfg.ini \== 1 then
call cfgRexx
return m.cfg.skels
endProcedure cfgRexx
/*--- inform user of input error/need --------------------------------*/
erI: procedure expose m.
parse arg msg
exit errEx('\n'left('--- input Fehler ', 79, '-') ,
||'\n'msg'\n'left('',79,'-'))
/*--- inform user of error/input need in ctlMbr ----------------------*/
erC: procedure expose m.
parse arg msg
exit errEx('\n'left('--- Fehler im ctlMbr ', 79, '-') ,
||'\n'msg'\n'left('',79,'-'))
/*** ctl: handle ctlMbr ***********************************************/
ctlMbrUpdate: procedure expose m.
upd = ''
if \ m.isEditing then do
call writeDsn m.ctlMbr, 'M.CI.', , 1
return
end
call adrEdit 'del all .zf .zl', 4 8 /* 8 for empty file */
do ix=1 to m.ci.0
li = m.ci.ix
call adrEdit 'line_after' (ix-1) '= (li)'
end
call adrEdit 'save'
return
endProcedure ctlMbrUpdate
ctlMbrWrite: procedure expose m.
parse arg isNew, stems
ox = 0
do wx = 1 to words(stems)
st = word(stems, wx)
do sx = 1 to m.st.0
ox = ox + 1
o.ox = m.st.sx
end
end
ox = ox+1
o.ox = '$#end history'
ox = ox+1
o.ox = 'pha fun ctlMbr lnk opt'
cm = dsnGetMbr(m.ctlMbr)
do ax=1 to m.zHist.addIx
if m.zHist.ax.ctlMbr \== cm then
iterate
ox = ox + 1
o.ox = m.zHistR.ax
end
if \ m.isEditing then do
call writeDsn m.ctlMbr copies('::f',isNew), o., ox, 1
end
else do
call adrEdit 'del all .zf .zl', 4 8 /* 8 for empty file */
do ix=1 to ox
li = o.ix
call adrEdit 'line_after' (ix-1) '= (li)'
end
call adrEdit 'save', 4 /* 4 = new member saved */
end
return
endProcedure ctlMbrWrite
ctlMbrExpand: procedure expose m.
parse arg what, msg, doWrite
st = runInline2St(what)
call ctlMbrAddLines st, envGet('ctlMbrExpandStop'), doWrite
if msg == '' then
exit erI(envGet('ctlMbrExpandMsg'))
else
exit erI(msg)
endProcedure ctlMbrExpand
/*
$=/obj/
$=ctlMbrExpandStop = /obj/
$=ctlMbrExpandMsg = please specify db2 objects in /obj/
* the object list with wildcards (% and _), type tb or ts
<=/obj/
tb OA1P name% 3-7,88
$'$/obj/'
$/obj/
$=/vcatSpec/
$=ctlMbrExpandStop = /vcats/ smsSG
$=ctlMbrExpandMsg = please specify the vcat and smsSG
* mass recovery analyze parameters
* the list of vCats (High Level Qualifiers of DB datasets)
* normally the same as the db2 subsys
* for ELAR there may be several entries:
* enter each entry on a separate line
* directly under the header vcat
<|/vcats/ vcat
${ctl.dbSub}
/vcats/
* the storage group in the diskSubsystem - for CIM
smsSG = DB2NMR
$/vcatSpec/
$=/maRec/
$=ctlMbrExpandStop = /sys/ est.ts.
$=ctlMbrExpandMsg = please specify sys and est....
$=sn =- sysVar('sysNode')
$=sp =- translate(substr($sn, 2, 1), 'S', 'Z')substr($sn,3,1)
est.ts.const = 0
est.ts.part = .41
est.ts.byte = 1.1e-7
est.ix.const = 5
est.ix.part = 1
est.ix.byte = 2e-7
* the list of system and number of jobs on this system
* optionally the 3. word gives the db2Member
<|/sys/
sys jobs member
${sp}1 10
${sp}2 10
${sp}3 10
${sp}4 10
/sys/
$/maRec/
*/
ctlMbrAddLines: procedure expose m.
parse arg st, chWrds, doWri
do ix=1 to m.ci.0 while \ abbrev( m.ci.ix, '$#end')
do wx=1 to words(chWrds)
if pos(word(chWrds, wx), m.ci.ix) < 1 then
iterate
say word(chWrds, wx) 'already in ctlMbr' ix':' m.ci.ix
return
end
end
if ix > m.ci.0 then do
call erI '$#end not found in ctlMbr'
return
end
call mInsert ci, ix, st
if doWri == 1 then
call ctlMbrUpdate
return
endProcedure ctlMbrAddLines
/**** hist: handle history ********************************************/
tst: procedure expose m.
parse upper arg f1 f2
if f1 = 'HIST' then
call tstHistNext
else
call err 'bad test fun' f1 f2
return 0
endProcedure tst
tstHistNext: procedure expose m.
m.zHist.addIx = 0
call tstHistNext1 'abc'
call tstHistNext1 'P00'
call tstHistNext1 'P01'
call tstHistNext1 'P08'
call tstHistNext1 'P09'
call tstHistNext1 'P10'
call tstHistNext1 'P79'
call tstHistNext1 'P80'
call tstHistNext1 'P98'
call tstHistNext1 'P99'
call tstHistNext1 'Q00'
call tstHistNext1 'Q01'
call tstHistNext1 'Q48'
call tstHistNext1 'Q49'
call tstHistNext1 'Q98'
call tstHistNext1 'Q99'
call tstHistNext1 'R00'
call tstHistNext1 'X99'
call tstHistNext1 'Y00'
call tstHistNext1 'Y50'
call tstHistNext1 'Y98'
call tstHistNext1 'Y99'
return
endProcedure tstHistNext
tstHistNext1: procedure expose m.
parse arg fr
lx = m.zHist.addIx
m.zHist.lx.phaId = fr
m.zHist.nextPha = ''
say 'phase' lx fr '==>' histNext()
m.zHist.addIx = lx+1
return
endProcedure tstHistNext1
histRead: procedure expose m.
dsn = dsnSetMbr(m.ctlMbr, "zHist")
cm = translate(dsnGetMbr(m.ctlMbr))
if sysDsn("'"dsn"'") \== "OK" then do
m.zHist.0 = 0
m.zHist.phase = ''
end
else do
call readDsn dsn, 'M.ZHISTR.'
do rx = 1 to m.zhistr.0
call histLine rx, m.zHistR.rx
m.zHist.rx.desc = phaseDescGet(m.zHist.rx.fun)
dp = m.zHist.rx.lnkO
if dp \== '' then
dp = m.dp.phase
m.zHist.rx.phase = phaseDescMake(m.zHist.rx.desc,
, m.zHist.rx.phaId, dp, m.zHist.rx.opt)
if cm = m.zHist.rx.ctlMbr then
m.zHist.phase = m.zHist.rx.phase
end
hx = m.zHistr.0
m.zHist.0 = hx
end
m.zHist.nextPha = ''
m.zHist.addIx = m.zHist.0
return
endProcedure histRead
histLine: procedure expose m.
parse arg rx, li
parse var li ph 5 fu 11 cm 20 ln 24 o 48 ts
ph = strip(ph)
call mapAdd phaseN2H, ph, 'ZHIST.'rx
if length(ph) \= 3 | ph <= laPha ,
| pos(left(ph, 1), 'PQRSTUVWXYZ') < 1 ,
| verify(substr(ph, 2), '0123456789') > 0 then
call err 'bad phase' ph 'in' rx':' li
m.zHist.rx.phaId = ph
fu = strip(fu)
m.zHist.rx.fun = fu
if length(fu) < 3 | length(fu) > 5 then
call err 'bad fun' fu 'in' rx':' li
m.zHist.rx.ctlMbr = translate(strip(cm))
if m.zHist.rx.ctlMbr = '' | length(m.zHist.rx.ctlMbr) > 8 then
call err 'bad ctlMbr' cm 'in' rx':' li
ln = strip(ln)
m.zHist.rx.link = ln
m.zHist.rx.lnkO = ''
if ln \== '' then
m.zHist.rx.lnkO = mapGet(phaseN2H, ln)
m.zHist.rx.opt = strip(o)
m.zHist.rx.tst = ts
return
endProcedure histLine
histAdd: procedure expose m.
parse arg ph
ds = m.ph.desc
fun = strip(m.ds.name)
if length(fun) < 3 | length(fun) > 5 then
call err 'histAdd bad fun' fun
fun = left(fun, 5)
if length(m.zHist.nextPha) \= 3 then
call err 'histAdd not preceeded by histNext'
ax = m.zHist.addIx
lnk = m.ph.disp
if lnk == '' then
lnk = ' '
else
lnk = m.lnk.phaId
if length(lnk) \== 3 then
call err 'histAdd bad link' lnk lnkX
if m.ph.phaId \== m.zHist.nextPha then
call err 'phaId mismatch'
li = m.zHist.nextPha fun left(dsnGetMbr(m.ctlMbr), 8) lnk m.ph.opt
tst = ' 'userid() date(s) time()
li = overlay(tst, li, 73-length(tst))
ax = ax+1
m.zHist.addIx = ax
m.zHistR.ax = li
call histLine ax, li
hx = m.zHist.0
m.zHist.hx.phase = ph
m.zHist.phase = ph
m.zHist.hx.desc = ds
m.zHist.nextPha = ''
return
endProcedure histAdd
histNext: procedure expose m.
if m.zHist.nextPha \== '' then
call err 'two histNext in seq'
if m.zHist.addIx = 0 then
m.zHist.nextPha = 'P00'
else do
lx = m.zHist.addIx
la = m.zHist.lx.phaId
if substr(la, 2) < 99 then
m.zHist.nextPha = left(la, 1)right(substr(la, 2)+1, 2, 0)
else do
nx = substr('PQRSTUVWXY', 1+pos(left(la, 1), 'PQRSTUVWX'),
, 1)
if nx == 'P' then
call err 'phase overflow' la
m.zHist.nextPha = nx'00'
end
end
return m.zHist.nextPha
endProcedure histNext
histWrite: procedure expose m.
if m.zHist.addIx == m.zHistR.0 then
return
call writeDsn dsnSetMbr(m.ctlMbr, 'zHist'),
, 'M.ZHISTR.', m.zHist.addIx, 1
do ax = m.zHistR.0+1 to m.zHist.addIx
call mAdd 'CI', m.zHistR.ax
end
m.zHistR.0 = m.zHist.addIx
return
endProcedure histWrite
/*** goal searcher: search the next function
search a path of phases with
goal in output of end node
inputs of each node in outputs of preceeding nodes,
current phase or ancestors
remove permutation and superset paths
expand ctlMbr if otherwise no path is found ****************/
funGoalSearch: procedure expose m.
parse arg goal
/* find current path and outputs */
m.phaseOut = ''
m.done = ''
dp = m.zHist.phase
do while dp \== ''
dsc = m.dp.desc
m.done = m.dsc.name m.done
do ix=1 to m.dp.io.0
i = m.dp.io.ix
if m.i.io == 'o' & wordPos(m.i.type, m.phaseOut) < 1 then
m.phaseOut = m.phaseOut m.i.type
end
dp = m.dp.disp
end
/* find first goal not reached yet */
do gx=1
g1 = word(goal, gx)
if g1 == '' then
exit erI('goals' goal 'already reached' ,
'\n entweder neues goal setzen,' ,
'\n oder Funktion angeben')
g1 = descOutFind(g1)
if wordPos(g1, m.phaseOut) < 1 then
leave
end
/* search paths */
m.sePa.0 = 0
if \ phaseSearchPathAll(m.phaseOut, m.done, g1, 0) then do
/* no path found --> expand ctlMbr? */
if envGetO('ctl.obj') == '' ,
& wordPos(g1, 'obj pra ala pitRe') > 0 then
exit ctlMbrExpand('obj', , 1)
if envGet('ctl.vcats.0') < 1 ,
& wordPos(g1, 'ana cim maRec mon') > 0 then
exit ctlMbrExpand('vcatSpec', , 1)
exit erI('cannot reach goal' g1 'please specify fun')
end
ch = ''
/* find next functions */
do sx = 1 to m.sepa.0
c1 = word(m.sePa.sx, words(m.done)+1)
if wordPos(c1, ch) < 1 then
ch = ch c1
end
if words(ch) = 1 then /* return single function */
return strip(ch)
/* tell user the choices */
say 'from' m.done 'to goal' goal
do sx = 1 to m.sepa.0
say ' by path' subword(m.sePa.sx, words(m.done)+1)
end
exit erI('multiple paths, choose one fun from'ch)
endProcedure funGoalSearch
/*--- find an output ioType
with abbreviations in any case -----------------------------*/
descOutFind: procedure expose m.
parse arg abbrev
if m.descOutIni \== 1 then do /* lazy initialisation */
m.descOutIni = 1
m.descOut = ''
do dx=1 to m.descs.0
d = m.descs.dx
do ix=1 to m.d.io.0
i = m.d.io.ix
if m.i.io == 'o' & wordPos(m.i.type, m.descOut) < 1 then
m.descOut = m.descOut m.i.type
end
end
m.descOutU = translate(m.descOut)
end
uu = ' 'translate(abbrev)
ff = ''
gx = 0
do forever
gx = pos(uu, m.descOutU, gx+1)
if gx < 1 then
leave
f1 = word(substr(m.descOut, gx+1), 1)
if length(f1) = length(abbrev) then
return f1
ff = ff f1
end
if words(ff) = 1 then
return strip(ff) /* return single abbreviation */
if ff = '' then
exit erI('unknown goal' abbrev)
else
exit erI('goal' abbrev 'not unique specify:'ff)
endProcedure descOutFind
/*--- search with all funs -------------------------------------------*/
phaseSearchPathAll: procedure expose m.
parse arg o, pa, goal, firstOnly
px = 0
do dx=1 to m.descs.0
d1 = m.descs.dx
if m.d1.io.0 < 1 then
iterate
if phaseDescSearchPath(d1, o, pa, goal, firstOnly) then do
if firstOnly then
return 1
px = px + 1
end
end
return px > 0
endProcedure phaseSearchPathAll
/*--- search one fun -------------------------------------------------*/
phaseDescSearchPath: procedure expose m.
parse arg d force, o, pa, goal, firstOnly
if wordPos(m.d.name, pa) > 0 & force \== 1 then
return 0
pa = pa m.d.name
do dx = 1 to m.d.io.0
f1 = m.d.io.dx
if m.f1.IO == 'o' then
o = o m.f1.type
else if m.f1.IO == 'i' then
if wordPos(m.f1.type, o) < 1 then
return 0
end
if wordPos(goal, o) > 0 then
return searchPathMerge(pa)
return phaseSearchPathAll(o, pa, goal, firstOnly)
endProcedure phaseDescSearchPath
/*--- merge a path: remove permustation and supersets ----------------*/
searchPathMerge: procedure expose m.
parse arg pa
sx = 1
do while sx <= m.sepa.0
do wx=1
if word(pa, wx) \== word(m.sepa.sx, wx) then
leave
if word(pa, wx) == '' then do
/* say '???mrg path' pa '= m.sepa.'sx m.sepa.sx */
return 1
end
end
if wrdisSubset(subWord(m.sepa.sx, wx), subWord(pa, wx)) then do
/*say '???mrg path' pa 'super of m.sepa.'sx m.sepa.sx */
return 1
end
if wrdisSubset(subWord(pa, wx), subWord(m.sepa.sx, wx)) then do
/* say '???mrg path' pa 'sub of m.sepa.'sx m.sepa.sx */
/* remove longer old path and continue search */
tx = m.sepa.0
m.sepa.sx = m.sepa.tx
m.sepa.0 = tx-1
end
else do
sx = sx + 1 /* inComparable: test next */
end
end
/* say '???mrg path' pa 'adding' */
call mAdd sepa, pa
return 1
endProcedure searchPathMerge
wrdIsSubset: procedure expose m.
parse arg sma, big
do sx=1
s1 = word(sma, sx)
if s1 == '' then
return 1
if wordPos(s1, big) < 1 then
return 0
end
endProcedure wrdIsSubset
/*** phase ************************************************************/
phaseIni: procedure expose m.
if m.phase.ini == 1 then
return
call mapReset phaseN2H
m.phase.ini = 1
c1 = classNew('u f const v, f part v, f byte v')
call classNew 'n Est u f ts' c1 ',f ix' c1
call classNew 'n Ctl u f dbSub v, f goal v, f fun v',
',f fromTst v, f toTst v, f sql v, f obj r' ,
classNew('u f type v, f crDb v, f tbTs v, f parts v'),
',f smsSG v, f vcats s' classNew('u f vcat v'),
',f est Est, f sys s' ,
classNew('u f sys v, f jobs v, f member v')
call classNew 'n IO u f IO v, f TYPE v, f DOAL v'
call classNew 'n IOTIn u IO', 'm',
, "new parse arg ., m.m.type, m.m.doAl; m.m.io='i'" ,
, 'ioInst return ioTInInst(m, pha)'
call classNew 'n IOTCtl u IO', 'm',
, "new parse arg ., m.m.type, m.m.doAl; m.m.io='o'" ,
, "ioInst return IOTCtlInst(m, pha)"
call classNew 'n IOTAlv u IO', 'm',
, "new parse arg ., m.m.type, m.m.doAl; m.m.io='o'" ,
, "ioInst return ioTAlvInst(m, pha)"
call classNew 'n IOTPha u IO, f mbr v', 'm',
, "new parse arg ., m.m.type m.m.mbr, m.m.doAl;",
"m.m.io='o'" ,
, "ioInst return IOTPhaInst(m, pha)"
call classNew 'n IOTAla u IOTPha', 'm',
, "ioInst return IOTAlaInst(m, pha)"
call classNew 'n IOInst u IO, f CopyT r, f FREE v', 'm',
, "new call err 'abstract class IOInst'" ,
, "IOAlloc return ''"
call classNew 'n IOCtlSpec u IOInst', 'm',
, "new parse arg ., m.m.type; m.m.io = 'o'",
, "ioInfo return 'ctlMbr' m.m.type"
call classNew 'n IODsn u IOInst, f DD v, f DSN v, f ATTS v', 'm',
, "new parse arg ., m.m.io m.m.type, m.m.dsn, m.m.atts",
, "IOAlloc return ioDsnAlloc(m, aIO)",
, "ioInfo return m.m.dsn"
call classNew 'n PhaseDesc u f NAME v, f CLASS v, f IO s r'
call mapReset descN
m.descs.0 = 0
call phaseDescAdd 'new PhaseNew'
call phaseDescAdd 'link PhaseLink'
call phaseDescAdd 'obj PhaseObj',
, mNew('IOTIn', 'obj', 0), mNew('IOTAlv', 'obj')
call phaseDescAdd 'copy PhaseCopy'
call phaseDescAdd 'make PhaseMake'
call phaseDescAdd 'pra PhasePRA',
, mNew('IOTIn', 'obj'), mNew('IOTAlv', 'obj', 0),
, mNew('IOTCtl', 'pra', 0), mNew('IOTCtl', 'cont', 0),
, mNew('IOTAlv', 'util', 0),mNew('IOTAlv', 'query', 0)
call phaseDescAdd 'pitRe PhasePitRec',
, mNew('IOTIn', 'obj', 0),
, mNew('IOTCtl', 'pitRe'), mNew('IOTCtl', 'staAll')
call phaseDescAdd 'ala PhaseALA',
, mNew('IOTIn', 'obj', 0),
, mNew('IOTIn', 'util', 0),mNew('IOTIn', 'query', 0),
, mNew('IOTCtl', 'ala', 0), mNew('IOTCtl','staAll'),
, mNew('IOTAla', 'repSu'),
, mNew('IOTAla', 'repDe') ,
, mNew('IOTAla', 'sql')
call phaseDescAdd 'ana PhaseAna',
, mNew('IOTIn', 'vcatSpec', 0), mNew('IOTCtl', 'ana', 0),
, mNew('IOTCtl', 'tsDsn', 0),mNew('IOTCtl', 'ixDsn', 0)
call phaseDescAdd 'cim PhaseCim',
, mNew('IOTIn', 'tsDsn'),mNew('IOTIn', 'ixDsn') ,
, mNew('IOTAlv', 'obj'),
, mNew('IOTCtl', 'cim'),mNew('IOTCtl', 'cim2'),
, mNew('IOTCtl', 'cimDe', 0),mNew('IOTCtl', 'cont', 0)
call phaseDescAdd 'maRec PhaseMaRec',
, mNew('IOTIn', 'obj'),
, mNew('IOTIn', 'cpTb'),
, mNew('IOTPha', 'maRec jclAll', 0),
, mNew('IOTPha', 'staAll'),
, mNew('IOTPha', 'jclAll')
call phaseDescAdd 'mon PhaseMon',
, mNew('IOTIn', 'staAll'), mNew('IOTPha', 'mon', 0)
/* am Ende damit es autopilot erst zuletzt bringt */
call phaseDescAdd 'cpTb PhaseCpTb',
, mNew('IOTCtl', 'cpTb')
call classNew 'n Phase u f PHAID v, f DESC r' ,
', f OPT v, f DISP r, f IO s r, f CTL r, f FARGS v' ,
',f CTLMBR v, f CTLPRE v, f ALVPRE v, f PHAPRE v', 'm',
, "new call phaseReset m, arg, arg2, arg3",
, "phaseReset ",
, "phaseWork call err 'call of abstract phaseWork('m",
"':'className(objClass(m))') pArg='m.m.pArg",
, "phaseCont return ''"
call classNew 'n PhaseNew u Phase', 'm',
, "phaseReset call phaseNewReset m"
call classNew 'n PhaseLink u Phase'
call classNew 'n PhaseObj u Phase', 'm',
, "phaseWork return phaseObjWork(m)"
call classNew 'n PhaseCopy u Phase', 'm',
, "phaseReset call phaseCopyReset m",
, "phaseWork return phaseCopyWork(m)"
call classNew 'n PhaseMake u Phase', 'm',
, "phaseReset call phaseMakeReset m",
, "phaseWork return phaseMakeWork(m)"
call classNew 'n PhasePRA u Phase', 'm',
, "phaseWork return phasePRAWork(m)",
, "phaseCont return phasePRACont(m)"
call classNew 'n PhaseALA u Phase', 'm',
, "phaseReset call phaseALAReset m",
, "phaseWork return phaseALAWork(m)",
, "phaseCont return phaseMonFor(m, fun)"
call classNew 'n PhasePitRec u Phase', 'm',
, "phaseWork return phasePitReWork(m)",
, "phaseCont return phaseMonFor(m, fun)"
call classNew 'n PhaseAna u Phase', 'm',
, "phaseWork return phaseAnaWork(m)",
, "phaseCont return phaseAnaCont(m)"
call classNew 'n PhaseCim u Phase', 'm',
, "phaseWork return phaseCimWork(m)",
, "phaseCont return phaseCIMCont(m)"
call classNew 'n PhaseCpTb u Phase', 'm',
, "phaseWork return phaseCpTbWork(m)",
, "phaseCont return phaseCpTbCont(m)"
call classNew 'n PhaseMaRec u Phase', 'm',
, "phaseWork return phaseMaRecWork(m)",
, "phaseCont return phaseMonFor(m, fun)"
call classNew 'n PhaseMon u Phase', 'm',
, "phaseReset call phaseMonReset m",
, "phaseWork return phaseMonWork(m)",
, "phaseCont return phaseMonCont(m, fun)"
return
endProcedure phaseIni
/**** PhaseDesc: description for a phase ******************************/
phaseDescAdd: procedure expose m.
n = mNew('PhaseDesc')
parse arg m.n.name m.n.class
call mAdd descs, mapAdd(descN, translate(m.n.name), n)
do ix=2 to arg()
call mAdd n'.IO', arg(ix)
end
return n
endProcedure phaseDescAdd
phaseDescGet: procedure expose m.
parse arg fun
if mapHasKey(descN, translate(fun)) then
return mapGet(descN, translate(fun))
call erI 'phaseDesc' fun 'not implemented'
endProcedure phaseDescGet
phaseDescMake: procedure expose m.
parse arg m, phase, dp, opt
return mNew(m.m.class, m, phase dp, opt)
endProcedure phaseDescMake
/**** IO: IOTemplates and IOInstances *********************************/
/**** IOT: IO Templates ***********************************************/
ioInst: procedure expose m.
parse arg m, pha
interpret objMet(m, 'ioInst')
endProcedure ioInst
ioInfo: procedure expose m.
parse arg m
interpret objMet(m, 'ioInfo')
endProcedure ioInst
ioCopy: procedure expose m.
parse arg o, aIo, doAlloc
n = oCopyNew(o)
m.n.io = aIo
m.n.dd = ''
m.n.doAl = doAlloc \== 0
return n
endProcedure ioCopy
/**** IOTIn: Input file ***********************************************/
ioTInInst: procedure expose m.
parse arg m, pha, doAlloc
f = phaseIoFind(m.pha.disp, m.m.type, 'o')
/* if f == '' then ???wkTst???
return '' */
return ioCopy(f, 'i', m.m.doAl)
endProcedure ioTInInst
/**** IOTCtl: IO Template for Mbr in CtlLibrary **********************/
IOTCtlInst: procedure expose m.
parse arg m, pha
t5 = strip(left(m.m.type, 5))
i = mNew('IODsn', 'o' m.m.type, m.pha.ctlPre || t5')')
m.i.copyT = m
m.i.doAl = m.m.doAl \== 0
return i
endProcedure IOTCtlInst
/**** IOTAlV: IO Template for Mbr in ALV Library **********************/
ioTAlVInst: procedure expose m.
parse arg m, pha
t5 = strip(left(m.m.type, 5))
i = mNew('IODsn', 'o' m.m.type, m.pha.alvPre || t5')')
m.i.atts = '::v'
m.i.copyT = m
m.i.doAl = m.m.doAl \== 0
return i
endProcedure IOTAlvInst
/**** IOTPha for phase Library ****************************************/
ioTPhaInst: procedure expose m.
parse arg m, pha
mb = translate(strip(if(m.m.mbr == '', m.m.type, m.m.mbr)))
dsn = m.pha.phaPre'('mb')'
i = mNew('IODsn', 'o' m.m.type, dsn , '::f')
m.i.doAl = m.m.doAl \== 0
return i
endProcedure ioTPhaInst
/**** IOTAla for Ala: pha Dsn *****************************************/
ioTAlaInst: procedure expose m.
parse arg m, pha
parse var m.pha.opt id sql
dsn = translate(m.pha.phaPre'.'id'.',
|| if(m.m.type=='sql', 's'sql, m.m.type))
i = mNew('IODsn', 'o' m.m.type, dsn)
m.i.doAl = 0
return i
endProcedure ioTAlaInst
/**** IOInstances: implement a file ***********************************/
ioAlloc: procedure expose m.
parse arg m, aIO
interpret objMet(m, 'IOAlloc')
endProcedure ioAlloc
/**** IODsn: IO for a DSN *********************************************/
ioDsnAlloc: procedure expose m.
parse arg m, aIO
uIO = aIO
if aIO == '' then
uIO = m.m.io
if m.m.dsn == '' then
call err 'empty dsn'
if m.m.free \== '' then
call err 'already allocated'
ds = translate(dsnSetMbr(m.m.dsn))
if aIO == '' & \ m.m.doAl then do
if uIO \== 'i' & m.m.atts \== '' & m.dsExists.ds\==1 then do
m.dsExists.ds = 1
call createDsn m.m.dsn, m.m.atts
end
return ''
end
if m.m.dd == '' then
m.m.dd = m.m.type
res = dsnAlloc("shr dd("m.m.dd") dsn('"m.m.dsn"')" m.m.atts)
m.dsExists.ds = 1
if word(res, 1) \== translate(m.m.dd) then
call err 'dd mismatch'
if uIO = 'o' then do
call writeDDBegin m.m.dd
m.m.free = "call writeDDEnd '"m.m.dd"';" subword(res, 2)
end
else do
m.m.free = "call readDDEnd '"m.m.dd"';" subword(res, 2)
end
return m.m.free
endProcedure ioDsnAlloc
/**** class phase: do the work for a phase ****************************/
phaseReset: procedure expose m.
parse arg m, dsc, aPh dp, m.m.opt
m.m.desc = dsc
m.m.phaId = aPh
m.m.disp = dp
m.m.ctl = envGetO('ctl')
m.m.ctlMbr = m.ctlMbr
m.m.ctlPre = dsnSetMbr(m.ctlMbr)'('aPh
m.m.alvPre = dsnSetMbr(m.ctlMbr)'.ALV('aPh
m.m.phaPre = dsnSetMbr(m.ctlMbr)'.'aPh
interpret objMet(m, 'phaseReset')
do dx = 1 to m.dsc.io.0
call mAdd m'.IO', IOInst(m.dsc.io.dx, m)
end
return m
endProcedure phaseReset
phaseWork: procedure expose m.
parse arg m
interpret objMet(m, 'phaseWork')
endProcedure phaseWork
phaseCont: procedure expose m.
parse arg m, fun
interpret objMet(m, 'phaseCont')
endProcedure phaseCont
/*--- alloc, work, free ----------------------------------------------*/
phaseDoWork: procedure expose m.
parse arg m
do fx=1 to m.m.io.0
call IOAlloc m.m.io.fx
end
cont = phaseWork(m)
do fx=1 to m.m.io.0
f1 = m.m.io.fx
interpret m.f1.free
m.f1.free = ''
end
return cont
endProcedure phaseDoWork
/*--- postwork: user actions after a phase is completed --------------*/
phasePostWork: procedure expose m.
parse arg ph, cont
if ph == '' then
ph = m.zHist.phase
cx = 0
res = ''
do while cx < length(cont)
ex = pos(';', cont, cx+1)
if ex <= cx then
ex = length(cont)+1
parse value substr(cont, cx+1, ex-cx-1) with c1 cr
cr = strip(cr)
cx = ex
if c1 == '' then
iterate
if wordPos(c1, 'c f q u w') > 0 then
res = strip(c1 cr)
else if c1 == 'e' | c1 == 'v' then
call phaseEdit ph, c1, cr
else if c1 == 'm' then
say cr
else
say 'bad cont' c1 'with' cr
end
return res
endProcedure phasePostWork
/*--- find a phase by its name ---------------------------------------*/
phaseById: procedure expose m.
parse arg nm
if nm == '' then
return m.zHist.phase
h = mapGet(phaseN2H, translate(nm), '')
if h \== '' then
return m.h.phase
if arg() > 1 then
return arg(2)
return erI('phase' nm 'missing in this ControlLibrary')
endProcedur phaseById
/*--- find a phase by its name ---------------------------------------*/
phaseInHistByName: procedure expose m.
parse arg ph, nm, cond
if ph == '' then
ph = m.zHist.phase
dp = ph
do while dp \== ''
dsc = m.dp.desc
if m.dsc.name == nm then
return dp
dp = m.dp.disp
end
if cond == 1 then
return ''
dsc = m.ph.desc
return erI('phase' nm 'missing in' m.dsc.name 'and ancestors')
endProcedure phaseInHistByName
/*--- find an io by an expression with abbreviations ---------------*/
phaseIOExFind: procedure expose m.
parse arg exp, cond
rest = exp
ph = ''
ioEx = 'o'
do while words(rest) > 1
parse var rest w1 rest
u1 = translate(w1)
if u1 == 'I' | u1 == 'O' | u1 == 'IO' | u1 = 'OI' then
ioEx = translate(w1, 'io', 'IO')
else
ph = w1
end
p = phaseById(ph)
obj = strip(rest)
if pos('h', cond) > 0 then
return phaseIOFind(p, obj, ioEx, cond)
else if pos('a', cond) > 0 then
return phaseIOFin1A(p, obj, ioEx, pos('r', cond) > 0)
else
return phaseIOFin1( p, obj, ioEx, pos('r', cond) > 0)
phaseIOExFind
/*--- find io in this phase with given type and i/o
or in any of its ancestors ---------------------------------*/
phaseIOFind: procedure expose m.
parse arg m, aTy, aIOs, cond
if aIOs == '' then
aIOs = 'o'
cP = m
do while cP \== ''
r1 = phaseIoFin1(cP, aTy, aIOs, 1)
if r1 \== '' then
return r1
cP = m.cP.disp
end
if pos('a', cond) > 0 then do
cP = m
do while cP \== ''
r1 = phaseIoFin1A(cP, aTy, aIOs, 1)
if r1 \== '' then
return r1
cP = m.cP.disp
end
end
if pos('r', cond) > 0 then
return ''
call erI 'no io type' aIOs aTy 'found in' m.m.phaId ,
'and ancestors'
endProcedure phaseIOFind
/*--- find io in this phase only with given type and i/o -------------*/
phaseIOFin1: procedure expose m.
parse arg m, aTy, aIOs, cond
withAbbr = pos('a', cond) > 0
uTy = translate(aTy)
if aIOs == '' then
aIOs = 'io'
do fx=1 to m.m.io.0
f1 = m.m.io.fx
if pos(m.f1.io, aIOs) > 0 & m.f1.type == aTy then
return f1
end
if cond == 1 then
return ''
call erI 'no io type' aIOs aTy 'found in' m.m.phaId
endProcedure phaseIoFin1
/*--- find io in this phase only with given io and type abbrev -------*/
phaseIOFin1A: procedure expose m.
parse arg m, aTy, aIOs, cond
uTy = translate(aTy)
if aIOs == '' then
aIOs = 'io'
do fx=1 to m.m.io.0
f1 = m.m.io.fx
if pos(m.f1.io, aIOs) > 0 ,
& abbrev(translate(m.f1.type), uTy) then
return f1
end
if cond == 1 then
return ''
call erI 'no io type' aIOs aTy 'abbrev found in' m.m.phaId
endProcedure phaseIoFin1A
/*--- gen rexx source for variables ----------------------------------*/
genRexx: procedure expose m.
parse arg lst
vars = ''
co = ''
do wx=1 to words(lst)
w1 = word(lst, wx)
if right(w1, 1) == '$' then do
nm = left(w1, length(w1)-1)
va = envGet('ctl.'nm)
end
else if pos('<', w1) > 0 then do
parse var w1 nm '<' src
va = envGet(src)
end
else if pos('=', w1) > 0 then do
parse var w1 nm "=" va
end
else do
nm = w1
va = envGet(nm)
end
vars = vars nm
if translate(nm) \= nm then
co = co'; ggNm ='quote(nm)'; v.ggNm'
else
co = co'; v.'nm
co = co'='quote(va)
end
return 'v.vars='quote(vars)co
endProcedure genRexx
/*** phase subclasses: concrete functions *****************************/
/*--- info: history with IOs -----------------------------------------*/
phaseInfo: procedure expose m.
parse arg nm
ph = phaseById(nm)
m.o.0 = 0
dp = ph
do while dp \== ''
na = m.dp.phaId
hi = mapGet(phaseN2H, na)
hx = substr(hi, lastPos('.', hi)+1)
call mAdd o, m.zHistR.hx
do fx=1 to m.dp.io.0
f = m.dp.io.fx
call mAdd o, ' ' if(m.f.io == 'i', 'in ', 'out'),
ioInfo(f)
end
dp = m.dp.disp
end
dsn = m.ph.ctlPre'Info)'
call writeDsn dsn, 'M.O.', , 1
call adrIsp "view dataset('"dsn"')", 4
return 0
endProcedure phaseInfo
/*--- link: link into a new controlMember ----------------------------*/
phaseLink: procedure expose m.
parse arg cm phaN
if cm = '' & phaN == '' then
exit erI('neither mbr nor phase specified')
phOld = ''
if phaN \== '' then
phOld = phaseById(phaN, '')
if phOld == '' then do
parse upper arg phaN cm
phOld = phaseById(phaN)
end
if cm >= 'P' then
exit erI('new controlMember' cm 'should be < P')
phId = histNext()
dsc = phaseDescGet('link')
ph = phaseDescMake(dsc, phId, phOld)
if cm == '' then do
call histAdd ph
call histWrite
call ctlMbrUpdate
return ''
end
cmDsn = dsnSetMbr(m.ctlMbr, cm)
if sysDsn("'"cmDsn"'") = 'OK' then
exit erI('new controlMember already exists')
m.ctlMbr = cmDsn
do cx=1 to m.ci.0 until abbrev(m.ci.cx, '$#end')
end
m.ci.0 = cx
call histAdd ph
call writeDsn cmDsn, 'M.CI.', , 1
call histWrite
if m.isEditing then
call adrIsp "edit dataset('"m.ctlMbr"')", 4
return 0
endProcedure phaseLink
/*--- edit a file of a phase -----------------------------------------*/
phaseEdit: procedure expose m.
parse arg p, f, aObj
obj = aObj
fun = if(translate(f)='E', 'edit', 'view')
ed = phaseIOExFind(aObj, 'ah')
if className(objClass(ed)) \== 'IODsn' then
call erI 'cannot edit' aObj 'not dsn type but' ioInfo(ed)
else if sysvar('sysEnv') \== 'FORE' ,
| sysvar('sysISPF') \== 'ACTIVE' then
say fun m.ed.dsn
else
return adrIsp(fun "dataset('"m.ed.dsn"')", 4) == 0 & f = 'e'
return 0
endProcedure phaseEdit
/**** PhaseNew: the startUp phase *************************************/
phaseNewReset: procedure expose m.
parse arg m
if envGetO('ctl.obj') \== '' then
call mAdd m'.IO', mNew('IOCtlSpec', 'obj')
if envGet('ctl.vcats.0') > 0 then
call mAdd m'.IO', mNew('IOCtlSpec', 'vcatSpec')
return
endProcedure phaseNewReset
phaseNewCont: procedure expose m.
parse arg m
return ''
endProcedure phaseNewCont
phaseNewWorker: procedure expose m.
parse upper arg subsys f1
if length(subsys) \= 4 then
call erI 'invalid db2 subsys' subsys 'for function n'
call envPut 'dbSub', subsys
call envPut 'f1', f1
if m.ctlMbr == '' then
m.ctlMbr = 'DSN.MAREC.D'substr(date('s'), 3),
|| '.T'translate('124578', time(), '12345678')'(A)'
else do
so = sysDsn("'"m.ctlMbr"'")
if so == "DATASET NOT FOUND" then
nop
else if so == 'OK' then do
call readDsn m.ctlMbr, i.
if i.0 <> 0 then
call erI 'fun new but ctlMbr' m.ctlMbr 'not empty'
end
else if so \== 'MEMBER NOT FOUND' then
call erI 'fun new but ctlMbr' m.ctlMbr 'sysDsn' so
end
call histRead
if m.zHist.0 > 0 & (m.zHist.1.fun \== 'new',
| word(m.zHist.1.opt, 1) \== subSys) then
call erI 'db subSys' subSys 'mismatch to' m.zHist.1.opt
phId = histNext()
dsc = phaseDescGet('new')
pha = phaseDescMake(dsc, phId, , subsys f1)
m.ci.0 = 0
call histAdd pha
nb = runInline2St('new')
call ctlMbrWrite 1, nb
m.ci.0 = 0
m.zHistR.0 = 0
call histWrite
if m.isEditing then
nop /* we edit the member already, just return| */
else if sysvar('sysEnv')='FORE' & sysvar('sysISPF')='ACTIVE' then
call adrIsp "edit dataset('"m.ctlMbr"')", 4
return 0
endProcedure phaseNewWorker
runInline2St: procedure expose m.
parse arg inl
jIn = jBufWriteStem(jBuf(), mapInline(inl))
jOut= jBuf()
call compRun '=', jIn, jOut
return jOut'.BUF'
endProcedure runInline2St
/*
$</new/
* pit Recovery analyze parameters
dbSub = $dbSub
goal = pra
$/new/
*/
/**** PhaseCopy ********************************************************
copy and edit an existing output file ***********************/
phaseCopyReset: procedure expose m.
parse arg m
if m.m.opt = '' then
call erI 'copy ohne option'
o0 = phaseIOExFind(m.m.opt, 'ah')
i1 = ioCopy(o0, 'i', 1)
m.i1.dd = 'copyIn'
o1 = ioInst(m.o0.copyT, m, 1)
m.o1.io = 'o'
m.o1.dd = 'copyOut'
call mAdd m'.IO', i1, o1
return m
endProcedure phaseCopyReset
phaseCopyWork: procedure expose m.
parse arg m
call readDD 'copyIn', i., '*'
call writeDD 'copyOut', i.
do fx=1 to m.m.io.0
i1 = m.m.io.fx
if m.i1.IO = 'o' & m.i1.dd = 'copyOut' then
return 'e' m.i1.type
end
call err 'copyOut not found'
endProcedure phaseCopyWork
/**** PhaseMake ********************************************************
make and edit an new output *********************************/
phaseMakeReset: procedure expose m.
parse arg m
opts = m.m.opt
do ox=1 to words(opts)
w1 = word(opts, ox)
o1 = ioInst(mNew('IOTCtl', w1, 1), m)
call mAdd m'.IO', o1
end
if ox <= 1 then
call erI 'make ohne option'
return m
endProcedure phaseMakeReset
phaseMakeWork: procedure expose m.
parse arg m
a = ''
do fx=1 to m.m.io.0
i1 = m.m.io.fx
a = a';e' m.i1.type
end
return a
endProcedure phaseMakeWork
/**** application phases: *********************************************/
/**** PhaseObj *********************************************************
expand an object list ***************************************/
phaseObjWork: procedure expose m.
parse arg m
fi = phaseIoFind(m.m.disp, 'obj', 'o')
if className(objClass(fi)) = 'IOCtlSpec' then
rdr = envGetO('ctl.obj')
else
rdr = file(m.fi.dsn)
if m.m.opt == '' then
m.m.opt = 'tb ix'
call phaseObjImpl rdr, m.m.opt, objWork
return 'v obj'
endProcedure phaseObjWork
phaseObjImpl: procedure expose m.
parse arg rdr, toTypes, oSt
call mapReset quNm, 'k'
m.quNm.objs.0 = 0
call sqlConnect envGet('ctl.dbSub')
s = scanRead(rdr, , , '*')
call jOpen s, '<'
call scanSpaceNl s
qu = 'qualifierVergessen'
nm = 'nameVergessen'
do while \ scanAtEnd(s)
t1 = ''
call scanSpaceCom s
if scanVerify(s, '. ', 'm') then do
t1 = translate(m.s.tok)
if wordPos(t1, 'TB TS IX IS') > 0 then do
ty = t1
t1 = ''
call scanSpaceCom s
if scanVerify(s, '. ', 'm') then
t1 = translate(m.s.tok)
end
end
call scanSpaceCom s
if scanLit(s, '.') then
call scanSkip s
if scanVerify(s, '. ', 'm') then do
if t1 \== '' then
qu = t1
na = translate(m.s.tok)
end
else if t1 \== '' then do
na = t1
end
pa = ''
do forever
call scanSpaceCom s
if \ scanVerify(s, '0123456789') then
leave
t2 = m.s.tok
call scanSpaceCom s
if \ scanLit(s, ',', '-') then do
pa = pa || t2
leave
end
if m.s.tok == '-' & right(pa, 1) == '-' then
call scanErr s, 'bad list' pa t2 '-'
pa=pa || t2 || m.s.tok
end
call phaseObjImplSel m, quNm, toTypes, ty, qu, na, pa
call scanReadNl s, 1
call scanSpaceNl s
end
call jClose s
call sqlDisConnect
call sort mapKeys(quNm), quNm.sort, '<'
m.oSt.0 = 0
do sx=1 to m.quNm.sort.0
s = mapGet(quNm, m.quNm.sort.sx)
pa = ''
if m.s.partitions = 0 & m.s.part.0 = 1 then do
pa = 0
end
else do
pFr = ''
pL = m.s.partitions + 1
m.s.part.pL = 0
do px=1 to pL
if m.s.part.px == 1 then do
if pFr = '' then
pFr = px
end
else if pFr \== '' then do
if pFr = px-1 then
pa=pa','pFr
else
pa=pa','pFr'-' || (px-1)
pFr = ''
end
end
if pa = '' then
call err 'no partitions for' m.s.key
else
pa = substr(pa, 2)
end
call mAdd oSt, m.s.key pa m.s.info
end
call writeDD obj, 'M.'oSt'.'
return
endProcedure phaseObjImpl
phaseObjImplSel: procedure expose m.
parse arg m, quNm, toTypes, ty, qu, na, pa
ty = translate(ty, m.scan.alfLC, m.scan.alfUC)
toTypes = translate(toTypes, m.scan.alfLC, m.scan.alfUC)
upper qu na
if wordPos(ty, toTypes) > 0 then do
toTy = ty
end
else do
wx = wordPos(ty, 'tb ts ix is')
if wx > 0 then
toTy = word('ts tb is ix', wx)
else
toTy = '?'
end
if wordPos(toTy, toTypes) < 1 then
call err 'cannot convert' ty 'to' toTypes
if toTy == 'tb' | toTy == 'ts' then
cx = phaseObjImplSelTb(m, quNm, toTy, ty, qu, na, pa)
else if toTy == 'ix' | toTy == 'is' then
cx = phaseObjImplSelIx(m, quNm, toTy, ty, qu, na, pa)
else
call err 'bad toTy' toTy
if cx < 1 then
say 'warning no db2 objects found for' ty qu'.'na':'pa
return
endProcedure phaseObjImplSel
phaseObjImplSelTb: procedure expose m.
parse arg m, quNm, toTy, ty, qu, na, pa
sq = 'select t.dbName, t.tsName, t.creator, t.name' ,
',s.partitions, max(s.spacef*1024, -1) spc, t.cardf',
'from sysibm.sysTables t' ,
'join sysibm.sysTableSpace s',
'on s.dbName = t.dbName and s.name = t.tsName'
if ty == 'tb' then
sq = sq 'where t.creator' sqlClause(qu) ,
'and t.name' sqlClause(na) ,
'order by t.creator, t.name'
else if ty == 'ts' then
sq = sq 'where t.dbName' sqlClause(qu),
'and t.tsName' sqlClause(na),
'order by t.dbName, t.tsName'
else
call erC 'phaseObjImplSelTb bad ty' ty
sr = jOpen(sqlRdr(sq), '<')
do cx=0 while assNN('PP', jReadO(sr))
crNm = strip(m.pp.creator)'.'strip(m.pp.Name)
dbTs = strip(m.pp.dbName)'.'strip(m.pp.tsName)
if toTy == 'tb' then
ky = toTy crNm
else if toTy == 'ts' then
ky = 'ts' dbTs
else
call err 'bad toTy' toTy
o = mapGet(quNm, ky, '')
if o == '' then do
if toTy == 'tb' then
t2 = '*ts' dbTs
else
t2 = '*tb' crNm
o = phaseObjImplSelAdd(m, quNm, ky, m.pp.partitions,
, t2 '*cardf' m.pp.cardf '*spc' m.pp.spc)
end
call phaseObjImplSelSetParts ky, o, pa
end
call jClose sr
return cx
endProcedure phaseObjImplSelTb
phaseObjImplSelIx: procedure expose m.
parse arg m, quNm, toTy, ty, qu, na, pa
sq = 'select i.creator, i.name, t.dbName, i.indexSpace',
', i.tbCreator, i.tbName, i.fullKeyCardf' ,
', t.tsName, t.cardF, max(i.spacef*1024, -1) spc',
', (select max(partition) from sysibm.sysIndexPart p',
'where p.ixCreator = i.creator' ,
'and p.ixName = i.name) ixParts' ,
'from sysibm.sysIndexes i' ,
'join sysibm.sysTables t' ,
'on t.creator = i.tbCreator and t.name = i.tbName'
if ty == 'ix' then
sq = sq 'where i.creator' sqlClause(qu) ,
'and i.name' sqlClause(na) ,
'order by i.creator, i.name'
else if ty == 'is' then
sq = sq 'where i.dbName' sqlClause(qu),
'and i.indexSpace' sqlClause(na),
'order by i.dbName, i.indexSpace'
else
call err 'bad ty' ty
sr = jOpen(sqlRdr(sq), '<')
do cx=0 while assNN('PP', jReadO(sr))
crNm = strip(m.pp.creator)'.'strip(m.pp.Name)
dbIs = strip(m.pp.dbName)'.'strip(m.pp.indexSpace)
if toTy == 'ix' then
ky = toTy crNm
else if toTy == 'is' then
ky = toTy dbIs
else
call err 'bad toTy' toTy
o = mapGet(quNm, ky, '')
if o == '' then do
if toTy == 'ix' then
t2 = '*is' dbIs
else if toTy == 'is' then
t2 = '*ix' crNm
else
call err 'bad toTy' toTy
o = phaseObjImplSelAdd(m, quNm, ky, m.pp.ixParts,
, t2 '*ts' strip(m.pp.dbName)'.'strip(m.pp.tsName),
'*tb' strip(m.pp.tbCreator)'.'strip(m.pp.tbName) ,
'*cardf' m.pp.cardf '*spc' m.pp.spc,
'*fullkeycardf' m.pp.fullkeycardf)
end
call phaseObjImplSelSetParts ky, o, pa
end
call jClose sr
return cx
endProcedure phaseObjImplSelIx
phaseObjImplSelAdd: procedure expose m.
parse arg m, quNm, ky, parts, inf2
o = mAdd(quNm.objs, 1)
m.o = o
call mapAdd quNm, ky, o
m.o.key = ky
m.o.partitions = parts
m.o.info = '*parts' parts inf2
return o
endProcedure phaseObjImplSelAdd
phaseObjImplSelSetParts: procedure expose m.
parse arg ky, o, pa
if pa == '' | pa == 0 then
pa = if(m.o.partitions = 0, 0, '1-'m.o.partitions)
bad = ''
ex = listExpReset(partList, pa)
do while assNN('e1', listExp(ex))
e1=e1+0
if (e1=0 & m.o.partitions=0) ,
| (e1 >= 1 & e1 <= m.o.partitions) then
m.o.part.e1 = 1
else
bad = bad e1
end
if bad \== '' then
say 'ignoring bad partitions' bad ,
'for' ky pa 'partitions' m.o.partitions
return
endProcedure phaseObjImplSelSetParts
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
sqlList: procedure expose m.
parse arg fld, lst
ex = listExpReset(sqlList, lst)
res = ''
do while ass('e1', listExp(ex)) \== ''
res = res',' e1
end
res = substr(res, 3)
if pos(',', res) < 1 then
return fld '=' res
return fld 'in ('res')'
endProcedure sqlList
listExpReset: procedure expose m.
parse arg m, m.m.src
m.m.rg.1 = 'reset'
m.m.rg.2 = ''
m.m.pos = 1
return m
endProcedur listExpReset
listExp: procedure expose m.
parse arg m
la = m.m.rg.1
if la > m.m.rg.2 then
if listExpRg(m) == '' then
return ''
else
la = m.m.rg.1
m.m.rg.1 = la + 1
return la
endProcedure listExp
listExpRg: procedure expose m.
parse arg m
m.m.rg.1 = 'end'
m.m.rg.2 = ''
x0 = m.m.pos
do lx=1 to 2
x1 = verify(m.m.src, ' ', 'n', x0)
if x1 < 1 then do
m.m.pos = length(m.m.src)+1
leave
end
x2 = verify(m.m.src, '0123456789', 'n', x1)
if x2 = 0 then
x2 = length(m.m.src)+1
if x2 <= x1 then
call err 'non numeric listelement' substr(m.m.src, x1),
'in list' m.m.src
m.m.rg.lx = substr(m.m.src,x1, x2-x1)
x3 = verify(m.m.src, ' ', 'n', x2)
if x3 = 0 then do
m.m.pos = length(m.m.src)+1
leave
end
if substr(m.m.src, x3, 1) == ',' then do
m.m.pos = x3+1
leave
end
if substr(m.m.src, x3, 1) \== '-' | lx > 1 then
call err 'bad op' substr(m.m.src, x3) 'in list' m.m.src
x0 = x3+1
end
if m.m.rg.1 == 'end' then
return ''
if m.m.rg.2 == '' then
m.m.rg.2 = m.m.rg.1
if m.m.rg.1 <= m.m.rg.2 then
return m.m.rg.1 m.m.rg.2
say 'empty range' m.m.rg.1'-'m.m.rg.2 'in list' m.m.src
return listExpRg(m)
endProcedure listExpRg
/**** PhasePRA ******************************************************
analysis for pit recovery ***********************************/
phasePRAReset: procedure expose m.
parse arg m
return
endProcedure phasePRAReset
phasePRAWork: procedure expose m.
parse arg m
jb = phaseIOFin1(m, 'pra')
ut = phaseIOFin1(m, 'util')
qu = phaseIOFin1(m, 'query')
c = '#PRA####' envGet('ctl.dbSub') ,
cfgSkels() m.jb.dsn m.m.phaPre'.??????' ,
cfgRexx() m.ut.dsn m.qu.dsn,
phaseObjQnNm('tb')
call mrcGen10 c
if result <> 0 then
call erI 'db2mrc10 rc' result
call readDD 'obj', i.
oo = phaseIOFin1(m, 'obj', 'o')
call writeDsn m.oo.dsn, i., , 1
return 'e pra'
endProcedure phasePRAWork
phaseObjQnNm: procedure expose m.
parse arg argTy
c = ''
do tx=1 to m.objWork.0
parse var m.objWork.tx ty tbCr .
if ty \== argTy then do
say left('ignoring' strip(m.objWork.tx), 79)
iterate
end
if e.tbCr == 1 then
iterate
e.tbCr = 1
c = c tbCr
end
if c == '' then
return erI('no db2 objects' argTy 'in input obj')
return c
endProcedure phaseObjQnNm
phasePRACont: procedure expose m.
parse arg m
res = ''
do ix=1 to m.m.io.0
f1 = m.m.io.ix
if m.f1.type == 'obj' | m.f1.io == 'i' then
iterate
else if m.f1.type == 'pra' then do
if sysDsn("'"m.f1.dsn"'") \= 'OK' then
call erI 'pra Job has not been created' m.f1.dsn ';q'
end
else if m.f1.type == 'cont' then do
oDsn = m.f1.dsn
if sysDsn("'"oDsn"'") == 'OK' then
return ''
end
else if sysDsn("'"m.f1.dsn"'") = 'OK' then
res = res';v' m.f1.type
else
res = res';m wait until job has written' m.f1.type ';q'
end
if pos(';m', res) > 0 then
return res
i.1 = 'continue ending'
call writeDsn oDsn, i., 1
return res ';m please fix list of tables ;e o obj'
endProcedure phasePRACont
createDsn: procedure expose m.
parse arg lib, na
fr = dsnAlloc("dd(alLib) '"lib"'" na)
interpret subword(fr, 2)
return
endProcedure createDsn
/**** PhaseALA ****************************************************
Pit Recovery Variante 3: change table ***********************/
phaseALAReset: procedure expose m.
parse arg m
if m.m.opt == '' then
m.m.opt = 'C'||RIGHT(date('D'),3,'0'),
||substr(time(),1,2),
||substr(time(),4,2) ,
nn(envGet('ctl.sql'), 'REDO')
if words(m.m.opt) \== 2 then
call err 'phaseALAReset bad opt' m.m.opt
return
endProcedure phaseALAReset
phaseALAWork: procedure expose m.
parse arg m
e = ''
if envGet('ctl.fromTst') == '' | envGet('ctl.sql') == '' then do
call putCurTstLrsn
call ctlMbrAddLines runInline2St('ALA'), 'fromTst sql', 1
e = e', sql, fromTst'
end
if envGet('ctl.toTst') == '' then do
call putCurTstLrsn
call ctlMbrAddLines runInline2St('PitToTst'), 'toTst', 1
e = e", toTst"
end
if e \== '' then
call erC 'please specify' substr(e, 3)
frTst = decodeTst('fromTst')
toTst = decodeTst('toTst')
ba = translate(envGet('ctl.sql'))
if wordPos(ba, 'UNDO REDO') < 1 then
call erC 'specify sql as UNDO or REDO'
call staAllWrite word(m.m.opt, 1)
jb = phaseIOFin1(m, 'ala')
ut = phaseIOFind(m.m.disp, 'util')
qu = phaseIOFind(m.m.disp, 'query')
c = '#ALA####' envGet('ctl.dbSub') ,
cfgSkels() m.jb.dsn m.m.phaPre'.'word(m.m.opt, 1) ,
cfgRexx() m.ut.dsn m.qu.dsn ,
ba frTst toTst,
phaseObjQnNm('tb')
call mrcGen10 c
if result <> 0 then
call erI 'mrcGen10 rc' result
return 'e ala'
endProcedure phaseALAWork
putCurTstLrsn: procedure expose m.
if envHasKey('curTst') then
return
cTst = translate('1234-56-78', date('s'),'12345678'),
|| '-'translate(time('l'), '.', ':')
numeric digits 22 /* ???wkTst transparent handling in time || */
call envPut 'curTst', cTst
call envPut 'curLrsn', timeLZT2Lrsn(cTst)
return
endProcedure putCurTstLrsn
/*
$</ALA/
sql = $-{left('redo', 26)} $'$** UNDO or REDO sql in report'
* fromTst = $curTst $'$** Zeitpunkt/Lrsn von'
$/ALA/
$</PitToTst/
* toTst = $curTst $'$** timestamp'
* toTst = $-{left($curLrsn, 26)} $'$** oder LRSN'
$/PitToTst/ */
*/
/**** PhasePitRe: generate PitRecovery Jobs ***************************/
phasePitReWork: procedure expose m.
parse arg m
if envGet('ctl.toTst') == '' then do
call putCurTstLrsn
call ctlMbrAddLines runInline2St('PitToTst'), 'toTst', 1
call erC 'please specify toTst in ctlMbr'
end
call decodeTst 'toTst'
call classNew 'n TS u f DB v, f TS v, f PA v', 'm',
, 'new parse arg , m.m.db m.m.ts m.m.pa'
b = jOpen(jBuf(), '>')
p = jOpen(jBuf(), '>')
do ix = 1 to m.objWork.0
parse var m.objWork.ix ty dbTs pa .
if ty \== 'ts' then do
say 'ignoring' ty dbTs pa
iterate
end
parse var dbTs db '.' ts
parse var m.objWork.ix . '*parts' prts '*'
prts = strip(prts)
if db = '' | ts = '' then
call err 'bad ts line' ix m.objWork.ix
call jWriteO b, mNew('TS', db ts pa)
if (prts = 0 & pa = 0) | (prts = 1 & pa = 1) ,
| (pa = '1-' || prts) then do
call jWriteO p, mNew('TS', db ts '-- partitions' prts)
end
else do
ex = listExpReset(m'.liEx', pa)
do while ass('e1', listExp(ex)) \== ''
call jWriteO p, mNew('TS', db ts e1)
end
end
end
call envPutO 'ts', jClose(b)
call envPutO 'tsPa', jClose(p)
/* call jWriteAll m.j.out, envGetO('ts') */
jIn = jBufWriteStem(jBuf(), mapInline('pitRe'))
jOut= jBuf()
call compRun '@', jIn, file('dd(pitRe)')
call staAllWrite 'YPITRECO'
return 'v pitRe'
endProcedure phasePitReWork
/*
$@/pitRe/
$=c=-'//' || '*'
$=jobName=YPITRECO
$@with ctl $@=¢
//$jobName JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
${c}MAIN CLASS=LOG
${c}----------------------- -sta ut -----------------------------
//STAUT EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSub)
$!
$; $<.$ts $@forWith one $@=¢
-sta db($DB) spacenam($TS) acc(ut)
-dis db($DB) spacenam($TS)
$!
$@with ctl $@=¢
${c}----------------------- copy before -------------------------
$@ut{COPYBEF}
LISTDEF LST
$!
$; $<.$ts $@forWith one $@=¢
INCLUDE TABLESPACE $DB.$TS PARTLEVEL
$! $;
$@=¢
COPY LIST LST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL REFERENCE
$!
$@with ctl $@=¢
${c}----------------------- copy before -------------------------
$@ut{PITREC}
-- lrsn $toTstLrsn
-- locale Zurich time $toTstLzt
-- gmt $toTstGmt
LISTDEF LST
$!
$; $<.$tsPa $@forWith one $@=¢
INCLUDE TABLESPACE $DB.$TS PARTLEVEL $PA
$! $;
$@with ctl $@=¢
RECOVER LIST LST TOLOGPOINT X'$toTstLrsn'
PARALLEL
LISTDEF IXLST
INCLUDE INDEXSPACES LIST LST
REBUILD INDEX LIST IXLST
SORTDEVT SYSDA
-- SORTNUM 100
WORKDDN(TSYUTD)
$!
$@with ctl $@=¢
${c}----------------------- copy before -------------------------
$@ut{COPYAFT}
LISTDEF LST
$!
$; $<.$ts $@forWith one $@=¢
INCLUDE TABLESPACE $DB.$TS PARTLEVEL
$! $;
$@=¢
COPY LIST LST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL REFERENCE
$!
$@proc ut $@¢ parse arg , step; $=step=-step
$@=¢
//$-{left($step,9)} EXEC PGM=DSNUTILB,TIME=1440,
// PARM=($dbSub,'$jobName.$step'),
// REGION=0M
//DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSub.DBAA.LISTDEF(TEMPL)
//SYSIN DD *
$!
$!
$/pitRe/ */
/*--- write a staAll Member with for the given jobs ------------------*/
staAllWrite: procedure expose m.
parse arg jobs
call envPut 'staAllJobs', jobs
call writeDD 'staAll', 'M.'runInline2St('staAll')'.'
return
endProcedure staAllWrite
/*
$=/staAll/
= tablespaces indexspaces
= parts bytes secs parts bytes secs
$@do ix = 1 to words($staAllJobs) $@=¢
$-{right($ix, 3, 0) word($staAllJobs, $ix)}
$!
$/staAll/
*/
decodeTst: procedure expose m.
parse arg nm
numeric digits 22
tst = translate(envGet('ctl.'nm))
if tst == '' then
call erC nm 'missing'
if verify(tst, '0123456789ABCDEF', 'n') = 0 then
lrsn = left(tst, 12, 0)
else
lrsn = timeLZT2Lrsn(checkTst(tst))
LZT = timeLrsn2LZt(lrsn)
GMT = timeLrsn2GMT(lrsn)
say left(nm, 20) tst '==> lrsn' lrsn
say right('==> localZurich', 20) lzt
say right('==> gmt', 20) gmt
call envPut nm'Lrsn', lrsn
call envPut nm'Lzt', lzt
call envPut nm'Gmt', gmt
return lzt
endProcedure decodeTst
checkTst: procedure expose m.
parse arg src .
pic = '0000-00-00-00.00.00.000000'
say length(pic)
if length(src) < 10 then
return erI('timestamp too short:' src)
res = left(src, length(pic))
do cx=1 to length(pic)
r = substr(res, cx, 1)
p = substr(pic, cx, 1)
if r == p | (p == '0' & datatype(r, 'n')) then
nop
else if r == ' ' then
res = overlay(p, res, cx)
else
return erI('bad timestamp at' left(src, cx) 'in' src)
end
return res
endProcedure checkTst
/**** PhaseAna: MassRecovery analyze **********************************/
phaseAnaReset: procedure expose m.
parse arg m
return
endProcedure phaseAnaReset
phaseAnaWork: procedure expose m.
parse arg m
if envGet('ctl.vcats.0') < 1 then
call ctlMbrExpand 'vcatSpec', ,1
fm = phaseIOFin1(m, 'ana')
vars = 'DBSUB<ctl.dbSub ANAPRE='m.m.ctlPre 'DSNPRE='m.m.phaPre ,
'REXXLIB='cfgRexx() 'SKELS='cfgSkels(),
'vcat.0='envGet('ctl.vcats.0')
do vx=1 to envGet('ctl.vcats.0')
vars = vars 'vcat.'vx'='envGet('ctl.vcats.'vx'.vcat')
end
rx = genRexx(vars)
call maRecAna rx
return 'e ana'
endProcedure phaseAnaWork
phaseAnaCont: procedure expose m.
parse arg m, fun
fm = phaseIOFin1(m, 'tsDsn')
if sysDsn("'"m.fm.dsn"'") == 'OK' then do
fm = phaseIOFin1(m, 'ixDsn')
if sysDsn("'"m.fm.dsn"'") == 'OK' then
return ''
end
if phaseInHistByName( , 'cpTb', 1) \== '' then
return 'm wait until job generated' m.fm.type ,
'in' m.fm.dsn ';q'
return maRecWorkWri(phaseDescGet('cpTb'), m.m.phaId)';q'
endProcedure phaseAnaCont
/**** PhaseCim: Dsn Deletes, CimAnalyse und Cleanup ******************/
phaseCimReset: procedure expose m.
parse arg m
return
endProcedure phaseCimReset
phaseCimWork: procedure expose m.
parse arg m
if envGet('ctl.vcats.0') < 1 | envGet('ctl.smsSG') = '' then
exit ctlMbrExpand('vcatSpec', ,1)
vars = 'vcat.0<ctl.vcats.0'
do cx=1 to envGet('ctl.vcats.0')
vars = vars 'vcat.'cx'<ctl.vcats.'cx'.vcat'
end
cd = phaseIOFin1(m, 'cimDe')
call envPut 'cimDe', translate(m.cd.dsn)
call envPut 'rexxLib', cfgRexx()
rx = genRexx('rexxLib cimDe smsSG<ctl.smsSG DBSUB<ctl.dbSub' vars)
call maRecJob 'cim' rx
return 'e cim'
endProcedure phaseCimWork
phaseCimCont: procedure expose m.
parse arg m
co = phaseIOFin1(m, 'cont')
if sysDsn("'"m.co.dsn"'") == 'OK' then
return ''
cd = phaseIOFin1(m, 'cimDe')
cdEx = sysDsn("'"m.cd.dsn"'") == 'OK'
if cdEx then
say 'ist cim delete Job fertig gelaufen?'
else
say 'cim analyse job hat cimDe noch nicht erstellt'
say 'Eingabe: w=Wait for or start Jobs, c=Continue next phases'
parse upper pull an
if abbrev(an, 'C') then do
i.1 = 'cont ending'
call writeDsn m.co.dsn, i., 1
return ''
end
else if cdEx then
return 'e cim2;q'
else if phaseInHistByName( , 'cpTb', 1) == '' then
return maRecWorkWri(phaseDescGet('cpTb'), m.m.phaId)';q'
else
return erI('wait for or start cim jobs')
endProcedure phaseCimCont
/**** PhaseCpTb: $marec.$copyTb erstellen und laden *******************/
phaseCpTbWork: procedure expose m.
parse arg m
vars = vars 'rexxLib='cfgRexx() 'DBSUB<ctl.dbSub',
'phaPre='m.m.phaPre 'ctlPre='m.m.ctlPre
rx = genRexx('DBSUB<ctl.dbSub')
call maRecJob 'copyTable' rx
return 'e cpTb'
endProcedure phaseCpTbWork
phaseCpTbCont: procedure expose m.
parse arg m, args
if m.m.opt == '' then
return ''
return phaseCont(phaseById(m.m.opt), args)
endProcedure phaseCpTbCont
/**** PhaseMaRec: Mass Recovery Job Generator *************************/
phaseMaRecReset: procedure expose m.
parse arg m
return
endProcedure phaseMaRecReset
phaseMaRecWork: procedure expose m.
parse arg m
if \ ( envGet('ctl.sys.0') > 0 ,
& datatype(envGet('ctl.est.ts.const'), 'N') ,
& datatype(envGet('ctl.est.ts.part'), 'N') ,
& datatype(envGet('ctl.est.ts.byte'), 'N') ,
& datatype(envGet('ctl.est.ix.const'), 'N') ,
& datatype(envGet('ctl.est.ix.part'), 'N') ,
& datatype(envGet('ctl.est.ix.byte'), 'N') ,
) then
call exit ctlMbrExpand('maRec', , 1)
vars = 'rexxLib='cfgRexx() 'DBSUB<ctl.dbSub',
'phaPre='m.m.phaPre 'ctlPre='m.m.ctlPre,
'est.ts.const$ est.ts.part$ est.ts.byte$' ,
'est.ix.const$ est.ix.part$ est.ix.byte$' ,
'sys.0$'
do cx=1 to envGet('ctl.sys.0')
call envPut 'sys?'cx, envGet('ctl.sys.'cx'.sys'),
envGet('ctl.sys.'cx'.jobs'),
envGet('ctl.sys.'cx'.member')
vars = vars 'sys.'cx'<sys?'cx
end
call maRecJob 'maRec' genRexx(vars)
return 'e maRec'
endProcedure phaseMaRecWork
/**** PhaseMon: Monitor Marec execution *******************************/
phaseMonReset: procedure expose m.
parse arg m
w1 = word(m.m.opt, 1)
if length(w1) == 3 & verify(w1, 'PQRSTUVWXY0123456789') < 1 then do
m.m.fArgs = subword(m.m.opt, 2)
m.m.opt = w1
end
else do
m.m.fArgs = m.m.opt
jP = m.m.disp
do forever
if jP == '' then
call erI 'no maRec or pitRe phase found for monitoring'
jD = m.jP.desc
if m.jD.name == 'maRec' | m.jD.name == 'pitRe' ,
| m.jD.name == 'ala' then
leave
jP = m.jP.disp
end
m.m.opt = m.jP.phaId
end
return
endProcedure phaseMonReset
phaseMonWork: procedure expose m.
parse arg m
jP = phaseById(m.m.opt)
jD = m.jP.desc
call envPut 'ARGS', m.m.fArgs
free = ''
if m.jD.name \== 'maRec' then
free = ioAlloc(phaseIoFind(jP, 'obj'), 'i')
fm = phaseIoFin1(m, 'mon')
vars = 'LIB=??? ARGS DBSUB<ctl.dbSub',
'JOBLIB='if(m.jD.name=='maRec',m.jP.phaPre , m.jP.ctlPre),
'MONLIB='m.m.phaPre 'SHOWMBR='dsnGetMbr(m.fm.dsn) ,
'TYPE='m.jD.name
res = maRecMon(genRexx(vars))
interpret free
return if(res=0, 'v mon', 'q')
endProcedure phaseMonWork
phaseMonCont: procedure expose m.
parse arg m, fun
m.m.fArgs = fun
return phaseDoWork(m, fun)';q'
endProcedure phaseMonCont
phaseMonFor: procedure expose m.
parse arg m, fun
return maRecWorkWri(phaseDescGet('mon'), m.m.phaId fun) ';q'
endProcedure phaseMonFor
/*** log function: log a job step from a phase job ********************/
maRecLogJob: procedure expose m.
parse arg dsnPre txt
say 'logging dsn' dsnPre':' txt
ff = dsnAllocWait('MOD dd(LOG)' dsnPre'.LOG', 5)
txt.1 = date(s)':'time() txt
call writeDDBegin log
call writeDD log, 'txt.', 1
call writeDDEnd log
call maRecLogStaAll dsnPre'(STAALL)', txt
interpret subWord(ff, 2)
return 0
endProcedure maRecLogJob
maRecLogStaAll: procedure expose m.
parse arg dsn, jNr jNa step msg
say 'status update in' dsn
say ' job nr' jNr 'name' jNa
say ' step' step 'msg' msg
call readDsn dsn, i.
do y=1 to i.0
if word(i.y, 1) = jNr & word(i.y, 2) = jNa then
leave
end
err = ''
allStates = 'OK WA ER'
oldSta = ''
newSta = ''
if y > i.0 then do
err = 'could not find' jNr jNa 'in' dsn
end
else do
li = i.y
wc = words(li)
if wc < 9 then do
err = 'only' wc 'words in jobline:' li ':line' y 'in' dsn
end
else if wc > 9 then do
oldSta = translate(word(li, min(wc, 11)))
if wordPos(oldSta, allStates 'START RESTART') < 1 then
err = 'bad old state' laWo
end
say 'old state' oldSta 'in line' y':' strip(i.y)
end
if err == '' & msg \= '' then do
newSta = translate(word(msg, words(msg)))
if wordPos(newSta, allStates) < 1 then do
err = 'bad new state' newSta
end
else if oldSta \== '' then do
newSta = word(allStates, max(wordPos(oldSta, allStates),
, wordPos(newSta, allStates)))
end
end
if err \== '' & newSt \= 'ER' then
newSta = 'er'
else if translate(step) = 'REBU' ,
| ( translate(step) = 'RECO' & word(li, 7) = 0) then
newSta = strip(newSta 'ej')
neLi = subword(li, 1, 9) step strip(newSta)
say 'new status:' subword(neLi, 10)
if length(neLi) > 72 then do
neLi = left(neLi, 71-length(newSta)) newSta
err = 'overflow msg' msg
end
if y <= i.0 then do
i.y = neLi
say 'new line: ' neLi
end
if err \== '' then do
z = i.0 + 1
i.z = 'error' err ':line' y 'step' step 'msg' msg
i.0 = z
end
call writeDsn dsn, i.
if err \== '' then
return err(err 'step:' step 'msg:' msg 'at line' y':' li)
return 0
endProcedure maRecLogStaAll
/*** ab hier nur noch copies ******************************************/
/* rexx ****************************************************************
wsh: walter's rexx shell
interfaces:
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.WshSyn
--- history ------------------------------------------------------------------
16. 3.11 w.keller basic new r '' ==> r m.class.classO
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
********/ /*** end of help ********************************************
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
m.wsh.version = 2.1
parse arg spec
if spec = '?' then
return help('wsh version' m.wsh.version)
os = errOS()
isEdit = 0
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
if sysvar('sysISPF') = 'ACTIVE' then
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
if spec = '?' then
return help('version' m.wsh.version)
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & m.editDsn = 'A540769.WK.REXX(WSH)' then
spec = 't'
end
end
call scanIni
f1 = spec
rest = ''
if pos(verify(f1, m.scan.alfNum), '1 2') > 0 then
parse var spec f1 2 rest
u1 = translate(f1)
if u1 = 'T' then
return wshTst(rest)
else if u1 = 'I' then
return wshInter(rest)
else if u1 = 'S' then
spec = '$<.$sqlIn $$begin sqlIn' rest,
'$@sqlIn() $$end sqlIn' rest '$#sqlIn#='
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = s2o('-wsh')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = s2o('-out')
end
end
else if os == 'LINUX' then do
inp = s2o('&in')
out = s2o('&out')
end
else
call err 'implemnt wsh for os' os
call compRun spec, inp, out
if isEdit then
call wshEditEnd
exit 0
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call tstSqlO2
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
return
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
/* if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
*/
ln = max(1, min(ln, la - 37))
say '??? locating' ln
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
call outPush mCut(ggStem, 0)
call errSay ggTxt
call outPop
isComp = 0
if wordPos("pos", m.ggStem.3) > 0 ,
& pos(" in line ", m.ggStem.3) > 0 then do
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
isComp = lin \== ''
end
if isComp then do
m.ggStem.1 = 'compErr:' m.ggStem.1
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
end
else do
m.ggStem.1 = '*** run error' m.ggStem.1
if m.wsh.editOut \== '' then do
do sx=1 to m.ggStem.0
call jWrite m.wsh.editOut, m.ggStem.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, ggStem
end
else do
do sx=1 to m.ggStem.0
say m.ggStem.sx
end
end
end
exit 0
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstScanUtilInto: procedure expose m.
call pipeBeLa '< !DSN.MFUNL.MF03A1P.A009A.PUN'
call in l1
say 'tst l1' strip(m.l1)
if \ scanUtilInto(abc) then
say 'no into found'
else
say 'table' m.abc.tb 'part' m.abc.part 'found'
if in(l1) then
say 'tst lNext' strip(m.l1)
else
say 'tst no more lines'
call pipeEnd
return
endProcedure tstSCanUtilInto
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.scan.alfLC)
c1 = substr(m.scan.alfLC, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jRead(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl, fi1)
nm = substr(m.fi1, lastPos('/', m.fi1)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
if errOS() = 'TSO' then
call tstZos
call tstTut0
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO1
call tstSqlO2
call tstSqls1
call tstSqlO
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*
$=/tstSorQ/
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSorQ/ */
/*
$=/tstSorQAscii/
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSorQAscii/ */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
$/tstMatch/ */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlIni
call jIni
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.sqlInd, :M.STST.B :M.STST.B.sqlInd, :M.+
STST.C :M.STST.C.sqlInd
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
$/tstSql/ */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlOIni
call tst t, "tstSqlO"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call sqlOIni
call tst t, "tstSqlO1"
call sqlConnect dbaf
sq = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen sq, m.j.cRead
call mAdd t.trans, className(m.sq.type) '<tstSqlO1Type>'
do while assNN('ABC', jReadO(sq))
call outO abc
end
call jClose sq
call out '--- writeAll'
call pipeWriteAll sq
call tstEnd t
call sqlDisconnect
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlOIni
call tst t, "tstSqlO2"
call sqlConnect dbaf
call pipeBegin
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe
call sqlSel
call pipeLast
call fmtFWriteAll fmtFreset(abc)
call pipeEnd
call tstEnd t
call sqlDisconnect
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlOIni
call tst t, "tstSqlS1"
call sqlConnect dbaf
s1 = fileSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, fileSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompStmtA
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
$/tstCompPrimary/ */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.-{"abc"}=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.-{""abc""}="$.-{"abc"}'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*
$=/tstCompExprCon/
$/tstCompExprCon/ */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompStmtA: procedure expose m.
call pipeIni
/*
$=/tstCompStmtAssAtt/
### start tst tstCompStmtAssAtt ###################################
compile @, 19 lines: call tstCompStmtAA "begin", "tstAssAtt"
run without input
begin tstAssAtt F1=F1val1 F2= F3= FR=
gugus1
ass1 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=
ass2 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=<oAAR2>
ass2 tstAssAr2 F1=FRF1ass2 F2= F3= FR=
gugus3
ass3 tstAssAtt F1=F1val1 F2=F2ass3 F3=F3ass1 FR=<oAAR2>
ass3 tstAssAr2 F1=FRF1ass2 F2=FrF2ass3 F3= FR=<oAAR3>
ass3 tstAssAr3 F1=r2F1as3 F2=r2F2as3 F3= FR=
*** err: no field falsch in class tstAssAtt in EnvPut(falsch, +
falsch, 1)
$/tstCompStmtAssAtt/
*/
call classNew 'n? tstAssAtt u f F1 v, f F2 v,' ,
'f F3 v, f FR r tstAssAtt'
call envPutO 'tstAssAtt', mNew('tstAssAtt')
call envPut 'tstAssAtt.F1', 'F1val1'
call tstComp1 '@ tstCompStmtAssAtt',
, 'call tstCompStmtAA "begin", "tstAssAtt"',
, '$=tstAssAtt=:¢F2=F2ass1 $$gugus1',
, 'F3=F3ass1',
, '!',
, 'call tstCompStmtAA "ass1", "tstAssAtt"',
, '$=tstAssAtt.FR.F1 = FRF1ass2',
, '$=tstAssAr2 =. ${tstAssAtt.FR}',
, 'call mAdd T.trans, $.$tstAssAr2 "<oAAR2>"',
, 'call tstCompStmtAA "ass2", "tstAssAtt"',
';call tstCompStmtAA "ass2", "tstAssAr2"',
, '$=tstAssAtt=:¢F2=F2ass3 $$gugus3',
, ':/FR/ F2= FrF2ass3',
, 'FR=:¢F1=r2F1as3',
, 'F2=r2F2as3',
, ' * blabla $$ sdf',
, '!',
, '/FR/ !',
, '$=tstAssAr3 =. ${tstAssAtt.FR.FR}',
, 'call mAdd T.trans, $.$tstAssAr3 "<oAAR3>";',
'call tstCompStmtAA "ass3", "tstAssAtt";',
'call tstCompStmtAA "ass3", "tstAssAr2";',
'call tstCompStmtAA "ass3", "tstAssAr3"',
, '$=tstAssAtt=:¢falsch=falsch$!'
/*
$=/tstCompStmtAsSuTy/
### start tst tstCompStmtAsSuTy ###################################
compile @, 4 lines: call tstCompStmtA2 "begin", "tstAsSuTy"
run without input
begin tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GTF1ini1 F2= F3= FR=
as2 tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GtF1ass2 F2=F2ass2 F3= FR=
$/tstCompStmtAsSuTy/
*/
call classNew 'n? tstAsSuTy u f G1 v, f GT tstAssAtt'
call envPutO 'tstAsSuTy', mNew('tstAsSuTy')
call envPut 'tstAsSuTy.G1', 'G1ini1'
call envPut 'tstAsSuTy.GT.F1', 'GTF1ini1'
call tstComp1 '@ tstCompStmtAsSuTy',
, 'call tstCompStmtA2 "begin", "tstAsSuTy"',
, '$=tstAsSuTy.GT =:¢F1= GtF1ass2',
, 'F2= F2ass2 $!',
, 'call tstCompStmtA2 "as2", "tstAsSuTy"'
/*
$=/tstCompStmtAssSt/
### start tst tstCompStmtAssSt ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSt H1=H1ass2 HS.0=1 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSt/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', mNew('tstAssSt')
call oClear envGetO('tstAssSt')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSt', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass2',
, 'HS =<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"',
, ''
/*
$=/tstCompStmtAssSR/
### start tst tstCompStmtAssSR ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASR>.HS class <clSR??> in EnvPut(ts+
tAssSR.HS.1.F1, HS.1.ini0, )
begin tstAssSR H1=H1ini1 HS.0=1 .
_..1 tstAssSR. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSR H1=H1ass2 HS.0=1 .
_..1 tstAssSR. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSR H1=H1ass3 HS.0=3 .
_..1 tstAssSR. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSR. F1= F2= F3= FR=
_..3 tstAssSR. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSR/
*/
cl = classNew('n? tstAssSR u f H1 v, f HS s r tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSR', mNew('tstAssSR')
call oClear envGetO('tstAssSR')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSR.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSR', '',
, "call mAdd t.trans, $.$tstAssSR '<oASR>'",
", m.tstCl '<clSR??>'",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSR.HS.0', 1",
";call envPutO 'tstAssSR.HS.1', ''",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass2',
, 'HS =<<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, ';call tstCompStmtSt "ass2", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSR"',
, ''
/*
$=/tstCompStmtassTb/
### start tst tstCompStmtassTb ####################################
compile @, 19 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
tstR: @tstWriteoV4 isA :<assCla H1>
tstR: .H1 = H1ass2
ass2 tstAssSt H1=H1ini1 HS.0=2 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
_..2 tstAssSt. F1= F2=h3+f2as2 F3=h3+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=f3as3 FR=
$/tstCompStmtassTb/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', mNew('tstAssSt')
call oClear envGetO('tstAssSt')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtassTb', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢ $@|¢ H1 ',
, ' H1ass2 ',
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<assCla H1>'} $!",
, 'HS =<|¢ $*(...',
, '..$*) F2 F3 ',
, ' hs+f2as2 hs+f3as2 ' ,
, ' * kommentaerliiii ' ,
, ' ' ,
, ' h3+f2as2 h3+f3as22222$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
'$=tstAssSt =:¢H1= H1ass3',
, 'HS =<|¢F2 F3',
, ' f2as3' ,
, ' ',
, ' $""',
, ' f3as3 $! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"'
/*
$=/tstCompStmtassInp/
### start tst tstCompStmtassInp ###################################
compile @, 11 lines: .
run without input
tstR: @tstWriteoV2 isA :<cla123>
tstR: .eins = l1v1
tstR: .zwei = l1v2
tstR: .drei = l1v3
tstR: @tstWriteoV3 isA :<cla123>
tstR: .eins = l2v1
tstR: .zwei = l2v2
tstR: .drei = l21v3
*** err: undefined variable oo in envGetO(oo)
oo before 0
oo nachher <oo>
tstR: @tstWriteoV5 isA :<cla123>
tstR: .eins = o1v1
tstR: .zwei = o1v2
tstR: .drei = o1v3
$/tstCompStmtassInp/
*/
call envRemove 'oo'
call tstComp1 '@ tstCompStmtassInp', '',
, "$@|¢eins zwei drei ",
, " l1v1 l1v2 l1v3",
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<cla123>'}" ,
, " l2v1 l2v2 l21v3",
, "!",
, "$$ oo before $.$oo",
, "$; $>.$oo $@|¢eins zwei drei",
, " o1v1 o1v2 o1v3 $!",
, "$; call mAdd 'T.TRANS', $.$oo '<oo>'",
, "$; $$ oo nachher $.$oo $@$oo"
return
endProcedure tstCompStmtA
tstCompStmtAA: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'F1='left(envGet(ggN'.F1'), 8),
'F2='left(envGet(ggN'.F2'), 8),
'F3='left(envGet(ggN'.F3'), 8),
'FR='envGetO(ggN'.FR')
return
endSubroutine
tstCompStmtA2: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'G1='left(envGet(ggN'.G1'), 8)
call tstCompStmtAA '_..GT', ggN'.GT'
return
endSubroutine
tstCompStmtSt: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'H1='left(envGet(ggN'.H1'), 8),
'HS.0='left(envGet(ggN'.HS.0'), 8)
do sx=1 to envGet(ggN'.HS.0')
call tstCompStmtAA '_..'sx, ggN'.HS.'sx
end
return
endSubroutine tstCompStmtSt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 17 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@|
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
*** err: scanErr comp2code bad fr | to | for @|| .
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@|'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<={ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith with $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun()
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call envPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun()', '$@oRun-{}' ,
, ' $@oRun-{$"-{1 arg only}" ''oder?''}' ,
, ' $@oRun.{$".{1 obj only}" ''oder?''} $=v2=zwei' ,
, ' $@oRun-{$"{2 args}", "und" $v2"?"}' ,
, ' $@oRun-{$"{3 args}", $v2, "und drei?"}'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+ abc
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@.<$dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $>.$eins $@for vv $$ <$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>.$eins $@for vv $$ <$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.$eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
$/tstCompDirSrc/ */
/*
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
$/tstCompDir/ */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@pi2()
$#pi2#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#=, 6 lines: +
zeile 1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#="
return
endProcedure tstCompDir
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
call sqlOIni
call sqlConnect dbaf
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fmtFWriteAll fmtFreset(abc)
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 11 lines: call sqlOIni
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
*/
call tstComp2 'tstCompSql', '@'
return
endProcedure tstCompFile
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DBAF
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* -{sysvar(sysnode) date() time()} ts=$ts 10*len=$-{length($ts) * 10}
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out 20101230 14:34:35
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* -{sysvar(sysnode) date() time()} ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DBAF,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DBAF
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out 20101229 13
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DBAF
$@|¢
db ts
DGDB9998 A976
DA540769 A977
!
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DBAF
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , name ts
from sysibm.sysTablespace
where dbName = '$db' and name < 'A978'
order by name desc
fetch first 2 rows only
$!
$| call sqlSel
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out 20101229
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 36 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977A EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976A EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#@
$=subsys = dbaf
$=lst=<:¢
db = DGDB9998
ts =<|¢
ts
A976
A977
!;
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. mNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out 201012
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dbtf
$@|¢ ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fmtFtab
$|
$=jx=0
$@forWith t $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect dbaf
$#out 20101231 11:56:23
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 46 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlOIni
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
call tstComp2 'tstTut04'
call tstComp2 'tstTut05'
call tstComp2 'tstTut07'
return
endProcedure tstTut0
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call tstOGet
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstEnvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile
call tstFileList
call tstFmt
call tstFmtUnits
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=nZwei new 3=nDrei old free fEins nEins new 4=nVier n+
ew
iter nDrei old free fEins nEins new
iter nZwei new
iter nVier new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1, ,
, "if symbol('m.m') \== 'VAR' then m.m = arg(2) 'new';" ,
"else m.m = arg(2) 'old' m.m",
, "m.m = 'free' arg(2) m.m"
t1 = mNew('tst'm1, 'nEins')
t2 = mNew('tst'm1, 'nZwei')
call mFree t1, 'fEins'
t3 = mNew('tst'm1, 'nDrei')
t4 = mNew('tst'm1, 'nVier')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2o2/
### start tst tstClass2 ###########################################
@CLASS.5 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice v union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .2 refTo @CLASS.6 :class = c
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.7 :class = u
. choice u stem 0
. .3 refTo @CLASS.8 :class = c
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.9 :class = c
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .5 refTo @CLASS.10 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.12 :class = r
. choice r .CLASS refTo @CLASS.5 done :class @CLASS.5
. .6 refTo @CLASS.13 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .7 refTo @CLASS.14 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.16 :class = c
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.15 done :class @CLASS.15
. .9 refTo @CLASS.19 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.20 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.11 done :class @CLASS.11
. .10 refTo @CLASS.21 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.20 done :class @CLASS.20
. .11 refTo @CLASS.22 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.23 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.24 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
$/tstClass2o2/
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.84 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2/ */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: bad type v: classBasicNew(v, tstClassTf12, )
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.3
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.3
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: bad type v:' ,
'classBasicNew(v, tstClassTf12, )'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class.classV m.class.classW m.class.classO) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'m.t.class)
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :CLASS.3
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstO/ */
call tst t, 'tstO'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOGet: procedure expose m.
/*
$=/tstOGet/
### start tst tstOGet #############################################
class.NAME= class
class.NAME= class : w
class| = u
*** err: bad stem index 91>7 @ CLASS.4 class class in oGet(CLASS.4,+
. 91)
class.91 = 0
class.1 = CLASS.1 |= u
class.2 = CLASS.5 |= c
$/tstOGet/ */
call oIni
call tst t, 'tstOGet'
cc = m.class.class
call tstOut t, 'class.NAME=' oGet(cc, 'NAME')
o = oGetO(cc, 'NAME')
call tstOut t, 'class.NAME=' o2String(o) ':' className(objClass(o))
call tstOut t, 'class| =' oGet(cc, '|')
call tstOut t, 'class.91 =' className(oGet(cc, 91))
call tstOut t, 'class.1 =' oGetO(cc, '1') '|=' oGet(cc, '1||')
call tstOut t, 'class.2 =' className(oGetO(cc, '2')) ,
'|=' oGet(cc, '2||')
call tstEnd t
/*
$=/tstOGet2/
### start tst tstOGet2 ############################################
tstOGet1 get1 w
tstOGet1.f1 get1.f1 v
tstOGet1.f2 get1.f2 w
tstOGet1.F3| get1.f3 v
tstOGet1.f3.fEins get1.f3.fEins v
tstOGet1.f3.fZwei get1.f3.fZwei w
tstOGet1.f3%fDrei !get1.f3.fDrei w
tstOGet1.f3.fDrei get1.f3.fDrei w
tstOGet1.f3%1 get1.f3.fDrei.1 w
tstOGet1.f3.2 TSTOGET1
tstOGet1.f3.2|f1 get1.f1 v
tstOGet1.f3.2|f3.2|f2 get1.f2 w
*** err: bad stem index 4>3 @ TSTOGET1.F3 class TstOGet0 in oGet(TS+
TOGET1, F3.4)
tstOGet1.f3.4 0
tstOGet1.f3.3 get1.f3.fDrei.3 w
*** err: bad stem index 3>3A @ TSTOGET1.F3 class TstOGet0 in oGet(T+
STOGET1, F3.3)
tstOGet1.f3.2 0
$/tstOGet2/
*/
c0 = classNew('n? TstOGet0 u f FEINS v,f FZWEI w,f FDREI r,v,' ,
's r TstOGet0')
cl = classNew('n? TstOGet u r, f F1 v, f F2 r, f F3 TstOGet0')
call oMutate tstOGet1, cl
m.tstOGet1 = s2o('get1 w')
m.tstOGet1.f1 = 'get1.f1 v'
m.tstOGet1.f2 = s2o('get1.f2 w')
m.tstOGet1.f3 = 'get1.f3 v'
m.tstOGet1.f3.fEins = 'get1.f3.fEins v'
m.tstOGet1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstOGet1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstOGet1.f3.0 = 3
m.tstOGet1.f3.1 = s2o('get1.f3.fDrei.1 w')
m.tstOGet1.f3.2 = tstOGet1
m.tstOGet1.f3.3 = s2o('get1.f3.fDrei.3 w')
call tst t, 'tstOGet2'
call tstOut t, 'tstOGet1 ' oGet(tstOGet1, )
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call tstOut t, 'tstOGet1.f2 ' oGet(tstOGet1, f2)
call tstOut t, 'tstOGet1.F3| ' oGet(tstOGet1, 'F3|')
call tstOut t, 'tstOGet1.f3.fEins ' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3.fZwei ' oGet(tstOGet1, f3.fZwei)
call tstOut t, 'tstOGet1.f3%fDrei ' oGetO(tstOGet1, 'F3%FDREI')
call tstOut t, 'tstOGet1.f3.fDrei ' oGet(tstOGet1, f3.fDrei)
call tstOut t, 'tstOGet1.f3%1 ' oGet(tstOGet1, 'F3%1')
call tstOut t, 'tstOGet1.f3.2 ' oGetO(tstOGet1, 'F3.2')
call tstOut t, 'tstOGet1.f3.2|f1 ' oGet(tstOGet1, 'F3.2|F1')
call tstOut t, 'tstOGet1.f3.2|f3.2|f2' ,
oGet(tstOGet1, 'F3.2|F3.2|F2')
call tstOut t, 'tstOGet1.f3.4 ' oGet(tstOGet1, 'F3.4')
call tstOut t, 'tstOGet1.f3.3 ' oGet(tstOGet1, 'F3.3')
m.tstOGet1.f3.0 = 3a
call tstOut t, 'tstOGet1.f3.2 ' oGet(tstOGet1, 'F3.3')
call tstEnd t
/*
$=/tstOPut3/
### start tst tstOPut3 ############################################
tstOGet1.f1 get1.f1 v
tstOGet1.f1 aPut1 f1.put1
tstOGet1.f2 aPut2 f2.put2
tstOGet1.f3.fEins p3 f3.fEins,p3
tstOGet1.f3%0 3A
tstOGet1.f3%0 =4 4
tstOGet1.f3.4.feins val f3.4|feins
$/tstOPut3/
*/
call tst t, 'tstOPut3'
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call oPut tstOget1, f1, 'f1.put1'
call tstOut t, 'tstOGet1.f1 aPut1' oGet(tstOGet1, f1)
call oPut tstOget1, f2, 'f2.put2'
call tstOut t, 'tstOGet1.f2 aPut2' oGet(tstOGet1, f2)
call oPut tstOget1, f3.fEins, 'f3.fEins,p3'
call tstOut t, 'tstOGet1.f3.fEins p3' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3%0 ' oGet(tstOGet1, 'F3%0')
call oPut tstOget1, f3.0, 4
call tstOut t, 'tstOGet1.f3%0 =4' oGet(tstOGet1, 'F3%0')
call oPutO tstOget1, 'F3.4', ''
call oPut tstOget1, 'F3.4|FEINS', 'val f3.4|feins'
call tstOut t, 'tstOGet1.f3.4.feins' ,
oGet(tstOGet1, 'F3.4|FEINS')
call tstEnd t
return
endProcedure tstOGet
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWOut.jOpen(<obj s of JRWOut>, <)
*** err: jWrite(<obj s of JRWOut>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jOpen s, m.j.cRead
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while assNN('res', jReadO(b))
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while assNN('ccc', jReadO(c))
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipeBeLa m.j.cRead b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa m.j.cRead c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipeBeLa m.j.cRead b0, m.j.cRead b1, m.j.cRead b2,
, m.j.cRead c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa m.j.cRead c1
call pipeWriteNow
call pipeEnd
call pipeBeLa m.j.cRead c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
$/tstEnvVars/ */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
call pipeBeLa '>' envGetO('theBuf', '-b')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa m.j.cRead envGetO('theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
tstEnvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1| get1 w
tstK1%f1 get1.f1 v
tstK1.f2 get1.f2 w
tstK1%F3 get1.f3 v
ttstK1.F3.FEINS get1.f3.fEins v
tstK1%F3%FZWEI get1.f3.fZwei w
tstK1.F3.FDREI !get1.f3.fDrei w
tstK1%F3%FDREI| get1.f3.fDrei w
tstK1.F3.1 get1.f3.1 w
tstK1%F3%2 TSTEW1
tstK1.F3.2|F1 get1.f1 v
tstK1%F3%2|F3.2|F2 get1.f2 w
*** err: undefined variable F1 in envGet(F1)
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3%FDREI !get1.f3.fDrei w
F3%FDREI| get1.f3.fDrei w
F3%1 get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined variable F1 in envGet(F1)
po-1 F1 0
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call envPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1| ' envGet('tstK1|')
call tstOut t, 'tstK1%f1 ' envGet('tstK1%F1')
call tstOut t, 'tstK1.f2 ' envGet('tstK1.F2')
call tstOut t, 'tstK1%F3 ' envGet('tstK1%F3|')
call tstOut t, 'ttstK1.F3.FEINS ' envGet('tstK1.F3.FEINS')
call tstOut t, 'tstK1%F3%FZWEI ' envGet('tstK1%F3%FZWEI')
call tstOut t, 'tstK1.F3.FDREI ' envGetO('tstK1.F3.FDREI')
call tstOut t, 'tstK1%F3%FDREI| ' envGet('tstK1%F3%FDREI')
call tstOut t, 'tstK1.F3.1 ' envGet('tstK1.F3.1')
call tstOut t, 'tstK1%F3%2 ' envGetO('tstK1%F3%2')
call tstOut t, 'tstK1.F3.2|F1 ' envGet('tstK1.F3.2|F1')
call tstOut t, 'tstK1%F3%2|F3.2|F2' ,
envGet('tstK1%F3%2|F3%2|F2')
call tstOut t, 'F1 ' envGet('F1')
call envPushWith tstEW1
call tstOut t, 'F1 ' envGet('F1')
call tstOut t, 'f2 ' envGet('F2')
call tstOut t, 'F3 ' envGet('F3|')
call tstOut t, 'F3.FEINS ' envGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' envGet('F3.FZWEI')
call tstOut t, 'F3%FDREI ' envGetO('F3%FDREI')
call tstOut t, 'F3%FDREI| ' envGet('F3%FDREI|')
call tstOut t, 'F3%1 ' envGet('F3%1')
call tstOut t, 'pu1 F1 ' envGet('F1')
call envPushWith tstEW2
call tstOut t, 'pu2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-1 F1 ' envGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3.F1 = v(c3.f1)
*** err: no reference @ <c3>.F1 class CLASS.1 in envGet(c3.F1.FEINS+
)
. s c3.F1.FEINS = 0
. s c3.F3.FEINS = .
. s c3.F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS @ <c3> class TstEW in envGet(c3.FEINS)
. s c3.FEINS = 0
*** err: null @ <c3> class TstEW in envGet(c3|FEINS)
. s c3|FEINS = 0
aft Put s c3|FEINS = val(c3|FEINS)
Push c3 s F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS aftPuP= pushPut(F3 @ <c3>.F3 class TstEW0 i+
n envGet(F3.FEINS aftPuP= pushPut(F3.FEINS))
. s F3.FEINS aftPuP= 0
push c4 s F1 = v(c4.f1)
put f2 s F2 = put(f2)
*** err: no field F222 in class TstEW in EnvPut(F222, f222 stopped,+
. 1)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3.f1)
*** err: undefined variable F1 in envGet(F1)
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = mNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3.f1)'
call envPutO 'c3', c3
call tstEnvSG , 'c3.F1'
call tstEnvSG , 'c3.F1.FEINS'
call tstEnvSG , 'c3.F3.FEINS'
call envPut 'c3.F3.FEINS', 'val(c3.F3.FEINS)'
call tstEnvSG , 'c3.F3.FEINS'
call tstEnvSG , 'c3.FEINS'
call tstEnvSG , 'c3|FEINS'
call envPut 'c3|FEINS', 'val(c3|FEINS)'
call tstEnvSG 'aft Put', 'c3|FEINS'
call envPushWith c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call envPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG , 'F3.FEINS aftPuP=' envGet('F3.FEINS')
c4 = mNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4.f1)'
call envPut f222, 'f222 no stop'
call envPushWith c4
call tstEnvSG 'push c4', f1
call envPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call envPut f222, 'f222 stopped', 1
call envPut f3.fEins, 'put(f3.fEins)'
call tstEnvSG 'put .. ', f3.fEins
call envPopWith
call tstEnvSG 'popW c4', f1
call envPopWith
call envPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
/*
$=/tstEW4/
### start tst tstEW4 ##############################################
tstO4 S.0 0 R.0 0 class TstEW4
*** err: no field FZWEI in class in EnvPut(FZWEI, v 1.fZwei, 1)
1 fEins s FEINS = v 1.fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1.fEins .# 1 vor
v 1.fEins .# 2 nach withNext e
*** err: undefined variable FEINS in envGet(FEINS)
? fEins s FEINS = 0
1 fEins s FEINS = v 1|fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1|fEins .# 2
$/tstEW4/
*/
c4 = classNew('n? TstEW4 u f S s TstEW0, f R s r TstEW0')
o4 = mReset('tstO4', 'TstEW4')
call tst t, 'tstEW4'
call tstout t, o4 'S.0' m.o4.s.0 'R.0' m.o4.r.0 ,
'class' className(objClass(o4))
call envPushWith o4'.S', m.c4.f2c.s, 'asM'
call envPut fZwei, 'v 1.fZwei', 1
call envWithNext 'b'
call envPut feins, 'v 1.fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
m.o4.s.2.feins = 'vorher'
m.o4.s.2.fZwei = s2o('vorher')
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'vor'
call envWithNext 'e'
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'nach withNext e'
call envPopWith
call tstEnvSG '? fEins ', fEins
call envPushWith o4'.R', m.c4.f2c.r, 'asM'
call envWithNext 'b'
call envPut fEins, 'v 1|fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call envWithNext 'e'
call envPopWith
o41r = m.o4.r.1
call tstOut t, m.o41r.fEins '.#' m.o4.r.0
call tstEnd t
return
endProcedure tstEnvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' envGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen oCast(m, "JBuf"), opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose oCast(m, "JBuf"), opt')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr";' ,
'return jRead(m.m.rdr, var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa m.j.cRead s2o(tstPdsMbr(pd2, 'eins')), m.j.cRead b,
,m.j.cRead jBuf(),
,m.j.cRead s2o(tstPdsMbr(pd2, 'zwei')),
,m.j.cRead s2o(tstPdsMbr(pds, 'wr0')),
,m.j.cRead s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFWriteAll fmtFreset(abc), b
call fmtFAddFlds fmtFReset(abc), oFlds(m.st.1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, b
call tstEnd t
return
endProcedure tstFmt
tstfmtUnits: procedure
/*
$=/tstFmtUnits/
### start tst tstFmtUnits #########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -59s0 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -59s0 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -10m1 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -59m5 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -23h1 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -23h3 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d0 --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d1 --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> ----d --> -9999d
. 863965440 ==> ++++d ++> 10000d -+> ----d --> -----d
. 8.6400E+9 ==> ++++d ++> +++++d -+> ----d --> -----d
. .3 ==> 0.300 ++> 0.300 -+> -0.300 --> -0.300
. .8 ==> 0.800 ++> 0.800 -+> -0.800 --> -0.800
. 1 ==> 1.000 ++> 1.000 -+> -1.000 --> -1.000
. 1.2 ==> 1.200 ++> 1.200 -+> -1.200 --> -1.200
. 59 ==> 59.000 ++> 59.000 -+> -59.000 --> -59.000
. 59.07 ==> 59.070 ++> 59.070 -+> -59.070 --> -59.070
. 59.997 ==> 59.997 ++> 59.997 -+> -59.997 --> -59.997
. 60 ==> 60.000 ++> 60.000 -+> -60.000 --> -60.000
. 60.1 ==> 60.100 ++> 60.100 -+> -60.100 --> -60.100
. 611 ==> 611.000 ++> 611.000 -+> -611.00 --> -611.000
. 3599.4 ==> 3k599 ++> 3k599 -+> -3k599 --> -3k599
. 3599.5 ==> 3k600 ++> 3k600 -+> -3k600 --> -3k600
. 3661 ==> 3k661 ++> 3k661 -+> -3k661 --> -3k661
. 83400 ==> 83k400 ++> 83k400 -+> -83k400 --> -83k400
. 999999.44 ==> 999k999 ++> 999k999 -+> -999k99 --> -999k999
. 999999.5 ==> 1M000 ++> 1M000 -+> -1M000 --> -1M000
. 567.6543E6 ==> 567M654 ++> 567M654 -+> -567M65 --> -567M654
. .9999991E9 ==> 999M999 ++> 999M999 -+> -999M99 --> -999M999
. .9999996E9 ==> 1G000 ++> 1G000 -+> -1G000 --> -1G000
. .9999991E12 ==> 999G999 ++> 999G999 -+> -999G99 --> -999G999
. .9999996E12 ==> 1T000 ++> 1T000 -+> -1T000 --> -1T000
. 567.6543E12 ==> 567T654 ++> 567T654 -+> -567T65 --> -567T654
. .9999991E15 ==> 999T999 ++> 999T999 -+> -999T99 --> -999T999
. .9999996E15 ==> 1P000 ++> 1P000 -+> -1P000 --> -1P000
. .9999991E18 ==> 999P999 ++> 999P999 -+> -999P99 --> -999P999
. .9999996E18 ==> 1E000 ++> 1E000 -+> -1E000 --> -1E000
. 567.6543E18 ==> 567E654 ++> 567E654 -+> -567E65 --> -567E654
. .9999991E21 ==> 999E999 ++> 999E999 -+> -999E99 --> -999E999
. .9999996E21 ==> 1000E ++> 1000E -+> -1000E --> -1000E
. .9999992E24 ==> 999999E ++> 999999E -+> ------E --> -999999E
. .9999995E24 ==> ++++++E ++> 1000000E -+> ------E --> -------E
. 10.6543E24 ==> ++++++E ++> +++++++E -+> ------E --> -------E
$/tstFmtUnits/ */
call jIni
call tst t, "tstFmtUnits"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)
end
lst = subword(lst, 1, 14) 999999.44 999999.5,
567.6543e6 .9999991e9 .9999996e9 .9999991e12 .9999996e12 ,
567.6543e12 .9999991e15 .9999996e15 .9999991e18 .9999996e18 ,
567.6543e18 .9999991e21 .9999996e21 .9999992e24 .9999995e24 ,
10.6543e24
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)
end
call tstEnd t
return
endProcedure tstfmtUnits
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b), m.j.cRead)
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b), '>')
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)), '>')
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa m.j.cRead m, '>' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
return s2o(m.m.in.ix)
end
call tstOut m, '#jIn eof' ix'#'
return ''
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
m.tstErrHandler.0 = 0
call outPush tstErrHandler
call errSay ggTxt
call outPop
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy time begin ---------------------------------------------------*/
timeTest: procedure
numeric digits 32
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
say 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call timeReadCvt 1
say 'tst2jul('t1') ' tst2jul(t1)
say 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
say 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
say 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
say 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
say 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
say 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
say 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
say 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
/* say 'conv2tod('t1')' conv2tod(t1) /* gmt --> stck */
say 'conv2ts('s1')' conv2ts(s1) /* stck --> gmt */
*/ return
endProcedure timeTest
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 32
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutin timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN:
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/* copy time end -----------------------------------------------------*/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFTab: procedure expose m.
call fmtFWriteAll fmtFReset('FMTF.F')
return
endProcedure fmtFTab
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, rdr, wiTi
b = env2buf(rdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(m.st.1)
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, m.st.sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = m.st.sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa */
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo */
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
call compIniKI '=', "skeleton", "expression or block"
call compIniKI '.', "object", "expression or block"
call compIniKI '-', "string", "expression or block"
call compIniKI '@', "shell", "pipe or $;"
call compIniKI ':', "assignAttributes", "assignment or statement"
call compIniKI '|', "assignTable", "header, sfmt or expr"
call compIniKI '#', "text", "literal data"
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@:|'
m.m.chKin2 = '.-=#;:|'
m.m.chKinC = '.-=@'
m.m.chOp = '.-<@|?'
m.m.chOpNoFi = '.-@|?'
return m
endProcedure compReset
compIniKI: procedure expose m.
parse arg ki, m.comp.kind.ki.name, m.comp.kind.ki.expec
return
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
if src \== '' then
m.nn.cmpRdr = o2File(src)
else
m.nn.cmpRdr = ''
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO
cmp = comp(inO)
r = compile(cmp, spec)
if ouO \== '' then
call pipeBeLa '>' ouO
call oRun r
if ouO \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKind) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc m.m.scan, spec
m.m.compSpec = 1
res = compCUnit(m, kind, 1)
do while abbrev(m.m.dir, '$#')
call envPutO substr(m.m.dir, 3, length(m.m.dir)-4),
, compCUnit(m, right(m.m.dir, 1))
end
if \ m.m.compSpec then
call jClose m.m.scan
return res
endProcedure compile
/*--- cUnit = compilation Unit = separate compilations
no nesting| --------------------------------------------*/
compCUnit: procedure expose m.
parse arg m, ki, isFirst
s = m.m.scan
code = ''
do forever
m.m.dir = ''
src = compUnit(m, ki, '$#')
if \ compDirective(m) then
return scanErr(s, m.comp.kind.ki.expec "expected: compile",
m.comp.kind.ki.name "stopped before end of input")
if \ compIsEmpty(m, src) then do
/*wkTst??? allow assTb in separatly compiled units */
if isFirst == 1 & m.src.type == ':' ,
& pos(' ', src) < 1 & abbrev(src, 'COMP.AST.') then
call mAdd src, '', ''
code = code || ';'compAst2code(m, src, ';')
end
if m.m.dir == 'eof' then do
if \ m.m.compSpec | m.m.cmpRdr == '' then
return oRunner(code)
call scanReadReset s, m.m.cmpRdr
call jOpen s, m.j.cRead
m.m.compSpec = 0
end
else if length(m.m.dir) == 3 then
ki = substr(m.m.dir, 3, 1)
else
return oRunner(code)
end
endProcedure compCUnit
/*--- directives divide cUnits ---------------------------------------*/
compDirective: procedure expose m.
parse arg m
m.m.dir = ''
s = m.m.scan
lk = scanLook(s)
cx = pos('#', lk, 3)
if \ abbrev(lk, '$#') then do
if \ scanAtEnd(m.m.scan) then
return 0
m.m.dir = 'eof'
return 1
end
else if scanLit(s, '$#end' , '$#out') then do
m.m.dir = 'eof'
return 1
end
else if pos(substr(lk, 3, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if cx > 3 & pos(substr(lk, cx+1, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, cx+1)
end
else
call scanErr s, 'bad directive:' strip(l)
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan, 'directive mismatch' m.m.dir
return 1
endProcedure compDirective
/**** parse the whole syntax *******************************************
currently, with the old code generation,
parsing and code generation is intermixec
migrating to AST should will separate these tasks
***********************************************************************/
compUnit: procedure expose m.
parse arg m, kind, stopper
s = m.m.scan
if pos(kind, m.m.chKind';') < 1 then
return scanErr(s, 'bad kind' kind 'in compUnit(...'stopper')')
if stopper == '}' then do
if kind \== '#' then do
one = compExpr(m, 'b', translate(kind, ';', '@'))
if compisEmpty(m, one) then
return compAST(m, 'block')
else
return compAST(m, 'block', one)
end
tx = '= '
cb = 1
do forever /* scan nested { ... } pairs */
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
return compAst(m, 'block', tx)
end
else if pos(kind, '.-=') > 0 then do
return compData(m, kind)
end
else if pos(kind, '@;') > 0 then do
call compSpNlComment m
return compShell(m)
end
else if kind == '|' | kind == ':' then do
if kind == '|' then
res = compAssTab(m)
else
res = compAssAtt(m)
if abbrev(res, '#') then
return compAst(m, ':', substr(res, 3))
else
return compAst(m, ';', substr(res, 3))
end
else if kind == '#' then do
res = compAST(m, 'block')
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata until' stopper
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then do
if stopper = '$#' then
leave
call scanErr s, 'eof in heredata until' stopper
end
end
return res
end
endProcedure compUnit
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compAST(m, 'block')
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
a = compAst(m, ';')
m.a.text = ''
do forever
one = compPipe(m)
if one \== '' then
m.a.text = m.a.text || one
if \ scanLit(m.m.scan, '$;') then
return a
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsbw') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock,
, if(type=='w', m.m.chNotWord,m.m.chDol))
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki, 1)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki, withChain
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if withChain then do
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
compObj: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '?')
one = compBlock(m, ki pk)
if one \== '' then
return compAstAddOp(m, one, ki)
pp = ''
if pk \== '' then do
ki = right(pk, 1)
pp = left(pk, length(pk)-1)
end
one = compPrimary(m, translate(ki, '.', '@'), 0)
if one \== '' then
return pp || one
if ki == '.' then do
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKinC) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return pp'. compile(comp(env2Buf()), "'m.s.tok'")'
end
end
call scanBack s, pk
return ''
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compCheckNE(m, compExprBlock(m, '='),
, 'block or expr expected for file')
if \ abbrev(res, '.') then do
end
else if substr(res, verify(res, '.', n), 3) == '0* ' then do
st = word(res, 2)
if m.st.0 = 1 & abbrev(m.st.1, '. envGetO(') then
/* if undefined variable use new jbuf */
if pos(')', m.st.1) == length(m.st.1) then
m.st.1 = left(m.st.1, length(m.st.1)-1) ,
|| ", '-b')"
end
return compASTAddOp(m, res, '<')
endProcedure compFile
/*--- scan an operator chain and a kind ------------------------------*/
compOpKi: procedure expose m.
parse arg m, opt
s = m.m.scan
op = ''
if opt == '<' then do
call scanVerify s, m.m.chOpNoFi
op = m.s.tok
if scanLit(s, '<') then
return op'<'
end
call scanVerify s, m.m.chOp
op = op || m.s.tok
k1 = scanLook(s, 1)
if k1 \== '' & pos(k1, m.m.chKind) > 0 then do
call scanLit s, k1
return op || k1
end
if opt == '?' | op == '' | pos(right(op, 1), m.m.chKind) > 0 then
return op
call scanErr s, 'no kind after ops' op
endProcedure compOpKi
/*--- block or expression --------------------------------------------*/
compExprBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '<')
if right(pk, 1) == '<' then
return compAstAddOp(m, compFile(m), pk)
res = compBlock(m, ki pk)
if res \== '' then
return res
if pk \== '' then
lk = right(pk, 1)
else
lk = translate(ki, '.', '@')
res = compExpr(m, 's', lk)
if res \== '' then
return compASTAddOp(m, res, pk)
call scanBack s, pk
return res
endProcedure compExprBlock
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
res = compAss(m)
if res == '' then
call scanErr s, 'assignment expected after $='
return res
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNE(m, compExprBlock(m, '@'),
, "block or expr expected after $@"))
fu = m.s.tok
if fu == 'for' | fu == 'with' | fu == 'forWith' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m, 'with'),
, "statement after $@for" v))
if fu == 'forWith' then
st = 'call envSetWith envGetO('v');' st
if abbrev(fu, 'for') then
st = 'do while envReadO('v');' st'; end'
if fu == 'forWith' then
st = 'call envPushWith "";' st '; call envPopWith'
else if fu == 'with' then
st = 'call envPushName' v';' st '; call envPopWith'
return ';' st
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
call compSpComment m
suf = compExpr(m, 's', ';')
if \ compIsEmpty(m, suf) then
suf = comp2Code(m, ':'suf)
else if var \== '' then
call scanErr s, "$@do control construct expected"
else
suf = ''
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInter('return' comp2Code(m, '-'nm)), st
return '; '
end
if scanLit(s, '(') then do
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '{', '.{', '-{', '={') then do
br = m.s.tok
a = compExpr(m, 'b', if(br == '{', '-', left(br, 1)))
if \ scanLit(s, '}') then
call scanErr s, 'closing } expected after $@'fu || br
res = '; call oRun envGetO("'fu'")'
if pos(left(a, 1), 'ec') < 1 then
res = res',' comp2code(m, a)
return res
end
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
end
if scanLit(s, '$$') then
return compCheckNN(m, compExprBlock(m, '='),
, 'block or expression expected after $$')
return ''
endProcedure compStmt
compAss: procedure expose m.
parse arg m, aExt
s = m.m.scan
sla = scanLook(s)
slx = verify(sla, m.m.chKind'/'m.m.chOp, 'n')
if slx > 0 then
sla = left(sla, slx-1)
sla = pos('/', sla) > 0
nm = ''
if \ sla then do
nm = compExpr(m, 'b', '=')
if compIsEmpty(m, nm) then
return ''
nm = comp2Code(m, '-'nm)
if \ scanLit(s, "=") then
return scanErr(s, '= expected after $=' nm)
end
m.m.bName = ''
vl = compCheckNE(m, compExprBlock(m, '='),
, 'block or expression after $=' nm '=')
if sla then
if m.m.bName == '' then
call scanErr s, 'missing blockName'
else
nm = "'"m.m.bName"'"
va = compAstAftOp(m, vl)
if va \== '' & m.va.type == ':' then do
pu = "call envPushName" nm
if abbrev(m.m.astOps, '<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else if abbrev(m.m.astOps, '<<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else
call mAdd va, pu ", 'as1'", "call envPopWith"
return va
end
if compAstKind(m, vl) == '-' then
return '; call envPut' nm',' comp2Code(m, vl)aExt
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)aExt
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, dKi ops
s = m.m.scan
if \ scanLit(s, '{', '¢', '/') then
return ''
start = m.s.tok
if (ops \== '' & pos(right(ops, 1), m.m.chKind) < 1) ,
| pos(dKi, m.m.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block (def' dKi')')
if ops == '' then do
ki = dKi
end
else do
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
end
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper) then do
if pos(ki, ':|') < 1 | \ abbrev(stopper, '$') then
call scanErr s, 'ending' stopper 'expected after' starter
else if \ scanLit(s, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'or' substr(stopper, 2),
'expected after' starter
end
if abbrev(starter, '/') then
m.m.bName = substr(starter, 2, length(starter)-2)
else
m.m.bName = ''
if m.res.text == '' then
m.res.text = ' '
return compAstAddOp(m, res, ops)
endProcedure compBlock
compAssAtt: procedure expose m. aClass
parse arg m
res = ''
aClass = ''
s = m.m.scan
last = ''
do forever
if compSpNlComment(m, '*') then do
end
else if pos(scanLook(s, 1), '/!}') > 0 then do
leave
end
else if scanLit(s, ';', '$;') then do
if last = ';' then
res = res'; call envWithNext'
last = ';'
end
else do
s1 = compAss(m, ", 1")
if s1 == '' then do
s1 = compStmt(m)
if s1 == '' then
leave
end
else do
if last == ';' then
res = res'; call envWithNext'
last = 'a'
end
res = res';' comp2code(m, ';'s1)
end
if res == '' then
res = ';'
end
if last == '' then
return res
else
return '# call envWithNext "b";' res ,
'; call envWithNext "e";'
endProcedure compAssAtt
compAssTab: procedure expose m. aClass
parse arg m
s = m.m.scan
call compSpNlComment m, '*'
hy = 0
tab = ''
do forever
bx = m.s.pos
if \ scanName(s) then
leave
hx = hy + 1
h.hx.beg = bx
if hx > 1 & bx <= h.hy.end then
call scanErr s, 'header overlap' m.s.tok 'pos' bx
h.hx = m.s.tok
tab = tab', f' m.s.tok 'v'
h.hx.end = m.s.pos
hy = hx
call compSpComment m, '*'
end
if tab \== '' then
aClass = classNew('n* Ass u' substr(tab, 3))
res = ''
isFirst = 1
do while scanReadNl(s)
do forever
call compSpNlComment m, '*'
s1 = compStmt(m)
if s1 == '' then
leave
res = res';' comp2code(m, ';'s1)
last = 's'
end
if pos(scanLook(s, 1), '/!}') > 0 then
leave
do qx=1
bx = m.s.pos
s1 = compExpr(m, 'w', '=')
if compIsEmpty(m, s1) then
leave
ex = m.s.pos
if ex <= bx then
return scanErr(s, 'colExpr backward')
do hy=1 to hx while bx >= h.hy.end
end
hz = hy+1
if hz <= hx & ex > h.hz.beg then
call scanErr s, 'value on hdr' h.hy 'overlaps' h.hz
else if hy > hx | bx >= h.hy.end | ex <= h.hy.beg then
call scanErr s, 'value from' bx 'to' ex ,
'no overlap with header' h.hy
if qx > 1 then
nop
else if isFirst then do
res = res"; call envWithNext 'b', '"aClass"'"
isFirst = 0
end
else
res = res"; call envWithNext"
res = res"; call envPut '"h.hy"'," comp2Code(m, "-"s1)", 1"
call compSpComment m, '*'
end
end
if isFirst then
return res
else
return '#' res"; call envWithNext 'e'"
endProcedure compassTab
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
sp = 0
co = 0
do forever
if scanVerify(s, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else if xtra == '' then
leave
else if \ scanLit(s, xtra) then
leave
else do
co = 1
m.s.pos = 1+length(m.s.src)
end
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/**** small helper routines ******************************************/
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
if pos(' ', ex) < 1 & pos('COMP.AST.', ex) > 0 then do
a = substr(ex, pos('COMP.AST.', ex))
a = compAstAftOp(m, a)
if m.a.type = 'block' then
return 0 /* m.a.0 == 0 */
else
return m.a.text == ''
end
e1 = word(ex, 1)
return ex = '' | verify(e1, 'ec', 'm') > 0
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Graph ***************************************
goal is to migrate to migrate to old codeGenerator to AST
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, tp
n = mNew('COMP.AST')
m.n.type = tp
if wordPos(tp, 'block') > 0 then do
do cx=1 to arg()-2
m.n.cx = arg(cx+2)
end
m.n.0 = cx-1
end
else do
m.n.text = arg(3)
m.n.0 = 0
end
m.a.isAnnotated = 1
return n
endProcedure compAST
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if ops == '' then
return a
if pos('COMP.AST.', a) < 1 then
return ops || a
if m.a.type = 'ops' then do
m.a.text = ops || m.a.text
return a
end
n = compAst(m, 'ops', ops)
call mAdd n, a
return n
endProcedure compAstAddOp
/*--- return the first AST after the operand chain
put the operands into m.m.astOps ---------------------------*/
compASTaftOp: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return ''
do while m.a.type == 'ops'
m.m.astOps = m.a.text || m.m.astOps
a = m.a.1
end
return a
endProcedure compASTAftOpType
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.type == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
/*--- return the code for an AST with operand chain trg --------------*/
compAst2Code: procedure expose m.
parse arg m, a, aTrg
if pos(' ', a) > 0 | \ abbrev(a, 'COMP.AST.') then
return comp2Code(m, aTrg || a)
if \ abbrev(a, 'COMP.AST.') then
call err 'bad ast' a
do while m.a.type == 'ops'
aTrg = aTrg || m.a.text
a = m.a.1
end
trg = compAstOpsReduce(m, aTrg)
if m.a.type == translate(right(trg, 1), ';', '@') then do
if length(trg) == 1 then do
if pos(trg, ';@') > 0 then
return 'do;' m.a.text ';end'
else
return m.a.text
end
else
return compAST2Code(m, a, left(trg, length(trg)-1))
end
if m.a.type == 'block' then do
op = right(trg, 1)
tLe = left(trg, length(trg)-1)
call compASTAnnBlock m, a
if pos(m.a.maxKind, '.-<') > 0 & pos(op, '.-|?') > 0 then do
if m.a.0 = 1 then do
o1 = if(op=='-', '-', '.')
r = compAst2Code(m, m.a.1, o1)
r = compC2C(m, o1, compAstOpsReduce(m, tLe||o1), r)
if pos(op, '.-<') > 0 then
return '('r')'
else
return r
end
if m.a.0 = 0 & op == '?' then
return compC2C(m, '.', compAstOpsReduce(m, tLe'.'))
if op == '-' then do
cd = ''
do cx = 1 to m.a.0
cd = cd '('compAst2Code(m, m.a.cx, '-')')'
end
return compC2C(m, '-', trg, substr(cd, 2))
end
call scanErr m.m.scan, 'bad block cardinality' aTrg
end
cd = ''
do cx = 1 to m.a.0
cd = cd';' compAst2Code(m, m.a.cx, ';')
end
if right(trg, 1) == '@' then
trg = overlay(';', trg, length(trg))
return compC2C(m, ';', trg, 'do;' cd'; end')
end
else if m.a.type == ';' then do
return compC2C(m, ';', trg, m.a.text)
if right(trg, 1) == '-' then
return compAst2Code(m, "- o2String('"oRunner(m.a.text)"')",
, trg)
if right(trg, 1) == '<' then
return compAst2Code(m, "< o2File('"oRunner(m.a.text)"')",
, trg)
end
else if m.a.type == ':' then do
if m.a.0 = 0 then
call mAdd a, 'call envPushWith', 'call envPopWith'
return compC2C(m, ';', trg,
, 'do;' m.a.1';' m.a.text';' m.a.2'; end')
end
trace ?r
call scanErr m.m.scan, 'implement type' m.a.type 'for' a 'trg' trg
endProcedure compAst2Code
/*--- do a chain of code transformations
from code of kind fr by opList
op as from kind operand
= constant -
- rexx string Expr cast to string/ concat file/output
. rexx object Expr cast to object
< rexx file Expr cast to file
; rexx Statements execute, write obj, Str
@ - cast to ORun, run an obj, write file
| - extract exactlyOne
? - extract OneOrNull
----------------------------------------------------------------------*/
compC2C: procedure expose m.
parse arg m, fr, opList, code
oldCode = fr':' code '==>' opList '==>'
do tx=length(opList) by -1 to 1
to = substr(opList, tx, 1)
if fr == to then
iterate
nn = '||||'
if to == '-' then do
if fr == '=' then
nn = quote(code)
else if abbrev(fr code, '. envGetO(') then
nn = 'envGet(' || substr(code, 9)
else if fr == ';' then
nn = "o2String('"oRunner(code)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("code")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(code))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('code')'
else if fr == '<' then
nn = code
else if fr == ';' then
nn = quote(oRunner(code))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' code
else if fr == '<' then
nn = 'call pipeWriteAll' code
else if fr == ';' then
nn = code
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(code)
else if fr == '-' then
nn = 'call out' code
else if fr == '.' | fr == '<' then
nn = 'call outO' code
end
else if to == ':' then do
if fr == '=' then
nn = quote(code)
else
nn = code
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('code')'
else if fr == '=' then
nn = "file("quote(code)")"
else if fr == '.' then
nn = 'o2File('code')'
else if fr == ';' then
nn = 'o2File('oRunner(code)')'
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then
nn = 'fileSingle('code if(to == '|','', ", ''")')'
else if fr == '@' | fr == ';' then
/* ???wkTst optimize: do it directly */
nn = compC2C(m, fr, to'<', code)
to = '.'
end
if nn == '||||' then
return scanErr(m.m.scan,
,'compC2C bad fr' fr 'to' to 'list' opList)
fr = to
code = nn
end
return code
endProcedure compC2C
/*--- reduce a chain of operands -------------------------------------*/
eliminate duplicates and identity transformations ----------*/
compAstOpsReduce: procedure expose m.
parse arg m, ops
ki = ops
ki = space(translate(ops, ' ', 'e('), 0)
fr = ';<; <;< -.- <@<'
to = '; < - < '
fr = fr '== -- .. << ;; @@ @('
to = to '= - . < ; @ (@'
wc = words(fr)
do until ki = oldKi
oldKi = ki
do wx=1 to wc
do forever
wf = word(fr, wx)
cx = pos(wf, ki)
if cx < 1 then
leave
ki = left(ki, cx-1) || word(to, wx) ,
|| substr(ki, cx+length(wf))
end
end
end
return ki
endProcedure compASTOpsReduce
/*--- annotate a block if necessary ----------------------------------*/
compASTAnnBlock: procedure expose m.
parse arg m, a
if m.a.isAnnotated == 1 then
return
mk = ''
do cx=1 to m.a.0
c = m.a.cx
if pos(' ', c) > 0 | \ abbrev(c, 'COMP.AST.') then
ki = left(c, 1)
else if \ abbrev(c, 'COMP.AST.') then
return scanErr(m.m.scan, 'bad ast' c 'parent' a) /0
else
call scanErr m.m.scan, 'implement kind of' c 'type' m.c.type
if pos(ki, '=-.<;@:|') < 1 then do
if pos(ki, 'el0') < 1 then
call err 'bad kind' ki
end
else if mk == '' | pos(ki, '=-.<;@:|') > pos(mk, '=-.<;@:|') then
mk = ki
end
m.a.maxKind = mk
m.a.isAnnotated = 1
return
endProcedrue compASTAnnBlock
/**** old code generator ***********************************************
plan is to replace it with AST ******************************/
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
if expr == '' & pos(' ', ki) < 1 & pos('COMP.AST.', ki) > 0 then do
cx = pos('COMP.AST.', ki)
return compAst2Code(m, substr(ki, cx), left(ki, cx-1))
end
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 | (to == '*' & fr == '*') then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
toBef = to
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' | fr == '<' then
nn = 'call outO' expr
else if fr == '#' then
nn = 'call envPushWith ;'expr'; call envPopWith'
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then do
nn = 'fileSingle('expr if(to == '|','', ", ''")')'
to = '.'
end
else if fr == '@' | fr == ';' then do
to = to'<'fr
nn = expr
end
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' toBef 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ @( $l $0 @#'
to.2 = '= - . < ; ( (- (. (; < ; @ @ (@ $ $ ;#'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; ;<( <(; @(- @(l |(l ?(l'
to.3 = ' 0; l; - - . . ; ;< <; ;(- ;(l (|l (?l'
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 then do
if trgt == '|' | trgt == '?' then
return left(m.st.1, 1) comp2Code(m, m.st.1)
else if trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
end
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
do forever
cl = scanUtil(sc)
if cl == '' then
return 0
if cl = 'n' & m.sc.tok == 'INTO' then
leave
end
if scanUtil(sc) \== 'n' | m.sc.tok \== 'TABLE' then
call scanErr sc, 'bad into table '
if \ scanSqlQuId(scanSkip(sc)) then
call scanErr sc, 'table name expected'
if m.sc.utilBrackets \== 0 then
call scanErr sc, 'into table in brackets' m.sc.utilBrackets
m.m.tb = m.sc.val
m.m.part = ''
do forever
cl = scanUtil(sc)
if cl == '' then
call scanErr sc, 'eof after into'
if cl == 'n' & m.sc.tok == 'PART' then
if scanUtil(sc) == 'v' then
m.m.part = m.sc.val
else
call scanErr sc, 'bad part'
if cl == 'n' & m.sc.tok == 'WHEN' then do
if scanUtil(sc) \== '(' then
call scanErr sc, '( nach when expected'
do while m.sc.utilBrackets > 0
call scanUtil sc
end
end
if cl == '(' then
leave
end
oX = m.sc.lineX
oL = overlay('', m.sc.src, 1, m.sc.pos-2)
do while m.sc.utilBrackets > 0
call scanUtil sc
if oX \== m.sc.lineX then do
call out strip(oL, 't')
oX = m.sc.lineX
oL = m.sc.src
end
end
call out left(oL, m.sc.pos)
call jClose sc
return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call mapReset env.vars
m.env.with.0 = 0
call mapReset env.c2w
call mNewArea 'ENV.WICO', '='
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
call jOpen m.e.in, m.j.cRead
if m.e.out == '' then
m.e.out = m.j.out
call jOpen m.e.out, m.e.outOp
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, m.j.cRead)
m.f.out = jOpen(Cat(), '>')
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFrame: procedure expose m.
m = oMutate(mBasicNew("PipeFrame"), "PipeFrame")
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = '>'
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
call jClose m.m.in
call jClose m.m.out
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outPush: procedure expose m.
parse arg st
call pipeBeLa '>' oNew('JRWOut', st)
return
endProcedure outPush
outPop: procedure expose m.
call pipeEnd
return
endProcedure outPop
/*--- returnall from rdr (rsp in) to a new jBuf --------------------*/
env2Rdr: procedure expose m.
parse arg rdr
if rdr == '' then
return m.j.in
cl = objClass(rdr, '')
if cl == '' then
return jBuf(rdr)
if classInheritsOf(cl, class4Name('JRW')) then
return r
trace ?r
say cl rdr
return jBuf(o2string(rdr))
endProcedure env2Rdr
envCatLines: procedure expose m.
parse arg rdr, opt
if rdr == '' then
return jCatLines(m.j.in, opt)
cl = objClass(rdr, '')
if cl == '' then
return jCat1(rdr, opt)
if classInheritsOf(cl, class4Name('JRW')) then
return jCatLines(rdr, opt)
return jCat1(o2String(rdr), opt)
endProcedure envCatLines
env2Buf: procedure expose m.
parse arg rdr
if rdr == '' then do
rdr = m.j.in
cl = objClass(rdr, '')
end
else do
cl = objClass(rdr, '')
if cl == '' then
return jBuf(rdr)
if \ classInheritsOf(cl, class4Name('JRW')) then
return jBuf(o2String(rdr))
end
if classInheritsOf(cl, class4Name('JBuf')) & m.rdr.jUsers < 1 then
return rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure env2Buf
envIsDefined: procedure expose m.
parse arg na
return '' \== mapValAdr(env.vars, na)
endProcedure envIsDefined
envPushWith: procedure expose m.
parse arg obj, cl, fn, elCl
tos = m.env.with.0 + 1
m.env.with.0 = tos
m.env.with.tos.fun = fn
m.env.with.tos.muElCl = ''
if fn == '' then do
call envSetWith obj, cl
return
end
if cl == '' then
cl = objClass(obj)
if fn == 'as1' then do
call envSetWith obj, cl
m.env.with.tos.muElRef = m.cl.valueCl \== '',
& m.cl.valueCl \== m.class.classV
if m.env.with.tos.muElRef then
m.env.with.tos.muElCl = m.cl.valueCl
else
m.env.with.tos.muElCl = cl
return
end
else if fn \== 'asM' then
call err 'bad fun' fn
if m.cl.stemCl == '' then
call err 'class' className(cl) 'not stem'
cc = m.cl.stemCl
isRef = m.cc == 'r'
m.env.with.tos.muElRef = isRef
if m.cc \== 'r' then
m.env.with.tos.muElCl = cc
else if elCl \== '' then
m.env.with.tos.muElCl = elCl
else if m.cc.class == '' then
call err 'elCl null for envPushWith('obj ','cl ','multi', ...)'
else
m.env.with.tos.muElCl = m.cc.class
m.env.with.tos.class = ''
m.env.with.tos.muCla = cl
m.env.with.tos.muObj = obj
return
endProcedure envPushWith
envSetWith: procedure expose m.
parse arg obj, cl
if cl == '' & obj \== '' then
cl = objClass(obj)
tos = m.env.with.0
m.env.with.tos = obj
m.env.with.tos.class = cl
return
endProcedure envSetWith
envWithObj: procedure expose m.
tos = m.env.with.0
if tos < 1 then
call err 'no with in envWithObj'
return m.env.with.tos
endProcedure envWithObj
envAccPath: procedure expose m. m cl
parse arg pa, stop, nllNw
nullNew = nllNw == 1
dx = verify(pa, m.class.cPath, 'm')
if dx = 0 then do
n1 = pa
p2 = ''
end
else do
n1 = left(pa, dx-1)
p2 = substr(pa, dx)
end
wCla = ''
do wx = m.env.with.0 by -1 to if(stop==1, m.env.with.0, 1)
wCla = m.env.with.wx.class
if symbol('m.wCla.f2c.n1') == 'VAR' then
return oAccPath(m.env.with.wx, pa, m.env.with.wx.class)
end
if stop == 1 then
return 'no field' n1 'in class' className(wCla)
vv = mapValAdr(env.vars, n1)
if vv \== '' then
if p2 == '' then
return oAccPath(vv, '', m.class.classR)
else
return oAccPath(vv, '|'p2, m.class.classR)
else if nullNew & p2 == '' then
return oAccPath(mapValAdr(env.vars, n1,'a'), p2,m.class.classR)
else
return 'undefined variable' pa
endProcedure envAccPath
envWithNext: procedure expose m.
parse arg beEn, defCl, obj
tos = m.env.with.0
if tos < 1 then
call err 'envWithNext with.0' tos
st = m.env.with.tos.muObj
if beEn == 'b' then do
if m.env.with.tos.fun == 'asM' then
m.st.0 = 0
if m.env.with.tos.muElCl == '' then
m.env.with.tos.muElCl = defCl
end
else if m.env.with.tos.fun == 'asM' then
m.st.0 = m.st.0 + 1
else if m.env.with.tos.fun == '' then
call outO m.env.with.tos
else if beEn = '' then
call err 'no multi allowed'
if beEn == 'e' then
return
if m.env.with.tos.fun == 'as1' then do
if m.env.with.tos == '' then
call err 'implement withNext null'
return
end
/* if obj \== '' then do
if \ m.env.with.tos.muElRef then
call err 'obj but not ref'
m.nn = obj
call envSetWith obj
end
*/
if m.env.with.tos.fun == '' then do
call envSetWith mNew(m.env.with.tos.muElCl)
return
end
nn = st'.' || (m.st.0 + 1)
if m.env.with.tos.muElRef then do
m.nn = mNew(m.env.with.tos.muElCl)
call envSetWith m.nn
end
else do
call mReset nn, m.env.with.tos.muElCl
call envSetWith nn
end
return
endProcedure envWithNext
envPushName: procedure expose m.
parse arg nm, multi, elCl
res = envAccPath(nm, , 1)
if res \== 1 then
return err(res 'in envPushName('nm',' multi')')
do while m.cl == 'r'
if m.m == '' then do
res = oRefSetNew(m, cl)
if res \== 1 then
call err res 'in envPushName('nm',' multi')'
end
m = m.m
cl = objClass(m)
end
call envPushWith m, cl, multi, elCl
return
endProcedure envPushName
envNewWiCo: procedure expose m.
parse arg co, cl
k1 = strip(co cl)
n = mapGet('ENV.C2W', k1, '')
if n \== '' then
return n
k2 = k1
if co \== '' then do
k2 = strip(m.co.classes cl)
n = mapGet('ENV.C2W', k2, '')
end
k3 = k2
if n == '' then do
cx = wordPos(cl, m.co.classes)
if cx > 0 then do
k3 = space(subWord(m.co.classes, 1, cx-1),
subWord(m.co.classes, cx+1) cl, 1)
n = mapGet('ENV.C2W', k3, '')
end
end
if n == '' then
n = envNewWico2(co, k3)
call mapAdd 'ENV.C2W', k1, n
if k2 \== k1 then
call mapPut 'ENV.C2W', k2, n
if k3 \== k2 & k3 \== k1 then
call mapPut 'ENV.C2W', k3, n
return n
endProcedure envNewWiCo
envNewWiCo2: procedure expose m.
parse arg co, clLi
n = mNew('ENV.WICO')
if co == '' then
m.n.level = 1
else
m.n.level = m.co.level + 1
m.n.classes = clLi
na = ''
do cx = 1 to words(clLi)
c1 = word(clLi, cx)
na = na className(c1)
do qx=1 to 2
ff = c1 || word('.FLDS .STMS', qx)
do fx = 1 to m.ff.0
fn = m.ff.fx
if fn == '' then
iterate
fn = substr(fn, 2)
m.n.f2c.fn = cx
end
end
end
m.n.classNames = space(na, 1)
return n
endProcedure envNewWiCo2
envPopWith:procedure expose m.
tos = m.env.with.0
m.env.with.0 = tos - 1
return
endProcedure envPopWith
envGet: procedure expose m.
parse arg na
res = envAccPath(na)
if res == 1 then
res = oAccStr(m, cl)
if res == 1 then
return str
return err(res 'in envGet('na')')
endProcedure envGet
envGetO: procedure expose m.
parse arg na, opt
res = envAccPath(na, , opt == '-b')
if res == 1 then
res = oAccO(m, cl, opt)
if res == 1 then
return ref
return err(res 'in envGetO('na')')
endProcedure envGetO
envPutO: procedure expose m.
parse arg na, ref, stop
res = envAccPath(na, stop, 1)
if res == 1 then
res = ocPutO(m, cl, ref)
if res = 1 then
return ref
return err(res 'in envPutO('na',' ref',' stop')')
endProcedure envPutO
envPut: procedure expose m.
parse arg na, va, stop
res = envAccPath(na, stop , 1)
if res == 1 then
res = ocPut(m, cl, va)
if res == 1 then
return va
return err(res 'in EnvPut('na',' va',' stop')')
endProcedure envPut
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
res = inO()
if res == '' then
return 0
call envPutO na, res
return 1
endProcedure envReadO
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
res = jReadO(m.m.catRd)
if res \== '' then
return res
call catNextRdr m
end
return ''
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
fileSingle: procedure expose m.
parse arg m
call jOpen m, '<'
res = jReadO(m)
two = jReadO(m)
call jClose m
if res == '' then
if arg() < 2 then
call err 'empty file in fileSingle('m')'
else
res = arg(2)
if two \== '' then
call err '2 or more recs in fileSingle('m')'
return res
endProcedure fileSingle
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
call oAdd1Method m.class.classV, 'o2File return file(m.m)'
call oAdd1Method m.class.classW, 'o2File return file(substr(m,2))'
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.class.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class.classV
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.fileTso.buf = m.fileTso.buf + 1
m.m.defDD = 'CAT'm.fileTso.buf
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
m.m.dsn = m.dsnAlloc.dsn
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = mNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
interpret fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, var)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
m.sqlO.cursors = left('', 10, 'r')left('', 30, ' ')
call sqlIni
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
"m.m.fetch = ''; m.m.cursor=''",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
/* call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
*/ return
endProcedure sqlOini
sqlSel: procedure expose m.
parse arg src, type
call pipeWriteAll oNew('SqlSel', envCatLines(src, '-s'), type)
return
endProcedure sqlSel
sqlStmt: procedure expose m.
parse arg src, ggRet
sql = envCatLines(src, '-s')
res = sqlExec(sql, ggRet)
say 'sqlCode' sqlCode 'for' word(sql, 1) sqlErrd.3 'rows'
return res
endProcedure sqlSel
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', envCatLines(src, '-s'), type)
endProcedure sqlRdr
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor(m.m.cursor)
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
if m.m.fetch == '' then
call sqlFetchIni m, 'M.V'
m.m.jReading = 1
return m
endProcedure sqlOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg last
cx = 0
if datatype(last, 'n') & last>0 & last<=length(m.sqlO.cursors) then
if pos(substr(m.sqlo.cursors, last, 1), 'c ') > 0 then
cx = last
if cx == 0 then
cx = pos(' ', m.sqlo.cursors)
if cx == 0 then
cx = pos('c', m.sqlo.cursors)
if cx = 0 then
call err 'no more cursors' m.sqlo.cursors
m.sqlo.cursors = overlay('o', m.sqlo.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if cx < 1 | cx > length(m.sqlo.cursors) then
call err 'bad cursor sqlFreeCursor('cx')'
m.sqlo.cursors = overlay('c', m.sqlo.cursors, cx)
return cx
endProcedure sqlFreeCursor
/*--- create a type for a sqlDA --------------------------------------*/
sqlDA2type: procedure expose m.
parse arg da , ind
endProcedure sqlDA2Type
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchIni: procedure expose m.
parse arg m, pre
da = 'SQL.'m.m.cursor'.D'
if m.m.type = '' | m.m.type == '*' then do
ff = ''
do ix=1 to m.da.sqlD
/* fetch uppercases variable names */
f1 = translate(word(m.da.ix.sqlName, 1))
if f1 == '' | pos(', f' f1 'v', ff) > 0 then
f1 = 'COL'ix
ff = ff', f' f1 'v'
end
m.m.type = classNew('n* SQL u' substr(ff, 3))
end
vv = ''
cn = ''
cl = class4name(m.m.type)
f = cl'.FLDS'
do ix=1 to min(m.f.0, m.da.sqlD)
if translate(m.f.ix) \== m.f.ix then
call err 'fld' ix m.f.ix 'not uppercase for sql'
vv = vv', :'pre || m.f.ix
if m.da.ix.sqlType // 2 = 1 then do
cn = cn'; if' pre || m.f.ix'.'m.sqlInd '< 0 then',
pre || m.f.ix '= "'m.sqlNull'"'
vv = vv' :'pre || m.f.ix'.'m.sqlInd
end
end
m.m.fetch = substr(vv, 3)
m.m.checkNull = substr(cn, 3)
return
endProcedure sqlFetchIni
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
v = mNew(m.m.type)
if \ sqlFetchInto(m.m.cursor, m.m.fetch) then
return ''
interpret m.m.checkNull
return v
endProcedure sqlSelRead
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
delsqlFetch: procedure expose m.
parse arg cx, dst
if \ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
call sqlPushRetOk
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
res = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if res == 0 then
return 1
if res == 100 then
return 0
return res
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return res
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRetOk
return sqlExec("disconnect ", ggRetOk, 1)
endProcedure sqlDisconnect
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCodeWarn()
end
else do
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\n',
|| sqlCodeWarn()
end
signal off syntax
end
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
sqlCodeWarn:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
return 'no warnings'
else
return 'warnings'ggWarn
endProcedure sqlCodeWarn
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, opt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = jCat1(m.line)
if \ abbrev(opt, '-', 1) then
do while jRead(m, line)
res = res || opt || m.line
end
else if opt == '-s' then
do while jRead(m, line)
res = res strip(m.line)
end
else if opt == '-72' then
do while jRead(m, line)
res = res || left(m.line, 72)
end
call jClose m
return res
endProcedure jCatLines
jCat1: procedure expose m.
parse arg v, opt
if \ abbrev(opt, '-', 1) then
return v
if opt == '-s' then
return strip(v)
if opt == '-72' then
return left(v, 72)
call err 'bad opt' opt 'in jCat1('v',' opt')'
endProcedure jCat1
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRWO', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), " ")')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(MARECALI) cre=2009-07-09 mod=2009-07-09-22.08.21 A540769 ---
/* rexx ****************************************************************
tso ex 'DSN.MAREC.exec(alib)'
activate marec loadlibraries
tso ex 'DSN.MAREC.exec(alib)' '-'
tso alib -
switch back altlib to previous loadLibraries
***********************************************************************/
parse arg a1
call errReset 'hI'
say 'macro rc' rc 'arg' arg
address tso "altlib disp"
say 'altlib'
rexxLib = 'DSN.MAREC.EXEC'
if a1 = '-' then do
call adrtso "altlib deact application(exec)"
say 'altlib deactivated'
end
else do
call adrtso "altlib activate application(exec)" ,
"dataset('"rexxLib"') uncond"
say 'altlib activated' rexxLib
end
address tso "altlib disp"
say 'altlib to' rexxLib
exit
signal on syntax name onSyntax
res = marec(a1, a2, a3)
say 'marec returned' res 'altlib deact(exec)'
if 0 then
onSyntax:
do
say '*** syntax on call marec, is it not present?'
res = 12
end
call adrtso "altlib deact application(exec)"
address tso "altlib disp"
say 'exit' res
exit res
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi ^== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na ^== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return ' ' alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(MARECANA) cre=2009-06-29 mod=2011-04-14-14.07.53 A540769 ---
/* REXX ****************************************************************
MARECANA MASSRECOVERY ANALYSE PHASE
***********************************************************************/
PARSE ARG CODE
INTERPRET CODE
ST = 'vcat'
if v.st.0 <> 1 then do
say 'nur ein vcat erlaubt nicht' v.st.0
exit 12
end
CALL RYXA00 v.st.1, SYSVAR(SYSNODE), V.ANAPRE, v.DSNPRE,
, v.REXXLIB, v.SKELS
EXIT 0 /* ------------- PGM END ------------ */
/* REXX ****************************************************************
MASSRECOVERY ANALYSE PHASE
***********************************************************************/
RYXA00: PROCEDURE
PARSE UPPER ARG VCAT, RZX, ANAPRE, DSNPRE, REXXLIB, SKELS
ADDRESS ISPEXEC "VPUT (VCAT ) PROFILE"
ADDRESS ISPEXEC "VPUT (RZX ) PROFILE"
ADDRESS ISPEXEC "VPUT (ANAPRE ) PROFILE"
ADDRESS ISPEXEC "VPUT (DSNPRE ) PROFILE"
ADDRESS ISPEXEC "VPUT (REXXLIB) PROFILE"
ADDRESS ISPEXEC "VPUT (SKELS ) PROFILE"
CALL SUBGENER 'S' /* --- TAYLORING FOR TABLESPACES --- */
CALL SUBGENER 'X' /* --- TAYLORING FOR INDEXSPACES --- */
ADDRESS ISPEXEC
"EDIT DATASET('"anaPre"ANA)') MACRO(RYXEM02)"
RETURN /* ------------- PGM END ------------ */
/* -------------------------------------------------------------- */
/* ------- SUBGENER: PROCESS 1) TS 2) IX SPACE TAXLORING ------- */
/* -------------------------------------------------------------- */
SUBGENER:
PARSE UPPER ARG SPACTYP
/* --- S: TAYLORING FOR TABLESPACES --- */
/* --- X: TAYLORING FOR INDEXSPACES --- */
IF ^(SPACTYP = 'S' | SPACTYP = 'X') THEN EXIT
VCNTL = dsnPre"."SPACTYP".CNTL"
VLIB = dsnPre"."SPACTYP
ADDRESS ISPEXEC "VPUT (VLIB) PROFILE"
/* ---- ALLOC LIBRARY FOR TAYLORED SKELETON MEMBERS ------- */
ADDRESS TSO
"ALLOC DS('"VCNTL"') NEW TRACK SPACE(5,5) DATACLAS(FB0080P0)
DSORG(PO) DIR(20)"
/* ---- COPY, EDIT AND SAVE SKELETONS ------- */
CALL SUBEDIT RYXEL2
CALL SUBEDIT RYXEL4
CALL SUBEDIT RYXEL5
CALL SUBEDIT RYXEL6
CALL SUBEDIT RYXEL7
CALL SUBEDIT RYXEL8
CALL SUBEDIT RYXEL9
CALL SUBEDIT RYXE1
CALL SUBEDIT RYXEM03
IF SPACTYP = 'S' THEN CALL SUBEDIT RYJANATS
IF SPACTYP = 'X' THEN CALL SUBEDIT RYJANAIX
/* ---- FREE LIBRARY FOR TAYLORED SKELETON MEMBERS ------- */
ADDRESS TSO "FREE DS('"VCNTL"')"
RETURN
/* -------------------------------------------------------------- */
/* ------- SUBEDIT: EDIT SKELETON MEMBERS ------- */
/* -------------------------------------------------------------- */
SUBEDIT:
PARSE UPPER ARG MEMBNAM .
parm = EM01
ADDRESS ISPEXEC "VPUT (MEMBNAM ) PROFILE"
ADDRESS ISPEXEC
"EDIT DATASET('"VCNTL"("MEMBNAM")') MACRO(MARECANE) PARM(parm)"
RETURN
}¢--- A540769.WK.REXX(MARECANE) cre=2011-04-14 mod=2011-04-14-14.16.16 A540769 ---
/*REXX ***/
/* -------------------------------------------------------------- */
/* ------- FUNKTION: ------- */
/* -------------------------------------------------------------- */
ADDRESS ISREDIT "MACRO (fun) "
TRACE ?R
say 'marecAnE('fun')'
ADDRESS ISPEXEC "VGET (VCAT) PROFILE"
ADDRESS ISPEXEC "VGET (RZX ) PROFILE"
ADDRESS ISPEXEC "VGET (ANAPRE ) PROFILE"
ADDRESS ISPEXEC "VGET (DSNPRE ) PROFILE"
ADDRESS ISPEXEC "VGET (REXXLIB ) PROFILE"
ADDRESS ISPEXEC "VGET (SKELS ) PROFILE"
ADDRESS ISPEXEC "VGET (VLIB ) PROFILE"
ADDRESS ISPEXEC "VGET (MEMBNAM ) PROFILE"
ADDRESS ISREDIT
if fun == 'EM01' then
call EM01
else
say 'maRecAne bad fun:' fun
exit
em01:
"X ALL"
"DEL ALL X"
"COPY '"skels"("MEMBNAM")' BEFORE .ZFIRST"
"C #VCAT# "VCAT" ALL "
"C #RZX# "RZX" ALL "
"C #LIB# '"LIB"' ALL "
"C #VLIB# '"VLIB"' ALL "
"END "
return
}¢--- A540769.WK.REXX(MARECCFG) cre=2011-04-08 mod=2011-04-08-09.15.53 A540769 ---
/* rexx */
return 'A540769.WK.REXX'
}¢--- A540769.WK.REXX(MARECDDL) cre=2009-10-08 mod=2009-10-08-09.39.13 A540769 ---
-- marec copy table
SET CURRENT SQLID='S100447';
-- drop tablespace $MAREC.$MAREC;
commit;
-- CREATE DATABASE $MAREC
-- BUFFERPOOL BP2
-- INDEXBP BP1
-- CCSID EBCDIC
-- STOGROUP GSMS;
-- commit;
------------------------------------------------------------------------
CREATE TABLESPACE $COPY
IN $MAREC
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
TRACKMOD YES
SEGSIZE 64
BUFFERPOOL BP2
LOCKSIZE ANY
LOCKMAX SYSTEM
CLOSE YES
COMPRESS YES
CCSID EBCDIC
DEFINE YES
MAXROWS 255
; ---------------------------------------------------------------------
CREATE TABLE $MAREC.$COPY
( db char(8) not null
, ts char(8) not null
, pa integer not null
, tst timestamp not null
, typ char(1) not null
, dsN char(44) not null
)
in $MAREC.$COPY
;
create index $MAREC.$ICOPY on $MAREC.$COPY
(db, ts, pa, tst, typ, dsn)
;
commit
;
}¢--- A540769.WK.REXX(MARECJOB) cre=2009-09-03 mod=2015-10-09-14.04.35 A540769 ---
/* rexx ****************************************************************
maRecJob massRecovery Job Generation
* history **************************************************************
17.07.11 JobName und Beta gemäss SchulungsFeedback
*/ /*** end of help ****************************************************
13.04.11 Umstellung auf marec 20, split in cim und marec phase
26.01.10 rebuild mit options event(itemerror skip)
26.01.10 nicht beendeten Kommentar geflickt
30.11.09 space * 1024 (war in kb statt byte)
27.11.09 dsn prefix aus vcat (mehrere) - DBOR ausgebaut
24.11.09 recover/rebuild jobs extract jesOutput to $JOBLIB.JOBOUT(*)
20.11.09 jcl if condition angepasst fuer rebuild abend --> log er
16.11.09 nur 50 datasets pro delete in IDCAMS
13.11.09 für PTA DBOR und spezielle CIM Library eingebaut
3.11.09 stürzt nicht mehr ab bei 0 TS
2.11.09 close und dealloziert files in einem err
2.11.09 fileName mit DSNDBC und DSNDBD werden jetzt analysiert
und DSNDBC deleted
10.10.09 rebuild jobs: höchstens soviele wie spez. für Recover,
mindestens halbe Grösse
* toDo / Ideen *********************************************************
todo:
idcams delete ... cluster noscratch für verlorenen volumes
(hinterlässt Leichen für Extents auf anderen Volumes,
hat storage Management eine bessere Idee?)
FilePräfix DBOF.DSNDBC/D (für Cluster resp. Data)
Nicht zuviele Rebuild Jobs (z.B. mit MaximalZahl)
maRecLog: muss locking machen, besser zuerst auf .log schreiben
Jobs generieren mit richtigem RC Handling:
Rebuild nur wenn Recover ok
JCL999 flickenn und restarten:
Status in staAll rausputzen
Utility Terminieren
(restartet sonst und bemerkt geänderte Listdef nicht)
Wenn ein Objekt nicht recovert werden kann, dann gibt Utility sofort
rc=8/12 und macht nichts
Kann man das mit option skip item ändern
Wollen wir das ändern, oder besser nicht
Was machen wir mit all den Ausnahmen?
objProfile des Techsaves benutzen und obj ausschliessen
Aus syscopy herausfinden was recoverbar ist (langsam und kompl
Ausnahemn nachher organisatorisch behandeln?
Es gibt immer Ausnahmen und Massenfehler/aenderungen,
das Tool muss praktisch dafür sein
und am besten täglich gebraucht werden, damit man Uebung hat
generator fuer MassRecovery
es fehlt noch
* bessere Messung für erwartete RestoreZeit ==> rexx(rcSt)
* index mit Copy
* Lob und XML Spaces
* Unterscheidung primary PartitionierungsIndex und andere
***********************************************************************/
parse arg fun code
call errReset 'hI'
m.debug = 0
call tstIni
call compIni
if 1 then do
say 'maRecJob' fun 'begin'
call envPut 'rexxLib', 'DSN.MAREC.EXEC'
end
else do
say '******* wk.rexx(maRecJob) ************* walter''s test'
call envPut 'rexxLib', 'A540769.WK.REXX'
end
call anaReset g
call setEnvVars code
call dbConn g, envGet(dbSub)
if fun == 'cim' then do
rz = sysvar('sysnode')
call envPut 'rzCim', if(rz = 'RR2', 'RZ23', rz)
call envPut 'sysCim', if(rz = 'RR2', 'R23' , '')
vv = ''
do vx=1 to envGet('vcat.0')
vv = strip(vv envGet('vcat.'vx))
end
m.g.vcats = vv
call pipeBegin '<' s2o('dd(tsDsn)')
call anaDsnList g, 't'
call pipeEnd
call pipeBegin '<' s2o('dd(ixDsn)')
call anaDsnList g, 'i'
call pipeEnd
m.t.0 = 0
call genTsIx g, 'obj'
grp = m.g.group
call grouping grp, g
if \ envHasKey('sys.0') then do
call envPut 'sys.1', 'S'substr(sysvar('SYSNODE'), 3, 1)'1 1'
call envPut 'sys.0', 1
end
call anaSys m.g.sys
call jobCreate m.g.job, grp, m.g.sys
call genDeletes g
end
else if fun == 'maRec' then do
call pipeBegin '<' s2o('dd(obj)')
call anaObjList g
call pipeEnd
call anaSys m.g.sys
grp = m.g.group
call grouping grp, g
kk = mapKeys(grp)
do kx = 1 to m.kk.0 * m.debug
sp = m.kk.kx
say sp m.grp.sp.est 'ts' m.grp.sp 'is' m.grp.sp.is
end
call jobCreate m.g.job, grp, m.g.sys
call verifyCopies g
call compInlineRun 'genJob'
nl = envGet('phaPre')
logAl = dsnAlloc('dd(LOG) new catalog' ,
dsnCreateAtts(nl'.LOG', ':v'))
txt.1 = date(s)':'time() 'job start'
call writeDDBegin log
call writeDD log, 'txt.', 1
call writeDDEnd log
interpret subword(logAl, 2)
call writeDD 'staAll', 'M.'envGetO('buf')'.BUF.'
call writeDsn nl'.jobout(STAALL) ::v',
, 'M.'envGetO('buf')'.BUF.',,1
do jx=1 to m.job.0
d = envGetO('buf'jx)'.BUF'
s3 = right(jx, 3, 0)
call writeDsn nl'(JCL's3')', 'M.'d'.', ,1
call writeDD 'jclAll' , 'M.'d'.', ,1
end
call genStati g
end
else if fun == 'copyTable' then do
call compInlineRun 'copyTable', '=', 'dd(cpTb)'
end
else
call err 'bad fun' fun
call sqlDisconnect
exit 0
compInlineRun: procedure expose m.
parse arg nm, spec, out
if symbol('m.compInline.nm') \== 'VAR' then
m.compInline.nm = compile(comp(jBufWriteStem(jBuf(),
, inlineData(nm))), spec)
if out \== '' then
call pipeBeLa '>' file(out)
call oRun m.compInline.nm
if out \== '' then
call pipeEnd
return 0
endProcedur compInlineRun
setEnvVars: procedure expose m.
parse arg code
interpret code
if m.debug then
call sayVars
do wx=1
v = word(v.vars, wx)
if v == '' then
leave
if right(v, 2) \== '.*' then do
call envPut v, v.v
end
else do
u = left(v, length(v)-2)
do ux = 1 to v.u.0
call envPut u'.'ux, v.u.ux
end
call envPut u'.0', v.u.0
end
end
return
endProcedure setVars
sayVars: procedure expose v.
parse arg st
vars = 'VARS' v.vars
do wx=1 to words(vars)
v = word(vars, wx)
vf = v
if right(v, 2) \== '.*' then do
if length(vf) < 20 then
vf = left(vf, 20)
say vf '=' v.v
end
else do
v = left(v, length(v)-2)
say v'.* ('v.v.0')'
do y=1 to v.v.0
say left(' .'y, 20) '=' v.v.y
end
end
end
return
endProcedure sayVars
inlineData: procedure expose m.
parse arg pName
if pName \== '' & symbol('m.inlineData.named.pName') == 'VAR' then
return m.inlineData.named.pName
if symbol('m.inlineData.0') \== 'VAR' then do
m.inlineData.0 = 0
m.inlineData.lineIx = 0
end
inData = 0
name = ''
do lx = m.inlineData.lineIx+1 to sourceline()
li = left(sourceline(lx), 72)
if inData then do
if abbrev(li, stop) then do
inData = 0
m.act.0 = ax
if pName = name then
leave
end
else do
ax = ax + 1
if opt == ' ' then
m.act.ax = strip(li, 't')
else if opt == '=' then
m.act.ax = li
else if opt == '.' then do
m.act.ax = strip(li, 'b')
if left(m.act.ax) == '.' then
m.act.ax = substr(m.act.ax, 2)
if right(m.act.ax) == '.' then
m.act.ax = left(m.act.ax, length(m.act.ax)-1)
end
end
end
else if abbrev(li, '/*/') then do
cx = pos('/', li, 4)
if cx < 4 then
call err 'after /*/ closing / expected in' ,
'sourceline('lx')' li
name = substr(li, 4, cx-4)
stop = '/'name'/'
opt = substr(li, cx+1, 1)
if pos(opt, ' .=') < 1 then
call err 'bad opt' opt 'in inlineData begin in',
'sourceline('lx')' li
if substr(li, cx+2) /= '' then
call err 'line not empty after inlineData begin in',
'sourceline('lx')' li
ax = m.inlineData.0+1
m.inlineData.0 = ax
m.inlineData.ax = name
act = 'INLINEDATA.'ax
ax = 0
if symbol('m.inlineData.named.name') == 'VAR' then
call err 'duplicate inline data name' name ,
'sourceline('lx')' li
m.inlineData.named.name = act
inData = 1
end
end
if inData then
call err 'inline Data' name 'has no end before eof'
m.inlineData.lineIx = lx
if pName = '' then
return ''
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inlineData named' pName
endProcedure inlineData
fe:
return fmt(arg(1),'e1.1.2')
/*/copyTable/
//Y4MARECD JOB (CP00,KE50),
// 'marec CreLoa',MSGCLASS=E,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CREA EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99 00020001
//SYSTSIN DD *
DSN SYSTEM($DBSUB)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- Database und Hilfstabelle für MAREC Prozedur anlegen
-- (die Database wird nur für die Dauer der Jobgenerierung benötigt,
-- und enthält den Inhalt der SYSCOPY Tabelle )
-- Die Database kann jederzeit gelöscht werden
SET CURRENT SQLID='S100447';
--DROP DATABASE $'$MAREC';
--COMMIT;
CREATE DATABASE $'$MAREC'
BUFFERPOOL BP2
INDEXBP BP1
CCSID EBCDIC
STOGROUP GSMS;
COMMIT;
CREATE TABLESPACE $'$COPY'
IN $'$MAREC'
USING STOGROUP GSMS
PRIQTY -1 SECQTY -1
ERASE NO
FREEPAGE 0 PCTFREE 10
GBPCACHE CHANGED
TRACKMOD YES
SEGSIZE 64
BUFFERPOOL BP2
LOCKSIZE ANY
LOCKMAX SYSTEM
CLOSE YES
COMPRESS YES
CCSID EBCDIC
DEFINE YES
MAXROWS 255
;
CREATE TABLE $'$MAREC'.$'$COPY'
( DB CHAR(8) NOT NULL
, TS CHAR(8) NOT NULL
, PA INTEGER NOT NULL
, TST TIMESTAMP NOT NULL
, TYP CHAR(1) NOT NULL
, DSN CHAR(44) NOT NULL
)
IN $'$MAREC'.$'$COPY'
;
CREATE INDEX $'$MAREC.$ICOPY' ON $'$MAREC.$COPY'
(DB, TS, PA, TST, TYP, DSN)
;
COMMIT
;
//LOAD EXEC PGM=DSNUTILB,PARM='$DBSUB,YMARCPTB.LOAD'
//SYSMAP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSERR DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=$DBSUB.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
EXEC SQL
DECLARE CUR1 CURSOR FOR
SELECT DB, TS, PA, TYP, TST, DSN FROM
(
SELECT '' DB, '' TS, -1 PA,
'' TYP, CURRENT TIMESTAMP TST, '' DSN
FROM SYSIBM.SYSCOPY
UNION ALL
SELECT DBNAME DB, TSNAME TS, DSNUM PA,
ICTYPE TYP, TIMESTAMP TST, DSNAME DSN
FROM SYSIBM.SYSCOPY
WHERE ICTYPE IN ('I', 'F', 'R', 'S', 'W', 'Y')
UNION ALL
SELECT DBNAME DB, TSNAME TS, PARTITION PA,
'c' TYP, CREATEDTS TST, '' DSN
FROM SYSIBM.SYSTABLEPART
) X
ENDEXEC
LOAD DATA INCURSOR CUR1 LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
SORTDEVT DISK SORTNUM 50
WORKDDN(TSYUTS,TSOUTS)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
INTO TABLE $'$MAREC.$COPY'
/copyTable/ */
/*/genJob/
$= j = //
$;
$>}buf $@/allJobs/
$$ = tablespaces indexspaces
$$ = parts bytes secs parts bytes secs
$@do jx=1 to m.job.0 $@/1job/
if length(jx) > 3 then
call err 'job' jx '> 999'
$=j3 =- right(jx, 3, 0)
if m.job.jx.cTS > 0 then
$=jn = YMRCO$j3
else
$=jn = YMRBU$j3
$=sys =- m.job.jx.system
$=dbMbr =- m.job.jx.member
jTs = 'JOB.'jx'.TS'
jIs = 'JOB.'jx'.IS'
$$- $j3 $jn $sys $*+
fe(m.jTs.prt) fe(m.jTs.byt) fe(m.jTs.est) $*+
fe(m.jIs.prt) fe(m.jIs.byt) fe(m.jIs.est)
$;
$>}buf$jx $@/1jobMbr/
$@=/1jobHdr/
//$jn JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,CLASS=P0,SCHENV=$sys
$j****************** jes2 jobCard statt *main |
$j*
$j* mass recovery job $jx
$j* $-¢m.job.jx.0$! object groups
$j* $-¢fe(m.job.jx.cTs) 'tablespaces:' fe(m.jTs.prt) 'parts,' $*+
fe(m.jTs.byt) 'bytes' fe(m.jTs.est) 'secs'$!
$j* $-¢fe(m.job.jx.cIs) 'indexspaces:' fe(m.jIs.prt) 'parts,' $*+
fe(m.jIs.byt) 'bytes' fe(m.jIs.est) 'secs'$!
$j*
//LOG PROC MSG=
//LIB SET LIB=$phaPre
$j* log procedure *****************************
//LOG EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='MAREC L &LIB $j3 $jn &MSG'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=$rexxLib
// PEND
$j* log start *********************************
//LOGSTART EXEC PROC=LOG,MSG='start'
$=nextIf=LOGSTART.LOG.RUN AND LOGSTART.LOG.RC = 0
$=nextI2=$''
$/1jobHdr/
if m.job.jx.cTS > 0 then
$@/recover/
$@=¢
// IF $nextIf
// $nextI2 THEN recover
$j* recover partitions ************************
//SRECO EXEC PGM=DSNUTILB,
// PARM='$dbMbr,$jn.RECOV'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$DBSUB.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF RECOLST
$!
grp = m.g.group
do gx=1 to m.job.jx.0
g1 = m.job.jx.gx
do tx=1 to words(m.grp.g1)
$=ts =- word(m.grp.g1, tx)
pk = m.g.sps'.'$ts
parts = m.pk
do px=1 to words(parts)
$=pa =- word(parts, px)
$@=¢
INCLUDE TABLESPACE $ts PARTLEVEL $pa
$!
end
end
end
$@=¢
OPTIONS EVENT(ITEMERROR SKIP)
RECOVER LIST RECOLST
PARALLEL
$j* log recover end ***************************
// IF ABEND OR (NOT SRECO.RUN)
// OR NOT (SRECO.RC = 0 OR SRECO.RC = 4) THEN
//SRECOER EXEC PROC=LOG,MSG='RECO ER'
// ELSE
// IF SRECO.RC = 0 THEN
//SRECOOK EXEC PROC=LOG,MSG='RECO OK'
// ELSE
//SRECOWA EXEC PROC=LOG,MSG='RECO WA'
// ENDIF
// ENDIF
// ENDIF recover
$=nextIf=(SRECOOK.LOG.RUN AND SRECOOK.LOG.RC=0)
$=nextI2=OR (SRECOWA.LOG.RUN AND SRECOWA.LOG.RC=0)
$!
$/recover/
if m.job.jx.cIS > 0 then
$@/rebuild/
$@=¢
// IF $nextIf
// $nextI2 THEN rebuild
$j* rebuild indexes ***************************
//SREBU EXEC PGM=DSNUTILB,
// PARM='$dbMbr,$jn.REBUI'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$DBSUB.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
OPTIONS EVENT(ITEMERROR SKIP)
LISTDEF REBULST
$!
grp = m.g.group
do gx=1 to m.job.jx.0
g1 = m.job.jx.gx
do tx=1 to words(m.grp.g1.is)
$=is =- word(m.grp.g1.is, tx)
pk = m.g.sps'.'$is
parts = m.pk
do px=1 to words(parts)
$=pa =- word(parts, px)
$@=¢
INCLUDE INDEXSPACE $is PARTLEVEL $pa
$!
end
end
end
$@=¢
REBUILD INDEX LIST REBULST
SORTDEVT SYSDA
SORTNUM 100
WORKDDN(TSYUTD)
$j* log rebuild end ***************************
// IF ABEND OR (NOT SREBU.RUN)
// OR NOT (SREBU.RC = 0 OR SREBU.RC = 4) THEN
//SREBUER EXEC PROC=LOG,MSG='REBU ER'
// ELSE
// IF SREBU.RC = 0 THEN
//SREBUOK EXEC PROC=LOG,MSG='REBU OK'
// ELSE
//SREBUWA EXEC PROC=LOG,MSG='REBU WA'
// ENDIF
// ENDIF
// ENDIF rebuild
$!
$/rebuild/
$@=/extract/
$j* extract joboutput *************************
//EXTRACT EXEC PGM=IKJEFT01,DYNAMNBR=24
//EJESEXT DD DISP=SHR,
// DSN=$phaPre.JOBOUT($jn)
//SYSABEND DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD *
EJES J=$jn,STATUS BATCH
:E
$/extract/
$/1jobMbr/
$/1job/
$/allJobs/
/genJob/ */
/*--- generate STAnnn members ----------------------------------------*/
genStati: procedure expose m.
parse arg g
j = m.g.job
grp = m.g.group
lib = envGet('phaPre')
mp = m.g.map
call mCut buf, 0
do jx=1 to m.j.0
call mCut buf, 0
do gx=1 to m.j.jx.0
g1 = m.j.jx.gx
do tx=1 to words(m.grp.g1)
ts = word(m.grp.g1, tx)
k = m.g.sps'.'ts
parts = m.k
k = mp'.'ts
do px=1 to words(parts)
pa = word(parts, px)
p1 = max(1, pa)
call statiAdd buf, jx, 'ts', ts, pa, m.k.p1.space
end
end
do tx=1 to words(m.grp.g1.is)
ix = word(m.grp.g1.is, tx)
k = m.g.sps'.'ix
parts = m.k
k = mp'.'ix
do px=1 to words(parts)
pa = word(parts, px)
p1 = max(1, pa)
call statiAdd buf, jx, 'ix', ix, pa, m.k.p1.space
end
end
end
call writeDsn lib'(STA'right(jx, 3, 0)')', 'M.BUF.', , 1
end
return
endProcedure genStati
statiAdd: procedure expose m.
parse arg b, jx, ty, sp, pa, by
ee = envGet('est.'ty'.part') + by * envGet('est.'ty'.byte')
li = ty left(sp':'pa , 30) fmt(by, 'e') fmt(ee, 'e')
call mAdd b, li
return
endProcedure statiAdd
genJobcards: procedure expose m.
parse arg jobNa, sys
call out '//'jobNa 'JOB (CP00,KE50),'
call out '// 'MassRecovery',MSGCLASS=E,TIME=1440,'
call out '// NOTIFY=&SYSUID,REGION=0M'
call out '//*MAIN CLASS=LOG'copies(' **',sys='')',SYSTEM='sys
return
endProcedure genJobcards
genDeletes: procedure expose m.
parse arg m
call envPut 'mm', m
call compInlineRun 'genDelete1', , 'dd(cim)'
call compInlineRun 'genDelete2', , 'dd(cim2)'
return
/*/genDelete1/
$#=
$@¢
$= j = //
call genJobCards 'Y4MARECC', $sysCim
$!
$j************** stop spaces ************************************
//STOP EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($DBSUB)
$@¢
mm = $mm
g = m.mm.group
j = m.mm.job
s = m.mm.sps
do jx=1 to m.j.0
do gx=1 to m.j.jx.0
g1 = m.j.jx.gx
spaces = m.g.g1.ts m.g.g1.is
do sx=1 to words(spaces)
parse value word(spaces, sx) with d1 '.' s1
$$- ' -STO DB('d1') SPACENAM('s1')'
end
end
end
$!
$j************** delete datasets ********************************
//SDEL EXEC PGM=IDCAMS
//SYSPRINT DD SYSOUT=*
//CEEDUMP DD SYSOUT=*
//SYSABEND DD SYSOUT=*
//SYSIN DD *
$= delBeg == DELETE ( -
$= delEnd == ) CLUSTER NOSCRATCH
$= delCnt =- 0
$delBeg
$@¢
mm = $mm
g = m.mm.group
j = m.mm.job
s = m.mm.sps
do jx=1 to m.j.0
do gx=1 to m.j.jx.0
g1 = m.j.jx.gx
spaces = m.g.g1.ts m.g.g1.is
do sx=1 to words(spaces)
parse value word(spaces, sx) with d1 '.' s1
dk = m.mm.dss'.'d1'.'s1
dsLst = m.dk
do px=1 to words(dsLst)
dsn = word(dsLst, px)
cx = pos('.DSNDBD', dsn)
if cx > 0 then
dsn = overlay('C', dsn, cx+6)
$= delCnt =- $delCnt + 1
if $delCnt // 50 = 0 then $@=¢
$delEnd
$delBeg
$!
$$- ' ' dsn '-'
end
end
end
end
$!
$delEnd
$j************** start spaces ***********************************
//START EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($DBSUB)
$@¢
mm = $mm
g = m.mm.group
j = m.mm.job
s = m.mm.sps
do jx=1 to m.j.0
do gx=1 to m.j.jx.0
g1 = m.j.jx.gx
spaces = m.g.g1.ts m.g.g1.is
do sx=1 to words(spaces)
parse value word(spaces, sx) with d1 '.' s1
$$- ' -STA DB('d1') SPACENAM('s1')'
end
end
end
$!
$j************** find uncataloged extents ***********************
$j************** delete these later with job delete2 ************
$j********************************************************************
$j* CIM 1.6.8 JOBSTREAM GENERATED BY ISPF FUNCTION: 5.1 *
$j* USERID=B370215 DATE=2009.10.01 TIME=16:10:18.28 *
$j********************************************************************
//SCIM EXEC PGM=CIMMAIN,REGION=4M
//STEPLIB DD DSN=CIM#A.$rzCim.P0.LOAD,DISP=SHR
//SYSPRINT DD SYSOUT=*
//CIMOUT DD DISP=SHR,
// DSN=$cimDe
$j*------------------------------------------------------------------*
$j* GENERATE DELETE FOR NON CATALOGED DASD DATASETS *
$j*------------------------------------------------------------------*
//SYSIN DD *
DIAGNOSE VVDS
TYPE=NONCATALOGED
ACTION=GENERATE_DELETE
SG=$smsSG
DSN=**
/genDelete1/ */
/*/genDelete2/
$#@
$= j = //
call genJobCards 'Y4MARECC'
$#=
$j************** delete uncataloged extents *********************
$j************** found in last job delete1 *********************
//DEL EXEC PGM=IKJEFT01,REGION=4M,DYNAMNBR=100
//SYSPRINT DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
$j*------------------------------------------------------------------*
$j* EXECUTE DELETE STATEMENTS FROM SYSIN *
$j*------------------------------------------------------------------*
//SYSTSIN DD *
PROFILE NOPREFIX
// DD DISP=SHR,
// DSN=$cimDe
/genDelete2/ */
endProcedure genDeletes
genDeletesOld: procedure expose m.
parse arg m
g = m.m.group
j = m.m.job
s = m.m.sps
call mCut d, 0
call mCut a, 0
call mCut o, 0
call mAdd d, '//YMRDELET JOB (CP00,KE50),' ,
, '// 'CATALOG',MSGCLASS=T,TIME=1440,' ,
, '// NOTIFY=&SYSUID,REGION=0M' ,
, '//*MAIN CLASS=LOG *SYSTEM=$sys' ,
, '//SDEL EXEC PGM=IDCAMS' ,
, '//SYSPRINT DD SYSOUT=*' ,
, '//CEEDUMP DD SYSOUT=*' ,
, '//SYSABEND DD SYSOUT=*' ,
, '//SYSIN DD *' ,
, ' DELETE ( -'
call mAdd a, overlay('//YMRSTART', m.d.1), m.d.2, m.d.3, m.d.4,
, '//S EXEC PGM=IKJEFT01' ,
, '//SYSTSPRT DD SYSOUT=*' ,
, '//SYSPRINT DD SYSOUT=*' ,
, '//SYSTSIN DD *' ,
, ' DSN SYS('envGet(dbSub)')'
call mAddSt o, a
m.o.1 = overlay('//YMRSTOPP', m.o.1)
do jx=1 to m.j.0
do gx=1 to m.j.jx.0
g1 = m.j.jx.gx
spaces = m.g.g1.ts m.g.g1.is
do sx=1 to words(spaces)
parse value word(spaces, sx) with d1 '.' s1
call mAdd a, ' -STA DB('d1') SPACENAM('s1')'
call mAdd o, ' -STO DB('d1') SPACENAM('s1')'
dk = m.m.dss'.'d1'.'s1
dsLst = m.dk
do px=1 to words(dsLst)
dsn = word(dsLst, px)
cx = pos('.DSNDBD', dsn)
if cx > 0 then
dsn = overlay('C', dsn, cx+6)
call mAdd d, ' ' dsn '-'
end
end
end
end
call mAdd d, ' ) CLUSTER NOSCRATCH'
call writeDsn envGet('JOBLIB')'(DELETE)', 'M.D.', , 1
call writeDsn envGet('JOBLIB')'(DBSTART)', 'M.A.', , 1
call writeDsn envGet('JOBLIB')'(DBSTOP)', 'M.O.', , 1
return
endProcedure genDeletesOld
verifyCopies: procedure expose m.
parse arg m
g = m.m.group
j = m.m.job
s = m.m.sps
do jx=1 to m.j.0
wh = ''
do gx=1 to m.j.jx.0
g1 = m.j.jx.gx
do tx=1 to words(m.g.g1)
parse value word(m.g.g1, tx) with d '.' t
wh = wh "or (db = '"d"' and ts = '"t"' and pa in (" ,
|| translate(space(m.s.d.t, 1), ",", " ")"))"
end
end
if wh \== '' then
call genCopies right(jx, 3, 0), substr(wh, 5)
end
call genCopiesEnd
return
endProcedure verifyCopies
genCopies: procedure expose m.
parse arg jNo, wh
if m.genCopies \== 1 then do
m.genCopies = 1
call mCut recSt, 0
call mCut reCop, 0
m.frRecSt = dsnAlloc(envGet('phaPre')'(recSt) dd(recSt)')
m.frReCop = dsnAlloc(envGet('phaPre')'(recop) dd(reCop)')
m.genCopiesTb = '$MAREC.$COPY'
if 0 then do /* alte version */
m.genCopiesTb = 'SESSION.COPY'
call sqlExImm ,
'declare global temporary table session.copy' ,
'( db char(8) not null',
', ts char(8) not null',
', pa integer not null',
', typ char(1) not null',
', tst timestamp not null',
', dsName char(44) not null',
')'
call sqlExImm ,
'create index session.iCopy on session.copy' ,
'(db, ts, pa, tst, typ)'
call sqlExec ,
"insert into session.copy" ,
"select * from" ,
"(" ,
"select dbName db, tsName ts, dsNum pa," ,
"icType typ, timestamp, dsName" ,
"from sysibm.sysCopy" ,
"where icType in ('I', 'F', 'R', 'S', 'W', 'Y')" ,
"union select dbName db, tsName ts, partition pa," ,
"'c' typ, createdTS, ''" ,
"from sysibm.sysTablePart" ,
") x where" wh
end
end
else do
if 0 then do /* alte version */
call sqlExec 'delete from session.copy'
end
end
/* call mCut reJo, 0
frReJo = dsnAlloc(envget('JOBLIB')'(REC'jNo') dd(reJo)') */
call sqlPreOpen 1 , ,
"with recSta as" ,
"( select c.*" ,
"from" m.genCopiesTb "c" ,
"where c.tst >=" ,
"( select max(a.tst)" ,
"from" m.genCopiesTb "a" ,
"where c.db = a.db and c.ts = a.ts" ,
"and c.pa = a.pa" ,
"and typ in ('c', 'F', 'R', 'S', 'W', 'Y')",
")" ,
")" ,
"select db, ts, pa, tst, typ, dsn from recSta" ,
"where" wh ,
"order by db, ts, pa, tst"
vars = ':db, :ts, :pa, :tst, :typ, :dsn'
call mAdd recSt, '*job' jNo
do cx=0 while sqlFetchInto(1, vars)
new = strip(db) strip(ts) strip(pa)
if new \== last then do
call mAdd recSt, new typ tst
last = new
end
if pos(typ, 'FI') > 0 then
call mAdd reCop, dsn
if m.reCop.0 > 100 then do
call writeDD recop, 'M.RECOP.'
call mCut recop, 0
if m.recSt.0 > 100 then do
call writeDD recSt, 'M.RECST.'
call mCut recSt, 0
end
end
end
call sqlClose 1
return
endProcedure genCopies
genCopiesEnd: procedure expose m.
parse arg mbr, wh
if m.genCopies \== 1 then
return
m.genCopies = 0
call writeDD recop, 'M.RECOP.'
call writeDDEnd recop
interpret subword(m.frReCop, 2)
call writeDD recSt, 'M.RECST.'
call writeDDEnd recSt
interpret subword(m.frRecSt, 2)
call sqlExec 'rollback'
return
endProcedure genCopiesEnd
tstRcGen: procedure expose m.
say 'start rcGen'
/* estimation of restore in seconds for ts */
call envIni
call errReset 'hI'
if sysVar('sysISPF') == 'ACTIVE' then
call adrEdit 'macro (arg)', '*'
call anaReset td, 'DBZF'
if 0 then do
call tstDbs td, 'A%'
end
else if 1 then do
call pipeBegin '<' jBuf( ,
DBZF.DSNDBC.DGDB9998.A600A000.I0001.A003 ,
, DBZF.DSNDBC.DGDB9998.A600A000.I0001.A006 )
call anaDsnList td, 't'
call pipeEnd
call pipeBegin '<' jBuf( ,
DBZF.DSNDBC.DGDB9998.IWK61AZG.I0001.A001 ,
, DBZF.DSNDBC.DGDB9998.IWK61QGV.I0001.A001 )
call anaDsnList td, 'i'
call pipeEnd
end
call grouping m.td.group, td
kk = mapKeys(m.td.group)
grp = m.td.group
do kx = 1 to -m.kk.0
sp = m.kk.kx
say sp m.grp.sp.est 'ts' m.grp.sp 'ix' m.grp.sp.is
end
call jobCreate m.td.job, m.td.group, td, r12 12
exit
m.a.typ = 't'
m.a.map = 'DS'
call mapReset m.a.map, 'K'
call anaDsn a, DBZF.DSNDBC.DGDB9998.A600A000.I0001.A001
call anaDsn a, DBAF.DSNDBC.DGDB9998.A225A.I0001.A001
call anaDsn a, DBZF.DSNDBC.DGDB9998.A600A000.I0001.A005
call anaDsn a, DBAF.DSNDBC.WI02A1A.A103H004.J0001.A004
call anaDsn a, DBAF.DSNDBC.NZ01A1A.A092A.I0001.A008
m.a.typ = 'i'
call anaDsn a, DBZF.DSNDBC.DGDB9998.IWK61EM0.I0001.A001
k = mapKeys(m.a.map)
do y=1 to m.k.0
b = m.a.map'.'m.k.y
say m.b m.k.y 'su' m.b.dbSub 'ts' m.b.ts 'ix' m.b.ix 'is' m.b.iss,
'part' m.b.part'/'m.b.toPa 'space' m.b.space 'iPr' m.b.iPr
end
call sqlDisconnect
return
endProcedure tstRcGen
/*--- make ts and ix lists ------------------------------------------*/
genTsIx: procedure expose m.
parse arg ob, dd
m.genTsIx.0 = 0
mp = m.ob.map
spM = m.ob.sps
spK = mapKeys(spM)
do spX=1 to m.spK.0
sp = m.spK.spX
prts = m.spM.sp
li = ''
fr = ''
la = ''
do forever
cu = 'ffff'x
do wx=1 to words(prts)
w1 = word(prts, wx)
if w1 > la & w1 < cu then
cu = w1
end
if cu \== 'ffff'x then do
if cu-1 = la then do
la = cu
iterate
end
end
if fr \== '' then
if fr = la then
li = li','fr
else
li = li','fr'-'la
if cu == 'ffff'x then
leave
la = cu
fr = cu
end
pas = m.mp.sp.toPa
if li=='' then
call err 'empty part list' li 'prts' prts 'for' sp
ty = m.mp.sp
if ty == 't' then
txt = 'ts' m.mp.sp.ts substr(li, 2)
else if ty == 'i' then
txt = 'is' m.mp.sp.is substr(li, 2)
else
call err 'bad type' ty 'in' sp
call mAdd genTsIx, txt
end
call writeDD dd, 'M.GENTSIX.'
call writeDDEnd dd
return
endProcedure genTsIx
/*--- group indexes with their TS and compute estimate --------------*/
grouping: procedure expose m.
parse arg gr, ob
call mapReset gr, 'K'
mp = m.ob.map
spM = m.ob.sps
spK = mapKeys(spM)
do spX=1 to m.spK.0
sp = m.spK.spX
prts = m.spM.sp
if m.mp.sp == 't' then do
gs = groupAdd(gr, sp, sp)
ty = gs'.TS'
ev = 'est.ts'
end
else if m.mp.sp == 'i' then do
gs = groupAdd(gr, m.mp.sp.ts, , sp)
ty = gs'.IS'
ev = 'est.ix'
end
else do
call err 'bad type' m.mp.sp 'for obj' sp
end
m.ty.prt = m.ty.prt + words(prts)
do px=1 to words(prts)
pa = max(1, word(prts, px))
m.ty.byt = m.ty.byt + m.mp.sp.pa.space
end
m.ty.est = envGet(ev'.const'),
+ m.ty.prt * envGet(ev'.part'),
+ m.ty.byt * envGet(ev'.byte')
m.gs.est = m.gs.ts.est + m.gs.is.est
end
return
endProcedure grouping
groupAdd: procedure expose m.
parse arg gr, ky, sp, ind
if mapHasKey(gr, ky) then do
if sp \== '' then
m.gr.ky = m.gr.ky sp
end
else do
call mapAdd gr, ky, sp
m.gr.ky.est = 0
m.gr.ky.is = ''
m.gr.ky.ts = ''
m.gr.ky.is.prt = 0
m.gr.ky.is.byt = 0
m.gr.ky.is.est = 0
m.gr.ky.ts.prt = 0
m.gr.ky.ts.byt = 0
m.gr.ky.ts.est = 0
end
if sp \== '' then
m.gr.ky.ts = m.gr.ky.ts sp
if ind \== '' then
m.gr.ky.is = m.gr.ky.is ind
return gr'.'ky
endProcedure groupAdd
/*--- create jobs and distribute groups to the jobs ----------------*/
jobCreate: procedure expose m.
parse arg j, grp, sys
cnt = 0
/* shuffle systems on jobs, such that the biggest job get
uniformly distriuted on the systems */
m.j.j1 = m.sys
do sx=1 to m.sys.0
cc.sx = 0
end
do forever
mi = 9
do sx=1 to m.sys.0
if cc.sx+1 <= m.sys.sx.jobs then
mi = min(mi, (cc.sx+.5) / m.sys.sx.jobs)
end
if mi > 1 then
leave
do sx=1 to m.sys.0
if cc.sx+1 <= m.sys.sx.jobs then
if mi >= (cc.sx+.5) / m.sys.sx.jobs then do
cnt = cnt+1
cc.sx = cc.sx + 1
call jobReset j, cnt, m.sys.sx, m.sys.sx.member
end
end
end
if m.sys \= cnt then
call err cnt 'jobs <>' m.sys
call mapReset j'.'map, 'K'
grK = mapKeys(grp)
call sort grK, j'.'sort,
, "bLe = '"grp".'m.aLe; bRi = '"grp".'m.aRi;" ,
"cmp = m.bLe.est >= m.bRi.est"
/* erste Runde: verteile TS-Gruppen,
immer die grösste in den kleinsten Job */
js = 0
m.j.0 = 0
toSp = 0
do cx=1 to m.j.sort.0
sp = m.j.sort.cx
toSp = toSp + m.grp.sp.est
if m.grp.sp == '' then
iterate
js = jobSmallest(j, 1, m.sys)
call jobAddGroup j'.'js, grp'.'sp, sp
end
/* zweite Runde: verteile ix-only Gruppen
in max m.sys minimaler Groesse */
spLim = toSp / m.sys * .5
jSta = js + 1
jLim = js + m.sys
js = 1
do cx=1 to m.j.sort.0
sp = m.j.sort.cx
if m.grp.sp \== '' then
iterate
if m.j.0 < jSta | m.j.js + m.grp.sp.est > spLim then
js = jobSmallest(j, jSta, jLim)
call jobAddGroup j'.'js, grp'.'sp, sp
end
/* dritte Runde: nichts vergessen? */
cJJ = 0
do qx = 1 to m.j.0
ox = qx
do ax=1 to m.j.ox.0
cJJ = cJJ + 1
sp = m.j.ox.ax
if \ mapHasKey(grp, sp) then
call err 'not in map' sp
if m.j.tst.sp == 1 then
call err 'already marked' sp
m.j.tst.sp = 1
end
end
say 'jobCreate' cJJ 'from' m.grK.0 'objs'
if cJJ <> m.grK.0 then
call err 'jobCreate' cJJ 'from' m.grK.0 'objs'
return
endProcedure jobCreate
/*--- return the smallest job between fr and tx
initialize (reset) it if not already done ---------------------*/
jobSmallest: procedure expose m.
parse arg j, fr, tx
if m.j.0 < tx then do
jx = m.j.0 + 1
end
else do
miSp = m.j.fr
jx = fr
do ax=fr+1 to min(tx, m.j.0)
if m.j.ax < miSp then do
miSp = m.j.ax
jx = ax
end
end
end
if jx < fr | jx > tx then
call err 'bad jx' jx 'for' fr '-' tx
if jx > m.j.0 then do
if jx \= m.j.0 + 1 then
call err 'bad jx' jx 'for' m.j.0
m.j.0 = jx
call jobReset j, jx
end
return jx
endProcedure jobSmallest
/*--- add group g to job jand member is passed as parm
or copied from job -j1 ------------------------*/
jobAddGroup: procedure expose m.
parse arg j, g, sp
m.j = m.j + m.g.est
call mAdd j, sp
m.j.cTs = m.j.cTS + words(m.g) /* wkTst??? err m.g.ts */
m.j.cIs = m.j.cIs + words(m.g.is)
m.j.ts.prt = m.j.ts.prt + m.g.ts.prt
m.j.ts.byt = m.j.ts.byt + m.g.ts.byt
m.j.ts.est = m.j.ts.est + m.g.ts.est
m.j.is.prt = m.j.is.prt + m.g.is.prt
m.j.is.byt = m.j.is.byt + m.g.is.byt
m.j.is.est = m.j.is.est + m.g.is.est
return
endProcedure jobAddGroup
/*--- initialize job, sys and member is passed as parm
or copied from job -j1 ------------------------*/
jobReset: procedure expose m.
parse arg job, jx, sys, mbr
if sys == '' then do
if jx <= m.job.j1 then
return
fx = jx - m.job.j1
sys = m.job.fx.system
mbr = m.job.fx.member
end
j = job'.'jx
m.j.system = sys
m.j.member = mbr
m.j = 0
m.j.0 = 0
m.j.cTs = 0
m.j.cIs = 0
m.j.ts.prt = 0
m.j.ts.byt = 0
m.j.ts.est = 0
m.j.is.prt = 0
m.j.is.byt = 0
m.j.is.est = 0
return
endProcedure jobReset
tstDbs: procedure expose m.
parse arg td, pDb
say 'tstDbs' m.dbSub pDb
call sqlPreAllCl 49, 'select strip(Name)' ,
'from sysibm.sysDatabase',
'where name like '''pDb'''',
'order by name',
, 'ST', ':M.ST.SX.db'
say 'tstDbs' m.dbSub pDb':' m.st.0 'dbs'
do sx=1 to min(m.st.0 2e0 )
call tstDb td, m.st.sx.db
end
say 'tSel ts' m.tSel.11 'ix' m.tSel.12
km = mapKeys(m.td.map)
kd = mapKeys(m.td.dbs)
ks = mapKeys(m.td.sps)
say 'dbs' m.kd.0 'map' m.km.0 'sps' m.ks.0
return
endProcedure tstDbs
tstDb: procedure expose m.
parse arg td, pDb
say time() 'tstDb' m.dbSub pDb
dbm = tstDbLocalMap
call csiOpen csi, m.dbSub'.'DSNDBC'.'pDb'.**'
cFi = 0
cTsFi = 0
cIxFi = 0
cBad = 0
do while csiNext(csi, file)
cFi = cFi + 1
m.td.typ = 't'
m.anaErr = 0
if anaDsn(td, m.file) then do
cTsFi = cTsFi + 1
end
else do
m.td.typ = 'i'
if anaDsn(td, m.file) then do
cIxFi = cIxFi + 1
end
else do
cBad = cBad + 1
call anaErr 'no is or ts found for dsn:' m.file
end
end
end
say time() 'tstDb' m.dbSub pDb',' cFi 'files:',
cTsFi 'ts' cIxFi 'ix' cBad 'bad'
kk = mapKeys(m.td.sps)
cTs = 0
cIx = 0
do kx = 1 to m.kk.0
if \ abbrev(m.kk.kx, pDb'.') then
iterate
aa = m.td.map'.'m.kk.kx
if m.aa == 't' then
cTs = cTs + 1
else
cIx = cIx + 1
end
say time() 'tstDb' m.dbSub pDb':' cTsFi 'files in' cTs 'TS,' ,
cIxFi 'files in' cIx 'ix, total' cFi
if cTs > cTsFi | cIx > cIxFi then
call err 'cTsFi cIxFi mismatch'
return
call sqlPreAllCl 49, 'select' ,
'strip(dbName) || ''.'' || strip(name)',
',partitions',
'from sysibm.sysTableSpace',
'where dbName = '''pDb'''',
, 'ST', ':M.ST.SX.TS, :M.ST.SX.PARTS'
if cTs > m.st.0 then
call err 'sysTables found' m.st.0 'ts > mapTs' cMapTs
do sx=1 to m.st.0
a0 = m.td.map'.'m.st.sx.ts
mapPa = mapGet(m.td.sps, m.st.sx.ts, '')
if mapPa == '' then
say 'ts' m.st.sx.ts 'not in map'
else if m.a0 \== 't' then
say 'ts' m.st.sx.ts 'bad type in map' m.a0
else if m.a0.toPa \== m.st.sx.parts then
say 'ts' m.st.sx.ts 'partitions in sysTS' m.st.sx.parts,
'but' m.a0.toPa 'in map'
else do px=1 to words(mapPa)
pa = word(mapPa, px)
if pa = 0 then do
if m.a0.1.part \= 0 then
say 'ts' m.st.sx.ts 'bad part' pa '(only 0)'
end
else if pa \= m.a0.pa.part then do
say 'ts' m.st.sx.ts 'bad part' pa '<>' m.a0.pa.part
end
end
end
call sqlPreAllCl 49, 'select' ,
'strip(i.dbName) || ''.'' || strip(i.indexSpace)',
',strip(t.dbName) || ''.'' || strip(t.tsName)',
'from sysibm.sysIndexes i, sysibm.sysTables t',
'where i.tbCreator = t.creator and i.tbName = t.name',
' and i.dbName = '''pDb'''',
, 'ST', ':M.ST.SX.IS, :M.ST.SX.TS'
if cIx > m.st.0 then
call err 'sysIndexes found' m.st.0 'indexes'
do sx=1 to m.st.0
a0 = m.td.map'.'m.st.sx.is
mapPa = mapGet(m.td.sps, m.st.sx.is, '')
if mapPa == '' then
say 'ix' m.st.sx.is 'not in map'
else if m.a0 \== 'i' then
say 'is' m.st.sx.is 'bad type in map' m.a0
else if m.a0.ts \== m.st.sx.ts then
say 'is' m.st.sx.is 'in sysTS belongs to' m.st.sx.ts,
'but' m.a0.ts 'in map'
else if 0 = mapPa then do
if m.a0.1.part \= 0 then
say 'is' m.st.sx.is 'unpartitioned but parts' mapPa
end
else do px=1 to words(mapPa)
pa = word(mapPa, px)
if pa \= m.a0.pa.part then
say 'is' m.st.sx.ts 'bad part' pa '<>' m.a0.pa.part
end
end
m.tFi = m.tFi + cFi
m.tTs = m.tTs + cTs
m.tTsFi = m.tTsFi + cTsFi
m.tIx = m.tIx + cIx
m.tIxFi = m.tIxFi + cIxFi
m.tBad = m.tBad + cBad
say 'total ts' m.tTs m.tTsFi 'ix' m.tIx m.tIxFi 'bad' m.tBad,
'files' m.tFi
return
endProcedure tstDb
anaObjList: procedure expose m.
parse arg m
cObj = 0
cBad = 0
do while in(line)
parse var m.line ty quNm parts .
parse var quNm db '.' ts
parse var m.line '*parts' paNum .
if ty == 'ts' | ty == 'is' then
m.m.typ = left(ty, 1)
else
call err 'bad obj line' strip(m.line)
call listExpReset paLst, parts
do forever
m.ana.err = 0
p1 = listExp(paLst)
if p1 == '' then
leave
res = anaObjPart(m, db, ts, p1)
if res == 1 then
cObj = cObj + 1
else do
call anaErr res 'for tsPart' db'.'ts':'p1
cBad = cBad + 1
end
end
end
say cObj ty'-spaceParts found and' cBad 'bad parts'
return
endProcedure anaObjList
anaDsnList: procedure expose m.
parse arg m, ty
cObj = 0
cBad = 0
m.m.typ = ty
do while in(file)
m.anaErr = 0
if anaDsn(m, left(m.file, 72)) then do
cObj = cObj + 1
end
else do
cBad = cBad + 1
call anaErr 'no' ty'-space found for dsn:' m.file
end
end
say cObj ty'-spaces found and' cBad 'bad file names'
return
endProcedure anaDsnList
anaDsn: procedure expose m.
parse arg m, sub '.DSNDB' c '.' d '.' t '.' iQua '.' aQua r
dsn = strip(arg(2))
if sub ='' | d ='' | t ='' | iQua ='' | aQua = '' | r <> '' then
return anaErr('anaTsDsn cannot analyze dsn' dsn)
if c \== 'C' & c \== 'D' then
return anaErr('bad cluster' c 'in analyze dsn' dsn)
if wordPos(sub, m.g.vcats) < 1 then
return anaErr('hlq' sub 'not in vcats' m.g.vcats 'in dsn' dsn)
th = pos(left(aQua, 1), 'ABCDEF') - 1
if th < 0 then
return anaErr('bad partition qualifier' aQua 'in dsn' dsn)
p = substr(aQua, 2)
if \ datatype(p, 'n') then
return anaErr('partition not numeric in dsn' dsn)
p = p + 1000 * th
res = anaObjPart(m, d, t, p, iQua, dsn)
if length(res) == 1 then
return res
return anaErr(res 'dsn' dsn) /* ???wkTst
mp = m.m.map
a0 = mp'.'d'.'t
if \ mapHasKey(mp, d'.'t) then
return 0
if m.a0 \== m.m.typ then
return 0
if m.a0.1.part = 0 then do
ap = a0'.'1
p = 0
end
else if mapHasKey(mp, d'.'t'.'p'.PART') then
ap = a0'.'p
else
return anaErr('bad partition' p 'for dsn' dsn)
lst = mapGet(m.m.sps, d'.'t, '')
if wordPos(p, lst) < 1 then
call mapPut m.m.sps, d'.'t, lst p
if \ abbrev(iQua, m.ap.iPr) then
return anaErr('iPref' m.ap.iPr ,
'in sys?'m.m.typ'?Part mismatches dsn' dsn)
dl = mapGet(m.m.dss, d'.'t, '')
if wordPos(dsn, dl) < 1 then
call mapPut m.m.dss, d'.'t, dl dsn
return 1 */
endProcedure anaDsn
anaObjPart: procedure expose m.
parse arg m, d, t, p, iQua, dsn
if \ mapHasKey(m.m.dbs, d) then do
call anaLoadDb m, d
call mapAdd m.m.dbs, d, 1
end
mp = m.m.map
a0 = mp'.'d'.'t
if \ mapHasKey(mp, d'.'t) then
return 0
if m.a0 \== m.m.typ then
return 0
if m.a0.1.part = 0 then do
ap = a0'.'1
p = 0
end
else if mapHasKey(mp, d'.'t'.'p'.PART') then
ap = a0'.'p
else
return 'bad partition' p 'in'
lst = mapGet(m.m.sps, d'.'t, '')
if wordPos(p, lst) < 1 then
call mapPut m.m.sps, d'.'t, lst p
if iQua == '' then
return 1
if \ abbrev(iQua, m.ap.iPr) then
return 'iPref' m.ap.iPr ,
'in sys?'m.m.typ'?Part mismatches'
dl = mapGet(m.m.dss, d'.'t, '')
if wordPos(dsn, dl) < 1 then
call mapPut m.m.dss, d'.'t, dl dsn
return 1
endProcedure anaObjPart
anaLoadDb: procedure expose m.
parse arg m, db
mp = m.m.map
cnt = anaSelect(21, db)
sp = ''
do rx=1
if sp == m.tmp.rx.ts then do
if pa = 0 then
call err 'ts' sp 'several rows but unpartitioned'
else if pa+1 \= m.tmp.rx.part then
call err 'ts' sp 'part' (pa+1) 'expected but fetched' ,
m.tmp.rx.part
pa = pa + 1
end
else do
if sp \== '' then do
if pa \= m.a0.toPa then
call err 'ts' sp pa 'parts selected but',
m.a0.toPa 'partitions'
m.a0.0 = px
end
if rx > cnt then
leave
sp = m.tmp.rx.ts
call mapAdd mp, sp, 't'
a0 = mp'.'sp
m.a0.ts = sp
m.a0.tb = m.tmp.rx.tb
pa = m.tmp.rx.toPa > 0
if pa \= m.tmp.rx.part then
call err 'ts' sp 'partitions' m.tmp.rx.toPa,
'but first part' m.tmp.rx.part
m.a0.toPa = m.tmp.rx.toPa
m.a0.is = ''
m.a0.ix = ''
m.a0.type = m.tmp.rx.type
if (pa == 0 & pos(m.a0.type, ' IKL') < 1) ,
| (pa \== 0 & pos(m.a0.type, ' GIKLR') < 1) then
say '*** ts' m.a0.ts 'pa' pa 'mismatch type' m.a0.type
end
px = max(pa, 1)
m.a0.px.part = pa
m.a0.px.space = m.tmp.rx.space
m.a0.px.iPr = m.tmp.rx.iPr
end
cnt = anaSelect(12, db)
sp = ''
do rx=1
if sp == m.tmp.rx.is then do
if pa = 0 then
call err 'is' sp 'several rows but unpartitioned'
else if pa+1 \= m.tmp.rx.part then
call err 'is' sp 'part' (pa+1) 'expected but fetched' ,
m.tmp.rx.part
pa = pa + 1
end
else do
if sp \== '' then do
m.a0.toPa = pa
m.a0.0 = px
end
if rx > cnt then
leave
sp = m.tmp.rx.is
call mapAdd mp, sp, 'i'
a0 = mp'.'sp
m.a0.is = sp
pa = m.tmp.rx.part
if pa \== 0 & pa \== 1 then
call err 'is' sp 'first part' pa
m.a0.ix = m.tmp.rx.ix
m.a0.ts = m.tmp.rx.ts
m.a0.type = m.tmp.rx.type
if (pa == 0 & m.a0.type \== 2) ,
| (pa \== 0 & pos(m.a0.type, '2DP') < 1) then
say '*** ix' m.a0.ix 'pa' pa 'mismatch type' m.a0.type
end
px = max(pa, 1)
m.a0.0 = px
m.a0.px.part = pa
m.a0.px.space = m.tmp.rx.space
m.a0.px.iPr = m.tmp.rx.iPr
end
return
endProcedeure anaLoadDb
anaSelect: procedure expose m.
parse arg cs, d
m.tSel.cs = m.tSel.cs + 1
return sqlOpAllCl(cs, tmp, m.db.cs.vars, d)
endProcedure anaSelect
anaErr: procedure expose m.
parse arg msg
if m.anaErr \== 1 then
say msg
if m.anaErr == 0 then
m.anaErr = 1
return 0
anaReset: procedure expose m.
parse arg m, dbSub
m.m.map = m'.MA' /* db structure filled by anaLoadDb
.db.sp... attributes per ts or ix space
.db.sp.pa... attributes per partition */
m.m.dbs = m'.DB' /* .db = 1 means db is loaded in m.m.map */
m.m.sps = m'.SP' /* partitionenn pro space
.db.ts contains partitions as word list */
m.m.dss = m'.DS' /* datasets pro space filled by anaDsn
.db.sp enthält datasets als WortListe */
m.m.sys = 'SYS' /* System, Anzahl Jobs und Member pro system */
m.m.job = 'JOB'
m.m.group = m'.GR' /* groups key ist dbTs
.dbTs.TS TS in this group (wordList)
.dbTs.IS IS in this group (wordList)
.dbTs.EST estimated time
.dbTs.*S... figures for IS / TS */
call mapReset m.m.Map, 'K'
call mapReset m.m.Dbs, 'K'
call mapReset m.m.sps, 'K'
call mapReset m.m.dss, 'K'
call mapReset m.m.job, 'K'
call mapReset m.m.group, 'K'
call envPut 'est.ts.const', 76
call envPut 'est.ts.part', .35
call envPut 'est.ts.byte', 1.5e-5 / 4096
call envPut 'est.ix.const', 30
call envPut 'est.ix.part', 1
call envPut 'est.ix.byte', 4e-8
m.tSel.11 = 0
m.tSel.21 = 0
m.tSel.12 = 0
m.tTs = 0
m.tTsFi = 0
m.tIx = 0
m.tIxFi = 0
m.tFi = 0
m.tBad = 0
return
endProcedure anaReset
/*--- System, Anzahl Jobs und MemberName aus
dem maRecStem /sys/ holen --------------------------------*/
anaSys: procedure expose m.
parse arg m
cnt = 0
sx = 0
grp = envGet('DBSUB')
do ix=1 to envGet('sys.0')
parse value envGet('sys.'ix) with sys c mbr .
if sys = '' | abbrev(sys, '*') | c < 1 then
iterate
if \ dataType(c, 'n') then
call err 'bad jobCount' c 'in sys.'ix':' envGet('sys.'ix)
sx = sx + 1
m.m.sx = sys
m.m.sx.jobs = c
m.m.sx.member = if(mbr='', grp, mbr)
cnt = cnt + c
end
m.m.0 = sx
m.m = cnt
if cnt < 1 then
call err 'no system with jobs in sys.*'
return
endProcedure anaSys
/*--- connect to subsystem and prepare selects for TS and IS ---------*/
dbConn: procedure expose m.
parse arg g, sub, closeOld
say 'connecting to' sub
if symbol('m.g.dbSub') == 'VAR' then
if closeOld == 1 then
call sqlDisconnect
else
call err 'db2 connect to' sub 'but already to' m.g.dbSub
call sqlConnect sub
m.g.dbSub = sub
call sqlPreDeclare 11, "select",
" strip(s.dbName) || '.' || strip(s.name)",
", s.partitions, s.type, p.partition, p.iPrefix" ,
", max(48e0, p.spacef, coalesce(r.space, 0)) * 1024" ,
"from sysibm.sysTablespace s",
"join sysibm.sysTablePart p" ,
"on s.dbName = p.dbName and s.name = p.tsName",
"left join sysibm.sysTablespaceStats r" ,
"on r.dbName = s.dbName and r.name = s.name",
"and r.dbid = s.dbid and r.psid = s.psid",
"and r.partition = p.partition",
"where s.dbName = ?",
"order by 1 asc, 4 asc",
"with ur"
m.db.11.vars = sqlVars('m.tmp.sx', "ts toPa type part iPr space")
call sqlPreDeclare 12, "select" ,
" strip(i.creator) || '.' || strip(i.name)",
", strip(i.dbName) || '.' || strip(i.indexspace)",
", strip(t.dbName) || '.' || strip(t.tsName)" ,
", i.indexType, p.partition, p.iPrefix" ,
", max(48e0, p.spacef, coalesce(r.space, 0)) * 1024" ,
"from sysibm.sysIndexes i",
"join sysibm.sysIndexPart p" ,
"on i.creator = p.ixCreator and i.name = p.ixName" ,
"join sysibm.sysTables t" ,
"on i.tbCreator = t.creator and i.tbName = t.name" ,
"left join sysibm.sysIndexSpaceStats r" ,
"on r.dbName = i.dbName and r.name = i.name",
"and r.creator = i.creator",
"and r.indexSpace = i.indexSpace",
"and r.dbid = i.dbid and r.isobid = i.isobid",
"and r.partition = p.partition",
"where i.dbName = ?" ,
"order by 2 asc, 5 asc",
"with ur"
m.db.12.vars = sqlVars('m.tmp.sx', "ix is ts type part iPr space")
/* wkTst 21 und 22 sind für neues Interface */
call sqlPreDeclare 21, "select",
" strip(s.dbName) || '.' || strip(s.name)",
", s.partitions, s.type, p.partition, p.iPrefix" ,
", max(48e0, p.spacef, coalesce(r.space, 0)) * 1024" ,
", value((select min(strip(creator) || '.' || strip(name))",
"from sysibm.sysTables t",
"where t.dbName=s.dbName and t.tsName=s.name)",
", '')",
"from sysibm.sysTablespace s",
"join sysibm.sysTablePart p" ,
"on s.dbName = p.dbName and s.name = p.tsName",
"left join sysibm.sysTablespaceStats r" ,
"on r.dbName = s.dbName and r.name = s.name",
"and r.dbid = s.dbid and r.psid = s.psid",
"and r.partition = p.partition",
"where s.dbName = ?",
"order by 1 asc, 4 asc",
"with ur"
m.db.21.vars = sqlVars('m.tmp.sx', "ts toPa type part iPr space tb")
return
endProcedure dbConn
listExpReset: procedure expose m.
parse arg m, m.m.src
m.m.rg.1 = 'reset'
m.m.rg.2 = ''
m.m.pos = 1
return m
endProcedur listExpReset
listExp: procedure expose m.
parse arg m
la = m.m.rg.1
if la > m.m.rg.2 then
if listExpRg(m) == '' then
return ''
else
la = m.m.rg.1
m.m.rg.1 = la + 1
return la
endProcedure listExp
listExpRg: procedure expose m.
parse arg m
m.m.rg.1 = 'end'
m.m.rg.2 = ''
x0 = m.m.pos
do lx=1 to 2
x1 = verify(m.m.src, ' ', 'n', x0)
if x1 < 1 then do
m.m.pos = length(m.m.src)+1
leave
end
x2 = verify(m.m.src, '0123456789', 'n', x1)
if x2 = 0 then
x2 = length(m.m.src)+1
if x2 <= x1 then
call err 'non numeric listelement' substr(m.m.src, x1),
'in list' m.m.src
m.m.rg.lx = substr(m.m.src,x1, x2-x1)
x3 = verify(m.m.src, ' ', 'n', x2)
if x3 = 0 then do
m.m.pos = length(m.m.src)+1
leave
end
if substr(m.m.src, x3, 1) == ',' then do
m.m.pos = x3+1
leave
end
if substr(m.m.src, x3, 1) \== '-' | lx > 1 then
call err 'bad op' substr(m.m.src, x3) 'in list' m.m.src
x0 = x3+1
end
if m.m.rg.1 == 'end' then
return ''
if m.m.rg.2 == '' then
m.m.rg.2 = m.m.rg.1
if m.m.rg.1 <= m.m.rg.2 then
return m.m.rg.1 m.m.rg.2
say 'empty range' m.m.rg.1'-'m.m.rg.2 'in list' m.m.src
return listExpRg(m)
endProcedure listExpRg
/* copy wsh ab hier */
/* rexx ****************************************************************
wsh
compiler directives $# ('|' | '<')? <kind>
$# ( 'end' | 'out' )
field access for getVars mit |
kind # mit filter (c=cut, j=strip and join ...)
inline Data mit $#</ und filter wie oben
Ideen: writeFramed: eliminieren von rdr abhängig machen ?|
Ideen: String --> ref mit Prefix done
buf mit copy semantics bufR mit refs noch implementieren
block mit lokalen geschachtelten Variabeln
run von JRW wegnehmen --> nein,
braeuchte wieder Fallunterscheidung in run
mapVia: eliminieren oder besser unterstützen?
pipe aus rexx (kürzer als pipeBegin ... pipeLast ... pipeEnd)
pipeAllFramed richtig testen (auch nested)
cat optimieren mit recursive nextRdr (DelegationsKette kürzen)
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
parse arg spec
os = errOS()
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done spec
if done then
return
end
spec = wshFun(spec)
if spec == '$' then
return
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = '-wsh'
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
end
end
else if os == 'LINUX' then do
inp = '&in'
out = '&out'
end
else
call err 'implemnt wsh for os' os
call compRun spec, inp, out
exit 0
wshFun: procedure expose m.
parse arg fun rest
call scanIni
f1 = translate(fun)
sx = verify(f1, m.scan.alfNum)
if sx = 2 | sx = 1 then do
f1 = left(f1, 1)
rest = substr(fun, 2) rest
end
if f1 = 'T' then
call wshTst rest
else if f1 = 'I' then
call wshInter rest
else if f1 = '?' then
return 'call pipePreSuf' rest '$<$#='
else
return arg(1)
return '$'
endProcedure wshFun
tstSqlO1: procedure expose m.
call sqlOIni
call sqlConnect dbaf
sq = sqlSel("select strip(name) from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 1")
do 2
call jOpen sq, m.j.cRead
do while jRead(sq, abc)
call outO abc
end
call jClose sq
end
call sqlDisconnect
return 0
endProcedure tstSqlO1
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call tstSqlO1
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- compRun: compile shell or data from inp and
run it to output out -----------------------------------*/
compRun: procedure expose m.
parse arg spec, inp, out
return compRunO(spec, s2oNull(inp), s2oNull(out))
endProcedure compRun
compRunO: procedure expose m.
parse arg spec, inO, ouO
cmp = comp(inO)
r = compile(cmp, spec)
if ouO \== '' then
call pipeBeLa '>' ouO
call oRun r
if ouO \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '|:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '|' then
return
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ':' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
end
say 'enter' mode 'expression, | for end, : or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
else
out = ''
call wshBatch ty, '-wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if sysvar('sysISPF') \= 'ACTIVE' then
return 0
if adrEdit('macro (mArgs) NOPROCESS', '*') \== 0 then
return 0
spec = wshFun(mArgs)
if spec == '$' then
return 1
if spec == '' & dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then do
call tstAct
return 0
end
call wshIni
o = jOpen(jBuf(), '>')
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
say 'range' rFi '-' rLa
end
else do
rFi = ''
say 'no range'
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
say 'dest' dst
end
else do
dst = ''
say 'no dest'
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
call jWrite o, left(li, 50) date('s') time()
end
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
i = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, spec)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call pipeBegin
call oRun r
call pipeLast '>' o
do while inO(obj)
call objOut(obj)
end
call pipeEnd
lab = wshEditInsLinSt(dst, 0, , o'.BUF')
if dst \= '' then
call wshEditLocate max(1, dst-7)
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
call outPush mCut(ggStem, 0)
call errSay 'compErr' ggTxt
call outPop
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst, 1, , so'.BUF')
call outPush mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst, 1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
call tstZos
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql /* wkTst??? noch einbauen|||
call tstSqlO
call tstSqlEnv */
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*<<tstSorQ
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSorQ */
/*<<tstSorQAscii
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSorQAscii */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*<<tstSort
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSort */
/*<<tstSortAscii
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSortAscii */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*<<tstMatch
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlIni
call jIni
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, :M.+
STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
call tst t, "tstSqlO",
, "*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAM",
|| "E ",
, " e 1: warnings",
, " e 2: state 42704",
, " e 3: stmt = execSql prepare s7 from :src",
, " e 4: with src = select * from sysdummy",
, "REQD=Y col=123 case=--- col5=anonym",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call out 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call out fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call out oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
call tst t, "tstSqlEnv",
, "REQD=Y COL2=123 case=--- COL5=anonym",
, "sql fmtFldRw sl<15",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "sql fmtFldSquashRW",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn sl=",
, "COL1 T DBNAME COL4 ",
, "SYSTABAUTH T DSNDB06 SYSDBASE"
call mAdd t.cmp,
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_ T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn ---",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
call pipeBegin
call out 'select d.*, 123, current timestamp "jetzt und heute",'
call out 'case when 1=0 then 1 else null end caseNull,'
call out "'anonym'"
call out 'from sysibm.sysdummy1 d'
call pipe
call sql 13
call pipeLast
do while envRead(abc)
call out 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call pipeEnd
call out 'sql fmtFldRw sl<15'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call pipeEnd
call out 'sql fmtFldSquashRW'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldSquashRW
call pipeEnd
call out 'sqlLn sl='
call pipeBegin
call out 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13, , ,'sl='
call pipeEnd
call out 'sqlLn ---'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13
call pipeEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*<<tstCompDataConst
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
tstCompDataConst */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*<<tstCompDataConstBefAftComm1
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
tstCompDataConstBefAftComm1 */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*<<tstCompDataConstBefAftComm2
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
tstCompDataConstBefAftComm2 */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*<<tstCompDataVars
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-$.{""$v1} = valueV1; .
tstCompDataVars */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-$.{""""$v1} =" $-$.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*<<tstCompShell
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
tstCompShell */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*<<tstCompShell2
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
tstCompShell2 */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*<<tstCompPrimary
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
tstCompPrimary */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*<<tstCompExprStr
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
tstCompExprStr */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*<<tstCompExprObj
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
tstCompExprObj */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*<<tstCompExprDat
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.$-{"abc"}=!abc
tstCompExprDat */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.$-{""abc""}="$.$-{"abc"}'
/*<<tstCompExprRun
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
tstCompExprRun */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*<<tstCompExprCon
tstCompExprCon */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*<<tstCompStmt1
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
tstCompStmt1 */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*<<tstCompStmt2
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
tstCompStmt2 */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*<<tstCompStmt3
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
tstCompStmt3 */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*<<tstCompStmtDo
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
tstCompStmtDo */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*<<tstCompStmtDo2
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
tstCompStmtDo2 */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*<<tstCompSynPri1
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
tstCompSynPri1 */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*<<tstCompSynPri2
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
tstCompSynPri2 */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*<<tstCompSynPri3
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
tstCompSynPri3 */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*<<tstCompSynPri4
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
tstCompSynPri4 */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*<<tstCompSynFile
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@$.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 18 in line 1: $@$.<$*( co1 $*) $$abc
tstCompSynFile */
call tstComp1 '@ tstCompSynFile +', '$@$.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*<<tstCompSynAss1
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
tstCompSynAss1 */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*<<tstCompSynAss2
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
tstCompSynAss2 */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*<<tstCompSynAss3
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
tstCompSynAss3 */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*<<tstCompSynAss4
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
tstCompSynAss4 */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*<<tstCompSynAss5
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
tstCompSynAss5 */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*<<tstCompSynAss6
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
tstCompSynAss6 */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*<<tstCompSynAss7
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
tstCompSynAss7 */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*<<tstCompSynRun1
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
tstCompSynRun1 */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*<<tstCompSynRun2
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
tstCompSynRun2 */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*<<tstCompSynRun3
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@ =
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@ =
tstCompSynRun3 */
call tstComp1 '@ tstCompSynRun3 +', '$@ ='
/*<<tstCompSynFor4
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
tstCompSynFor4 */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*<<tstCompSynFor5
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
tstCompSynFor5 */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*<<tstCompSynFor6
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
tstCompSynFor6 */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*<<tstCompSynFor7
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
tstCompSynFor7 */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*<<tstCompSynCt8
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
tstCompSynCt8 */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*<<tstCompSynProc9
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
tstCompSynProc9 */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*<<tstCompSynProcA
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
tstCompSynProcA */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*<<tstCompSynCallB
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
tstCompSynCallB */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*<<tstCompSynCallC
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
tstCompSynCallC */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*<<tstCompSynCallD
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
tstCompSynCallD */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*<<tstCompObjRef
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla union = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
tstCompObjRef */
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*<<tstCompObjRefPri
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
tstCompObjRefPri */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*<<tstCompObjRefFile
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
tstCompObjRefFile */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<{ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*<<tstCompObjRun
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
tstCompObjRun */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
return
/*<<tstCompObj
### start tst tstCompObj ##########################################
compile @, 8 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
out .¢ o1, o2!
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
tstCompObj */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompDataIO: procedure expose m.
/*<<tstCompDataHereData
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
tstCompDataHereData */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*<<tstCompDataIO
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@$.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
tstCompDataIO */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = dsn tstFB('::F37', 0)
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
call tstComp1 '= tstCompDataIO',
, ' input 1 $@$.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@$.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*<<tstCompFileBloSrc
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+.
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
tstCompFileBloSrc */
/*<<tstCompFileBlo
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @LINE isA :TstClassVF union = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @LINE isA :TstClassVF union = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @LINE isA :TstClassVF union = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @LINE isA :TstClassVF union = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @LINE isA :TstClassVF union = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @LINE isA :TstClassVF union = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @LINE isA :TstClassVF union = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @LINE isA :TstClassVF union = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
tstCompFileBlo */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*<<tstCompFileObjSrc
$=vv=value-vv-1
$=fE=.$.<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@$.<$dsn
tstCompFileObjSrc */
/*<<tstCompFileObj
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-2
tstR: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
tstCompFileObj */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*<<tstCompPipe1
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
tstCompPipe1 */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*<<tstCompPipe2
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
tstCompPipe2 */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*<<tstCompPipe3
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
tstCompPipe3 */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*<<tstCompPipe4
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
tstCompPipe4 */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*<<tstCompRedir
### start tst tstCompRedir ########################################
compile @, 6 lines: $>}eins $@for vv $$<$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>}eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<}eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*<<tstCompCompShell
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
tstCompCompShell */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*<<tstCompCompData
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
tstCompCompData */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*<<tstCompDirSrc
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
tstCompDirSrc */
/*<<tstCompDir
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
tstCompDir */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*<<tstCompDirPiSrc
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@$#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
tstCompDirPiSrc */
/*<<tstCompDirPi
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$.$#=, 5 lines: zeile +
1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
tstCompDirPi */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$.$#="
return
endProcedure tstCompDir
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*<<tstTstSayEins
### start tst tstTstSayEins #######################################
test eins einzige testZeile
tstTstSayEins */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
/*<<tstTstSayDrei
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
tstTstSayDrei */
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
tstM */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*<<tstMap
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 nicht gefunden
tstMap */
/*<<tstMapInline1
inline1 eins
inline1 drei
tstMapInline1 */
/*<<tstMapInline2
inline2 eins
tstMapInline2 */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3',
, 'nicht gefunden')
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*<<tstMapVia
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
tstMapVia */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*<<tstClass2old
### start tst tstClass2 ###########################################
@CLASS.8 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.7 :class union
. choice u stem 9
. .1 refTo @CLASS.15 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.16 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.10 :class union
. choice r .CLASS refTo @CLASS.8 done :class @CLASS.8
. .3 refTo @CLASS.17 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .4 refTo @CLASS.19 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.18 :class union
. choice s .CLASS refTo @CLASS.10 done :class @CLASS.10
. .5 refTo @CLASS.20 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.12 :class union
. choice u stem 2
. .1 refTo @CLASS.9 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.21 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .7 refTo @CLASS.22 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.23 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.14 :class union
. choice u stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.13 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .9 refTo @CLASS.26 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.25 :class union
. choice n union
. .NAME = w
. .CLASS refTo @CLASS.24 :class union
. choice r .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2old */
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.13 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.12 :class union
. choice u stem 10
. .1 refTo @CLASS.20 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.22 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.21 :class union
. choice w } LASS.21
. .3 refTo @CLASS.23 :class union
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.10 :class union
. choice o obj has no class @o
. .4 refTo @CLASS.24 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.16 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.15 :class union
. choice r .CLASS refTo @CLASS.13 done :class @CLASS.13
. .5 refTo @CLASS.25 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.16 done :class @CLASS.16
. .6 refTo @CLASS.27 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.26 :class union
. choice s .CLASS refTo @CLASS.15 done :class @CLASS.15
. .7 refTo @CLASS.28 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.17 :class union
. choice u stem 2
. .1 refTo @CLASS.14 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.16 done :class @CLASS.16
. .8 refTo @CLASS.29 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .9 refTo @CLASS.30 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .10 refTo @CLASS.31 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.19 :class union
. choice u stem 2
. .1 refTo @CLASS.14 done :class @CLASS.14
. .2 refTo @CLASS.18 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2 */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
tstClass */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n tstClassTf12 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12,' ,
's u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,'*** err: basicClass v' ,
'end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"')
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 n =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 n =className= TstOElf
C4 n =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
tstO */
call tst t, 'tstO'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWOut.jOpen(<obj s of JRWOut>, open<Arg)
*** err: jWrite(<obj s of JRWOut>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
tstJSay */
call jIni
call tst t, 'tstJSay'
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jOpen s, 'open<Arg'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*<<tstJ
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
*** err: already opened jOpen(<buf b>, <)
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
tstJ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*<<tstJ2
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
call tst t, "tstJ2"
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jReadO(b, res)
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), '<'
do while jReadO(c, ccc)
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*<<tstCat
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
tstCat */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*<<tstEnv
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
tstEnv */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipeBeLa '<' b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*<<tstEnvCat
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
tstEnvCat */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipeBeLa '<' b0, '<' b1, '<' b2, '<' c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa '<' c1
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*<<tstPipe
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
tstPipe */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1|FLD')
call pipeBeLa '>' s2o('}theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa '<' s2o('}theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
tstPipeLazy: procedure expose m.
call pipeIni
/*<<tstPipeLazy
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAllFramed *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAllFramed in inIx 0
a2 vor writeAllFramed jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAllFramed in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAllFramed ***
b1 vor barBegin lazy 1 writeAllFramed *** <class TstPipeLazyRdr>
b4 vor writeAllFramed
b2 vor writeAllFramed rdr inIx 1
RdrOpen <
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAllFramed ***
tstPipeLazy */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr"; return in(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
if lz then
call mAdd t'.TRANS', m.j.out '<barBegin out>'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*<<tstEnvClass
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAllFramed *** TY
a5 vor writeAllFramed
a1 vor jBuf()
a2 vor writeAllFramed b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAllFramed
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAllFramed ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
t10 = classNew('n TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n TstEnvClass20 u v, f f24 v, f F25 v')
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*<<tstFile
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
tstFile */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa '<' s2o(tstPdsMbr(pd2, 'eins')), '<' b,
,'<' jBuf(),
,'<' s2o(tstPdsMbr(pd2, 'zwei')),
,'<' s2o(tstPdsMbr(pds, 'wr0')),
,'<' s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
tstFileList */
/*<<tstFileListTSO
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
tstFileListTSO */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
call pipeIni
/*<<tstFmt
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
tstFmt */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFWriteAll fmtFreset(abc), b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, b
call tstEnd t
return
endProcedure tstFmt
tstScan: procedure expose m.
/*<<tstScan.1
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
tstScan.1 */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.2
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
tstScan.2 */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.3
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
tstScan.3 */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*<<tstScan.4
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
tstScan.4 */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*<<tstScan.5
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*<<tstScanRead
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
tstScanRead */
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*<<tstScanReadMitSpaceLn
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
tstScanReadMitSpaceLn */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*<<tstScanJRead
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*<<tstScanWin
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
tstScanWin */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*<<tstScanWinRead
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*<<tstScanSqlId
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
tstScanSqlId */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlDelimited
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
tstScanSqlDelimited */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlQualified
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
tstScanSqlQualified */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNum
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
tstScanSqlNum */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNumUnit
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
tstScanSqlNumUnit */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa '<' m, '>' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '/*<<'name
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say name '*/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
m.class.o2c.arg = m.class.classV
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
m.tstErrHandler.0 = 0
call outPush tstErrHandler
call errSay ggTxt
call outPop
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m, var)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v,'
end
t = classNew('n tstData* u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, rdr, wiTi
b = env2buf(rdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
say ' ' newFo
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = src
return nn
endProcedure comp
m.nn.cmpRdr = scanRead(src)
return compReset(nn, src)
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@'
m.m.chKinC = '.-=@'
return m
endProcedure compReset
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
s = m.m.scan
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKinC) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc s, spec
call compSpComment m
m.m.dirKind = kind
m.m.compSpec = 1
res = oRunner()
nxt = res
doClose = 0
do cx=1 to 100
m.m.dir = ''
kind = m.m.dirKind
if kind == '@' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = comp2Code(m, ';'compShell(m))
end
else do
what = "data("kind")";
expec = "sExpression or block";
src = comp2Code(m, ';'compData(m, kind))
end
if m.m.dir == '' then
call compDirective m
if m.m.dir == '' then
return scanErr(s, expec "expected: compile" what ,
" stopped before end of input")
if abbrev(m.m.dir, '$#') then
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan 'directive' m.m.dir 'mismatch'
if src \== '' then do
call oRunnerCode nxt, src
nxt = m.m.dirNext
end
if wordPos(m.m.dir, 'eof next $#end $#out') > 0 then do
if doClose then
call jClose s
if m.m.dir \== 'next' | \ m.m.compSpec then
return res
call scanReadReset s, m.m.cmpRdr
doClose = jOpenIfNotYet(s)
m.m.compSpec = 0
end
end
call scanErr s, 'loop in compile'
endProcedure compile
compDirective: procedure expose m.
parse arg m, ki
if m.m.dir \== '' then
return ''
lk = scanLook(m.m.scan, 9)
if abbrev(lk, '$#') then do
if pos(substr(lk, 3, 1), m.m.chKinC) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if abbrev(lk, '$#end') then do
m.m.dir = 'eof'
return ''
end
else
call scanErr m.m.scan, 'bad directive after $#'
end
else if scanAtEnd(m.m.scan) then do
if \ m.m.compSpec | m.m.cmpRdr == '' then do
m.m.dir = 'eof'
return ''
end
m.m.dir = 'next'
end
else do
return ''
end
m.m.dirNext = oRunner()
if ki == '@' then
return "; call oRun '"m.m.dirNext"'"
else
return ". '"m.m.dirNext"'"
endProcedure compDirective
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compNewStem(m)
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return 'l*' lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res || one
if \ scanLit(m.m.scan, '$;') then
return res
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsb') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock, m.m.chDol)
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' then
nn = 'call outO' expr
else if fr == '<' then
nn = 'call pipeWriteAll ' expr
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' to 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ $l $0'
to.2 = '= - . < ; ( (- (. (; < ; @ @ $ $'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; <(; '
to.3 = ' 0; l; - - . . ; <; '
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 & trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/* wkTst???syntax start */
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = comp2Code(m, '-'compCheckNE(m,
, compExpr(m, 'b', '='), "variable name after $="))
if \ scanLit(s, "=") then
call scanErr s, '= expected after $=' nm
vl = compCheckNE(m, compBlockExpr(m, '='),
, 'block or expression after $=' nm '=')
if abbrev(vl, '-') then
return '; call envPut' nm',' comp2Code(m, vl)
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNN(m, compObj(m, '@'),
, "objRef expected after $@"))
fu = m.s.tok
if fu == 'for' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m),
, "statement after $@for" v))
return '; do while envReadO('v');' st'; end'
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
suf = comp2Code(m, ':'compCheckNE(m, compExpr(m, 's', ';'),
, "$@do control construct"))
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInterEx(comp2Code(m, '-'nm)), st
return '; '
end
if \ scanLit(s, '(') then
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '$$') then
return compCheckNN(m, compBlockExpr(m, '='),
, 'block or expression expected after $$')
return compDirective(m, '@')
endProcedure compStmt
/* wkTst???syntax end */
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
compInterEx: procedure expose m.
interpret 'return' arg(1)
endProcedure compInterEx
compBlockExpr: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compBlock(m, ki)
if res \== '' then
return res
lk = scanLook(s, 1)
if pos(lk, m.m.chKind) > 0 then
call scanChar s, 1
else
lk = ki
return compExpr(m, 's', lk)
endProcedure compBlockExpr
compObj: procedure expose m.
parse arg m, ki
one = compPrimary(m, translate(ki, '.', '@'))
if one \== '' then
return one
ki = translate(ki, ';', '@')
one = compBlock(m, ki)
if one \== '' then
return ki || one
s = m.m.scan
if scanLit(s, '<') then
return compFile(m)
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKind) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return ki'. compile(comp(env2Buf()), "'m.s.tok'")'
end
return compDirective(m, ki)
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compBlock(m, '=')
if res \== '' then
return '<;'res
s = m.m.scan
ki = scanLook(s, 1)
if pos(ki, m.m.chKind) > 0 then do
call scanLit s, ki
end
else do
ki = '='
res = compDirective(m, '.')
if res \== '' then
return '<'res
end
res = compCheckNE(m, compExpr(m, 's', ki),
, 'block or expr expected for file')
return '<'res
endProcedure compFile
compBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
t2 = scanLook(s, 2)
hasType = pos(left(t2, 1) , m.m.chKind) > 0
start = substr(t2, hasType+1, 1)
if pos(start, '{¢/') < 1 then
return ''
if hasType then
ki = translate(left(t2, 1), ';', '@')
if \ scanLit(s, left(t2, hasType+1)) then
call scanErr s, 'compBlock internal 1'
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
if start == '{' then do
res = compNewStem(m)
if ki == '#' then do
tx = '= '
cb = 1
do forever
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
call mAdd res, tx
end
else do
one = compExpr(m, 'b', ki)
if one \== '' & \ abbrev(one, 'e') then
call mAdd res, one
end
res = 'l*' res
end
else if ki == '#' then do
res = compNewStem(m)
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after' starter
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after' starter
end
res = 'l*' res
end
else if ki == ';' then do
call compSpNlComment m
res = compShell(m)
end
else if ki == '@' then do
call err 'compBlock bad ki' ki
end
else do
res = compData(m, ki)
if res == '' then
res = 'l*' compNewStem(m)
end
if \ scanLit(s, stopper) then
call scanErr s, 'ending' stopper 'expected after' starter
if res = '' then
return '('ki
else
return '('res
endProcedure compBlock
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
e1 = left(ex, 1)
return ex = '' | pos(e1, 'ce') > 0 | e1 = ex
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
sp = 0
co = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else
leave
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose if m.m.closeRdr then call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
m.m.closeRdr = jOpenIfNotYet(m.m.rdr, m.j.cRead)
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call classNew "n PipeFramedRdr u JRWO", "m",
, "jOpen call jOpen never-call-PipeFramedRdr-Open",
, "jReadO call pipePushFrame m;" ,
"res = jReadO(m.m.framedRdr, var);",
"call pipeEnd; return res",
, "jReset never-call-PipeFramedRdr-jReset",
, "jClose call pipeFramedClose m"
call mapReset env.vars
call jReset oMutate("PIPE.framedNoOut", "JRWErr")
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
else if jOpenIfNotYet(m.e.in, m.j.cRead) then
m.e.toClose = m.e.toClose m.e.in
if m.e.out == '' then
m.e.out = m.j.out
else if jOpenIfNotYet(m.e.out, m.e.outOp) then
m.e.toClose = m.e.toClose m.e.out
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
m.e.allInFrame = 1
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, '<')
m.f.out = jOpen(Cat(), '>')
m.f.toClose = m.f.in m.f.out
m.j.in = m.f.in
m.j.out = m.f.out
m.e.allInFrame = 1
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
m.f.allInFrame = 1
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
m.f.allInFrame = m.preF.allInFrame
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFramedRdr: procedure expose m.
parse arg e
m = pipeFrame()
m.m.jReading = 1
m.m.jWriting = 0
m.m.framedRdr = jOpen(jClose(m.e.out), m.j.cRead)
say 'framedRdr <' m.m.framedRdr
m.m.in = m.e.in
m.m.framedToClose = m.e.toClose
m.e.toClose = ''
m.m.out = "PIPE.framedNoOut"
call oMutate m, 'PipeFramedRdr'
return m
endProcedure pipeFramedRdr
pipeFramedClose: procedure expose m.
parse arg m
m.m.allInFrame = 0
call pipeClose m
call oMutate m, 'PipeFrame'
return
endProcedure pipeFramedClose
pipeFrame: procedure expose m.
m = oBasicNew("PipeFrame")
m.m.toClose = ''
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = ''
m.m.allInFrame = 0
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
if m.m.allInFrame == 2 then
return pipeFramedRdr(m)
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
/*--- write all from rdr (rsp in) to out, possibly lazy
do lazy reads within current frame -----------*/
pipeWriteAllFramed: procedure expose m.
parse arg rdr
if rdr == '' then
rdr = m.j.in
px = m.pipe.0
f = m.pipe.px
if m.f.allInFrame = 0 then do
call jWriteNow m.j.out, rdr
return
end
m.f.allInFrame = 2
call jWriteall m.j.out, rdr
return
endProcedure pipeWriteFramed
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outPush: procedure expose m.
parse arg st
call pipeBeLa '>' oNew('JRWOut', st)
return
endProcedure outPush
outPop: procedure expose m.
call pipeEnd
return
endProcedure outPop
/*--- write all from rdr (rsp in) to a new jBuf --------------------*/
env2Buf: procedure expose m. /*wkTst remove |||| */
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, if(rdr=='', m.j.in, rdr)
return jClose(b)
endProcedure env2Buf
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGetO: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envGet: procedure expose m.
parse arg na
return o2String(mapGet(env.vars, na))
endProcedure envGet
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
if \ inO("ENV.VARS.OBJ."na) then
return 0
call envPutO na, "ENV.VARS.OBJ."na
return 1
if \ inO('ENV.XX') then
return 0
call envPut na, m.env.xx
return 1
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na) /*wkTst??? remove?*/
envPutO: procedure expose m.
parse arg na, ref
return mapPut(env.vars, na, ref)
envPut: procedure expose m.
parse arg na, va
call mapPut env.vars, na, s2o(va)
return va
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catRdClose = 0
m.m.catIx = -9e9
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
if m.m.catRdClose then
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' & m.m.catRdClose then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
m.m.catRdClose = jOpenIfNotYet(m.m.catRd , m.j.cRead)
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jReadO(m.m.catRd, var) then
return 1
call catNextRdr m
end
return 0
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
call mAdd m'.RWS', o2File(arg(ax))
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
if abbrev(str, m.j.cVar) then do
var = substr(str, 2)
if envHasKey(var) then
return envGetO(var)
else
return envPutO(var, jBuf())
end
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jReadO return catReadO(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt m.m.stream%%qualify
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.class.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m.m \== value('m.'m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset return fileLinuxListReset(m, arg, arg2)",
, "jOpen return fileLinuxListOpen(m, opt)",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
jclSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure jclSub
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
m.sqlO.cursors = left('', 10, 'r')left('', 30, ' ')
call sqlIni
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
"m.m.fetch = ''; m.m.type=''; m.m.cursor=''",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelRead(m, var)"
/* call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
*/ return
endProcedure sqlOini
sqlSel: procedure expose m.
parse arg src, type
return oNew('SqlSel', src, type)
endProcedure sqlSel
sqlSel1: procedure expose m.
parse arg src, type, var
r = jOpen(oNew('SqlSel', src, type), '<')
if \ jReadO(r, var) then
call err 'eof on 1. Read in sqlSel1'
if jReadO(r, sqlSql.ver) then
call err 'not eof on 2. Read in sqlSel1'
call jClose r
return
endProcedure sqlSel1
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor(m.m.cursor)
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
if m.m.type == '' then do
m.m.type = sqlDA2type('SQL.'m.m.cursor'.D')
m.m.fetch = ''
end
if m.m.fetch == '' then
m.m.fetch = sqlFetchVars(m.m.type, 'M.V')
m.m.jReading = 1
return m
endProcedure sqlOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg last
cx = 0
if datatype(last, 'n') & last>0 & last<=length(m.sqlO.cursors) then
if pos(substr(m.sqlo.cursors, last, 1), 'c ') > 0 then
cx = last
if cx == 0 then
cx = pos(' ', m.sqlo.cursors)
if cx == 0 then
cx = pos('c', m.sqlo.cursors)
if cx = 0 then
call err 'no more cursors' m.sqlo.cursors
m.sqlo.cursors = overlay('o', m.sqlo.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if cx < 1 | cx > length(m.sqlo.cursors) then
call err 'bad cursor sqlFreeCursor('cx')'
m.sqlo.cursors = overlay('c', m.sqlo.cursors, cx)
return cx
endProcedure sqlFreeCursor
/*--- create a type for a sqlDA --------------------------------------*/
sqlDA2type: procedure expose m.
parse arg da , ind
ff = ''
do ix=1 to m.da.sqlD
f1 = word(m.da.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
if (ind == 1 & m.da.ix.sqlType // 2 = 1) | ind == 2 then
ff = ff', f' f1' v, f' f1'.IND v'
else
ff = ff', f' f1 'v'
end
return classNew('n SQL* u' substr(ff, 3))
endProcedure sqlGenType
/*--- create the fetch vars sql syntx -------------------------------*/
sqlFetchVars: procedure expose m.
parse arg cla, pre
vv = ''
f = class4name(cla)'.FLDS'
la = '?'
do fx=1 to m.f.0
if la'.IND' \== m.f.fx then
vv = vv','
vv = vv ':'pre || m.f.fx
end
return substr(vv, 3)
endProcedure sqlFetchVars
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelRead: procedure expose m.
parse arg m, v
call oMutate v, m.m.type
return sqlFetchInto(m.m.cursor, m.m.fetch)
endProcedure sqlSelRead
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.out, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.out, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.out, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx retOk
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, retOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
return sqlExec("disconnect ", ggRet, 1)
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXECall(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy sleep begin ***************************************************/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
doClose = jOpenIfNotYet(m, opt)
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if doClose then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jRead(rdr, line)
call jWrite m, m.line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jReadO(rdr, line)
call jWriteO m, line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpenIfNotYet: procedure expose m.
parse arg m, opt
if opt == m.j.cRead & m.m.jReading then
return 0
if (opt == m.j.cWri | opt == m.j.cApp) & m.m.jWriting then
return 0
call jOpen m, opt
return 1
endProcedure jOpenIfNotYet
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
else
call err 'jClose' m 'but already closed'
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, mid
call jOpen m, '<'
if \ jRead(m, line) then
return ''
res = m.line
do while jRead(m, line)
res = res m.line
end
call jClose m
return res
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
m.j.cVar = '}'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, var) then return 0;" ,
"call oMutate arg, m.class.classV; return 1" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead if \ jReadO(m, 'J.GGVAR.'m) then return 0;" ,
"m.var = o2string('J.GGVAR.'m); return 1" ,
, "jReadO" am "jReadO('m',' var')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRW', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), '<')
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m, var)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufRun u JBuf, f RUNNER r", "m",
, "jOpen return jBufRunOpen(m, opt)",
, "jReset return jBufRunReset(m, arg)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
parse arg arg
return jReadO(m.j.in, arg)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
nx = mAdd(m'.BUF', line)
if \ m.m.allV then
m.class.o2c.nx = m.class.classV
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
m.class.o2c.m.buf.ax = m.class.classV
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl = m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
adr = m'.BUF.'ax
m.class.o2c.adr = m.class.classV
end
end
call oCopy ref, m'.BUF.'mInc(m'.BUF.0')
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
m.class.o2c.var = m.class.classV
end
else
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
end
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufRun: procedure expose m.
parse arg oRun
return oNew('JBufRun', oRun) /* calls jBufRunReset */
endProcedure jBufRun
jBufRunReset: procedure expose m.
parse arg m, m.m.runner
return m
endProcedure jBufRunReset
jBufRunOpen: procedure expose m.
parse arg m, opt
call jBufOpen m, m.j.cWri /* to avoid recursive loop in push| */
call pipeBeLa m.j.cWri m
call oRun m.m.runner
li = m.m.buf.0
call pipeEnd
call jBufOpen jClose(m), opt
m.m.buf.0 = li
return m
endProcedure jBufRunOpen
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return JBufRun(m)',
, 'm o2String return jCatLines(JBufRun(m), " ")'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do until m.cl = 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'n' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
r = oNew(classNew('n ORun* u', '\', 'ORun' ,
, 'm oRun call err "undefined method oRun in oRun"'))
if arg() > 0 then
call oRunnerCode r, arg(1)
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
call err 'o2String did not return'
endProcedure o2String
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
/*--- cast a String to an object or Null ---------------------------*/
s2oNull: procedure expose m.
parse arg str
if str == '' then
return ''
return m.class.escW || str
endProcedure s2oNull
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.)
is done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v string (value)
class expression (ce) allow the following syntax
ce = name | 'v' # value contains a string
| 'w' # string reference =m.class.escW||string
| 'o' # object: dynamic class lookup
| 'r' ce? # reference instance of ce default 'o'
| ('n' # names ce
| 'f' # field
| 'c') name ce # choice if value=name
| 's' ce # stem
| 'm' name code # method
| 'u' (ce (',' ce)*)? # union
# 'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('n v u v', 'm o2String return m.m',
, 'm o2File return file(m.m)')
m.class.escW = '!'
m.class.classW = classNew('n w u v',
, 'm o2String return substr(m, 2)',
, 'm o2File return file(substr(m, 2))')
m.class.classO = classNew('o')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c w w' ,
, 'c o o' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
srch = pos('\', opts) < 1
p = classPermanent(t, srch)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if \srch & p \== t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'vwo') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm == '' then
nm = 'o'
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if m.t = 'o' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
opt = left('K', m.map.keys.a \== '')
if opt == 'K' then
call mAdd m.map.Keys.a, ky
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(MARECLOA) cre=2009-10-08 mod=2009-10-08-17.12.30 A540769 ---
//YMARELOA JOB (CP00,KE50), 00010001
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//S1 EXEC PGM=DSNUTILB,PARM='DBZF,YMARELOA.LOAD' 00020001
//SYSMAP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSERR DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=DBZF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
EXEC SQL
DECLARE CUR1 CURSOR FOR
SELECT DB, TS, PA, TYP, TST, DSN FROM
(
SELECT '' DB, '' TS, -1 PA,
'' TYP, CURRENT TIMESTAMP TST, '' DSN
FROM SYSIBM.SYSCOPY
UNION ALL SELECT DBNAME DB, TSNAME TS, DSNUM PA,
ICTYPE TYP, TIMESTAMP TST, DSNAME DSN
FROM SYSIBM.SYSCOPY
WHERE ICTYPE IN ('I', 'F', 'R', 'S', 'W', 'Y')
UNION ALL SELECT DBNAME DB, TSNAME TS, PARTITION PA,
'c' TYP, CREATEDTS TST, '' DSN
FROM SYSIBM.SYSTABLEPART
) X
ENDEXEC
LOAD DATA INCURSOR CUR1 LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
SORTDEVT DISK SORTNUM 50
WORKDDN(TSYUTS,TSOUTS)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
INTO TABLE $MAREC.$COPY
}¢--- A540769.WK.REXX(MARECMON) cre=2009-10-07 mod=2011-04-13-17.32.30 A540769 ---
/* rexx ****************************************************************
maRecMon massRecovery Monitor Phase
Funktionen:
-DEBUG : DEBUG ON
-D : DISPLAY DB() TS() Liste für all/einzelne Jobs im Scope "MON#DISP"
-P : Progress Analyse "MON#PROG"
-S : Statusanzeige "MON#STAT"
-SQL:SQL Generierung (Select Statements) "MON#SQL1"
-U : DISPLAY UTILITY GESAMTE Liste für alle Jobs "MON#UTIL"
-US: DISPLAY UTILITY UEBERSICHT alle Jobs "MON#UTI2"
-V : Joboutput Analyse
***********************************************************************/
parse arg code
interpret code
call checkArgs v.args
xf_vars = 'LIB="'v.lib'"; ARGS="'v.args'"; DBSUB="'v.dbsub'"; ',
'JOBLIB="'v.joblib'"; MONLIB="'v.monlib'"; SHOWMBR="'v.showmbr'";',
'ar.help='ar.help'; ar.dbug='ar.dbug';'
say '???xf_vars' xf_vars
debug=0
if ar.dbug=1 then debug = 1
if debug then say 'MARECMON start at 'time()
if debug then say '----------------------------'
if debug then say ' '
/* JOBOUT Library allocieren falls sie noch nicht existiert */
if debug then say 'v.monlib='v.monlib
/* check if JOBOUT library is already allocated and allocate if not */
jobout_dsn = "'"v.monlib".JOBOUT'"
call alloc_jobout jobout_dsn
if ar.dbug=1 then do
say 'maRecMon code=' code;
say ' '
call sayVars;
say 'maRecMon xf_vars='xf_vars;
end
if ar.help=1 then do
call sayHelp;
end
if ar.utility=1 then do
call "MON#UTIL" xf_vars;
end
if ar.utility_overview=1 then do
call "MON#UTI2" xf_vars;
end
if ar.display=1 then do
call "MON#DISP" xf_vars;
end
if ar.status=1 then do
call "MON#STAT" xf_vars;
end
if ar.progress=1 then do
call "MON#PROG" xf_vars;
end
if ar.sqlgen=1 then do
call "MON#SQL1" xf_vars;
end
if debug then say 'MARECMON end at 'time()
if debug then say '----------------------------'
if debug then say ' '
exit 0
/*--------------------------------------------------------------------*/
sayVars: procedure expose v. /*$proc$*/
parse arg st
vars = 'VARS' v.vars
do wx=1 to words(vars)
v = word(vars, wx)
vf = v
if right(v, 2) \== '.*' then do
if length(vf) < 20 then
vf = left(vf, 20)
say vf '=' v.v
end
else do
v = left(v, length(v)-2)
say v'.* ('v.v.0')'
do y=1 to v.v.0
say left(' .'y, 20) '=' v.v.y
end
end
end
return
endProcedure sayVars
/* Argumente prüfen und Steuervariablen initialisieren */
checkArgs: procedure expose ar.
parse upper arg xx
ar.help=0
ar.dbug=0
ar.display=0
ar.check=0
ar.joboutput=0
ar.status=0
ar.utility=0
ar.utility_overview=0
ar.sqlgen=0
i=0
do until xx=''
parse upper var xx x ' ' y
if x='-?' | x='??' | x='HELP' then ar.help=1 /* ok */
if x='-DEBUG' then ar.dbug=1 /* ok */
if x='-D' then ar.display=1 /* ok */
if x='-V' then ar.check=1 /* fehlt noch */
if x='-J' then ar.joboutput=1 /* fehlt noch */
if x='-P' then ar.progress=1 /* in Arbeit */
if x='-S' | x=' ' | x='-SL' then ar.status=1 /* ok */
if x='-SQL' then ar.sqlgen=1 /* in Arbeit */
if x='-U' then ar.utility=1 /* ok */
if x='-US' then ar.utility_overview=1 /* ok ?? */
xx=y
i=i+1
end
return
endProcedure checkArgs
sayHelp:
say ' ';
say 'ARGUMENTS for MON phase of the MAREC macro:'
say ' '
say ' -debug activates display DEBUG information'
say ' ? or -? or ?? display HELP Information '
say ' '
say ' -p display Job Progress Report'
say ' -s display Job Status Report'
say ' -sl display extended Job Status Report (slow|)'
say ' '
say ' -sql generate SELECT statements to verify access is ok'
say ' '
say ' -d ¢ jobmum ! DISPLAY DB() TS() Report'
say ' -u ¢ jobnum ! DISPLAY UTILITY() Report'
say ' -us DISPLAY UTILITY() Overwiew Report'
say ' '
say ' -v ¢ jobnum ! verify RECOVER Output in SYSPRINT of Jobs'
say ' ';
return;
/**********************************************************************/
/** JOBOUT Library allozieren wenn noch keine existiert **/
/**********************************************************************/
alloc_jobout:
procedure expose v. debug
if debug then say ">> proc: alloc_jobout "
parse upper arg dsn
if debug then say '.. dsn='dsn
address tso;
check_dsn = Sysdsn(dsn)
If check_dsn ^= 'OK' Then do
/** Alloc JOBOUT DS, MGMTCLAS(COM#E035), no Archive, no backup **/
say '.. allocating a new 'dsn' ...';
"ALLOCATE FILE(JOBOUT) DATASET("dsn") NEW CATALOG ",
"SPACE(10,100) CYLINDERS",
"MGMTCLAS(COM#E035) STORCLAS(ALL$N) RECFM(V, B) ",
"LRECL(32756) BLKSIZE(32760) DSORG(PO) DSNTYPE(LIBRARY)"
If RC ^= 0 Then do
say " "
say "New ALLOC of "dsn" failed, RC="RC
say "please try again ..."
"FREE FI(CMDDN)"
return;
end;
end
else do
nop /* nix tun, wenn die JOBOUT Library existiert */
end
if debug then say ">> end proc: alloc_jobout "
return;
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- conditional expression -----------------------------------------*/
if: procedure
parse arg cond, true, false
if cond then
return true
else
return false
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(MARECRE) cre=2009-11-17 mod=2009-11-17-15.21.46 A540769 ---
$** copy ds to pds -----------------------------------------------------
out = 'DSN.MARECRE.PTAN.JOBOUT'
call csiOpen c, 'DSN.MAREC.PTA.TEST*.**'
do while csiNext(c, o)
k = substr(m.o, 19, 12)
mbr = 'L'substr(k, 3, 1)substr(k, 7, 2)substr(k, 11, 2)
say mbr k m.o
call readDsn m.o, i.
call writeDsn out'('mbr') ::v', i., , 1
end
/* call csiClose c */
$#end
$** rename members------------------------------------------------------
lib = 'DSN.MARECRE.DBZF.JOBOUT'
ll = lmmBegin(lib)
libIn = dsnSetMbr(mbrIn)
do ix=1
mbr = lmmNext(ll)
if mbr = '' then
leave
pIn = libIn'('mbr')'
if abbrev(mbr, 'ALL') then
iterate
call adrTso "rename '"lib"("mbr")' (Z"mbr")"
end
call lmmEnd ll
}¢--- A540769.WK.REXX(MARECSTK) cre=2009-09-24 mod=2010-01-14-15.31.41 A540769 ---
/*- rexx ---------------------------------------------------------------
maRec statistics:
analyze jes output members from recovery jobs
and write statistics per job in csv format
synopsis: maRecStk <inp> <out>
inp must be a pds and allows a member mask
----------------------------------------------------------------------*/
parse arg mbrIn dsOut
if mbrIn = '' | mbrIn = '-' then
mbrIn = 'DSN.MARECRE.JOBOUT(*)'
if dsOut = '' | dsOut = '-' then
dsOut = dsnSetMbr(mbrIn, 'ALL')
mbrIn = dsn2jcl(mbrIn, 0)
dsOut = dsn2jcl(dsOut, 0)
call errReset 'hI'
call adrEdit 'macro (arg)', '*'
call recStatsIni
call pipeIni
call pipeBeLa '>' s2o(dsOut)
call pipeBegin
ll = lmmBegin(dsn2jcl(mbrIn))
libIn = dsnSetMbr(mbrIn)
do ix=1
mbr = lmmNext(ll)
if mbr = '' then
leave
pIn = libIn'('mbr')'
if pIn = dsOut | abbrev(mbr, 'ALL') then do
say 'skipping' mbr
iterate
end
say ix 'analysing' pIn '.................'
call pipeBeLa '< !'pIn
call recStats a
m.a.member = mbr
call outO a
call pipeEnd
end
say 'rcst' (ix-1) 'members'
call pipeLast
call fmtFCsvAll
call pipeEnd
call pipeEnd
call lmmEnd ll
exit
recStatsIni: procedure expose m.
if m.recStats.ini == 1 then
return
call classIni
call classNew 'n RecStats u f MEMBER v, f JOB v, f SYSTEM v,' ,
'f PARTS v, f COPIES v, f PAGES v,' ,
'f RBARANGE v, f RBAZERO v,',
'f CPU v, f SRB v,' ,
'f ELAPSED v, f REST v, f APPLY v,' ,
'f REBU v, f REBURECS v, f REBUKEYS v, f STARTED v'
return
endProcedure recStatsIni
recStats: procedure expose m.
parse arg m
numeric digits 20
call oMutate m, 'RecStats'
m.m.parts = 0
m.m.pages = 0
m.m.copies = 0
m.m.rbaRange = 0
m.m.rbaZero = 0
m.m.timeBase = 0
m.m.timeLast = 0
m.m.restFirst = -1
m.m.restLast = m.m.restFirst
m.m.applyLast = m.m.restFirst
m.m.rebuFirst = m.m.restFirst
m.m.rebuLast = m.m.rebuFirst
m.m.rebuKeys = 0
m.m.rebuRecs = 0
sta = 0
do while in(line)
if sta = 0 then
if abbrev(m.line, 'DSNU532I ') ,
| abbrev(m.line, 'DSNU515I ') then do
m.m.restFirst = getTime(m, m.line)
m.m.restLast = m.m.restFirst
sta = 1
end
if abbrev(m.line, 'DSNU504I') then
call recStatsMerge m, line
if abbrev(m.line, 'DSNU513I') then
call recStatsRange m, line
if abbrev(m.line, 'DSNU1510I ') then do
m.m.applyLast = getTime(m, m.line)
sta = max(sta+1, 3)
if sta > 3 then
call err 'second logapply complete msg:' line
end
if abbrev(m.line, 'DSNU555I ') ,
| abbrev(m.line, 'DSNU393I ') ,
| abbrev(m.line, 'DSNU394I ') then do
if sta < 11 then do
call err 'sta' sta 'in line' m.line
m.m.rebuFirst = getTime(m, m.line, 4)
sta = 11
end
call rebuStats m, line
end
if abbrev(m.line, 'DSNU392I ') then do
if pos(' SORTBLD PHASE COMPLETE', m.line) < 1 then
call err 'bad sortbld complete line:' m.line
m.m.rebuLast = getTime(m, m.line)
end
if abbrev(m.line, 'DSNU050I ') then do
if pos(' REBUILD INDEX ', m.line) < 30 then
iterate
m.m.rebuFirst = getTime(m, m.line)
sta = max(sta+1, 11)
if sta > 11 then
call err 'second rebuild index msg:' line
end
if abbrev(m.line, 'IEF376I ') then
call recStatsEoj m, line
if substr(m.line, 11, 9) = ' IEF403I ' then
call recStatsStartJ m, line
if substr(m.line, 11, 9) = ' IEF404I ' then
call recStatsEndJ m, line
end
m.m.rest = -m.m.restFirst + m.m.restLast
m.m.apply = if(m.m.applyLast < 0, 0, -m.m.restLast + m.m.applyLast)
m.m.rebu = - m.m.rebuFirst + m.m.rebuLast
/* say m.m.rebuFirst '-' m.m.rebuLast 'recs' m.m.rebuRecs ,
'keys' m.m.rebuKeys
*/ return
endProcedure recStats
getTime: procedure expose m.
parse arg m, line
tiFo = word(line, 3)
parse var tiFo ho ':' mi ':' se
if \ (datatype(ho, 'n') & datatype(mi, 'n') & datatype(se, 'n')) then
call err 'bad utility time' tiFo 'in' line
ti = ((ho * 60) + mi) * 60 + se
if ti < m.m.timeLast then do
m.m.timeBase = m.m.timeBase + 86400
say 'dateSwitch' tiFo '(now +' (m.m.timeBase // 86400) 'days)'
end
m.m.timeLast = ti
return ti + m.m.timeBase
endProcedure getTime
recStatsMerge: procedure expose m.
parse arg m, li1
m.m.restLast = getTime(m, m.li1)
cx = pos('MERGE STATISTICS FOR', m.li1)
if cx < 1 then
call err 'no merge statistics for in line:' m.li1
parse value substr(m.li1, cx+21) with ty obj c1 dsnu .
if \ (in(li2) & in(li3)) then
call err '2 lines required after line:' m.li1
parse var m.li2 e2 'NUMBER OF COPIES=' cop .
if \ (e2 = '' & datatype(cop , 'N')) then
call err 'bad copies line after line:' m.li1
parse var m.li3 e3 'NUMBER OF PAGES MERGED=' pag .
if \ (e3 = '' & datatype(pag , 'N')) then
call err 'bad pages line 2 after line:' m.li1
/* say obj'/'c1 dsNu':' ty 'merged co' cop 'pag' pag */
m.m.parts = m.m.parts + 1
m.m.copies = m.m.copies + cop
m.m.pages = m.m.pages + pag
return
endProcedure recStatsMerge
recStatsRange: procedure expose m.
parse arg m, li1
parse var m.li1 e1 'LOG APPLY RANGE IS RBA' fR e1e 'LRSN' fL e1To
if fR = '' | e1e \= '' | fL = '' | e1To \= 'TO' ,
| verify(fR || fL, '0123456789ABCDEF') > 0 then
call err 'bad log apply range line:' m.li1
if \ in(li2) then
call err '1 line required after line:' m.li1
parse var m.li2 e2 'RBA' tR e2e 'LRSN' tL e2To
if e2 \= '' | tR = '' | e2e \= '' | tL = '' | e2To \= '' ,
| verify(tR || tL, '0123456789ABCDEF') > 0 then
call err 'bad log apply range to line:' m.li2
di = x2d(tR) - x2d(fR)
if fR = 0 | tR = 0 | di < 1 then do
say 'rba ZeroRange' fR '-' tR 'line' m.li1
m.m.rbaZero = m.m.rbaZero + 1
end
else do
m.m.rbaRange = m.m.rbaRange + di
end
return
endProcedure recStatsRange
recStatsEoj: procedure expose m.
parse arg m, li1
parse var m.li1 e1 'JOB/'job'/STOP' ti e2 'CPU' cMi 'MIN' cSe 'SEC',
'SRB' sMi 'MIN' sSe 'SEC'
if e2 \= '' | \datatype(cMi, 'n') | \datatype(cSe, 'n') ,
| \datatype(sMi, 'n') | \datatype(sSe, 'n') then
call err 'bad eoj line:' m.li1
m.m.cpu = 60*cMi + cSe
m.m.srb = 60*sMi + sSe
return
endProcedure recStatsEoj
recStatsStartJ: procedure expose m.
parse arg m, li1
parse var m.li1 bH ':' bM ':' bS e1 'IEF403I' jo e2,
'- STARTED -' ti sys e3
if \dataType(bH, 'n') | \dataType(bM, 'n') | \dataType(bS, 'n') ,
| e1 \='' | jo ='' | e2 \='' | ti ='' | sys ='' | e2 \='' then
call err 'bad job ... started line:' m.li1
m.m.system = sys
m.m.job = jo
m.m.started = strip(bH':'bM':'bS)
m.m.ended = strip(eH':'eM':'eS)
return
09:10:17 IEF403I A540769R - STARTED - TIME=09.10.17 S12
09:11:56 IEF404I A540769R - ENDED - TIME=09.11.56 S12
endProcedure recStatsStartJ
recStatsEndJ: procedure expose m.
parse arg m, li1
parse var m.li1 eH ':' eM ':' eS e1 'IEF404I' eJ e2 '- ENDED -' ti
if \dataType(eH, 'n') | \dataType(eM, 'n') | \dataType(eS, 'n') ,
| e1 \='' | eJ \= m.m.job | e2 \='' | ti ='' then
call err 'bad job ... ended line:' m.li2
parse var m.m.started bH ':' bM ':' bS
m.m.elapsed = ((eH * 60) + eM) * 60 + eS ,
- (((bH * 60) + bM) * 60 + bS)
return
endProcedure recStatsEndJ
rebuStats: procedure expose m.
parse arg m, line
if pos(' UNLOAD PHASE STATI', m.line) > 0 then do
cx = pos('RECORDS PROCESSED=', m.line)
if cx > 50 then do
c = strip(substr(m.line, cx+18))
m.m.rebuRecs = m.m.rebuRecs + c
return
end
end
if pos('- SORTBLD PHASE STATI', m.line) > 0 then do
cx = pos(' NUMBER OF KEYS=', m.line)
if cx > 50 then do
c = word(substr(m.line, cx+16), 1)
m.m.rebuKeys = m.m.rebuKeys + c
return
end
end
call err 'bad rebuild stats line' m.line
endProcedure rebuStats
/* rexx ****************************************************************
wsh
compiler directives $# ('|' | '<')? <kind>
$# ( 'end' | 'out' )
field access for getVars mit |
kind # mit filter (c=cut, j=strip and join ...)
inline Data mit $#</ und filter wie oben
Ideen: writeFramed: eliminieren von rdr abhängig machen ?|
Ideen: String --> ref mit Prefix done
buf mit copy semantics bufR mit refs noch implementieren
block mit lokalen geschachtelten Variabeln
run von JRW wegnehmen --> nein,
braeuchte wieder Fallunterscheidung in run
mapVia: eliminieren oder besser unterstützen?
pipe aus rexx (kürzer als pipeBegin ... pipeLast ... pipeEnd)
pipeAllFramed richtig testen (auch nested)
cat optimieren mit recursive nextRdr (DelegationsKette kürzen)
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
parse arg spec
os = errOS()
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done spec
if done then
return
end
spec = wshFun(spec)
if spec == '$' then
return
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = '-wsh'
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
end
end
else if os == 'LINUX' then do
inp = '&in'
out = '&out'
end
else
call err 'implemnt wsh for os' os
call compRun spec, inp, out
exit 0
wshFun: procedure expose m.
parse arg fun rest
call scanIni
f1 = translate(fun)
sx = verify(f1, m.scan.alfNum)
if sx = 2 | sx = 1 then do
f1 = left(f1, 1)
rest = substr(fun, 2) rest
end
if f1 = 'T' then
call wshTst rest
else if f1 = 'I' then
call wshInter rest
else if f1 = '?' then
return 'call pipePreSuf' rest '$<$#='
else
return arg(1)
return '$'
endProcedure wshFun
tstSqlO1: procedure expose m.
call sqlOIni
call sqlConnect dbaf
sq = sqlSel("select strip(name) from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 1")
do 2
call jOpen sq, m.j.cRead
do while jRead(sq, abc)
call outO abc
end
call jClose sq
end
call sqlDisconnect
return 0
endProcedure tstSqlO1
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call tstSqlO1
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- compRun: compile shell or data from inp and
run it to output out -----------------------------------*/
compRun: procedure expose m.
parse arg spec, inp, out
if inp == '' then
cmp= comp()
else
cmp= comp(file(inp))
r = compile(cmp, spec)
if out \== '' then
call pipeBeLa '>' s2o(out)
call oRun r
if out \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '|:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '|' then
return
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ':' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
end
say 'enter' mode 'expression, | for end, : or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
else
out = ''
call wshBatch ty, '-wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if sysvar('sysISPF') \= 'ACTIVE' then
return 0
if adrEdit('macro (mArgs) NOPROCESS', '*') \== 0 then
return 0
spec = wshFun(mArgs)
if spec == '$' then
return 1
if spec == '' & dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then do
call tstAct
return 0
end
call wshIni
o = jOpen(jBuf(), '>')
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
say 'range' rFi '-' rLa
end
else do
rFi = ''
say 'no range'
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
say 'dest' dst
end
else do
dst = ''
say 'no dest'
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
call jWrite o, left(li, 50) date('s') time()
end
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
i = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, spec)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call pipeBegin
call oRun r
call pipeLast '>' o
do while inO(obj)
call objOut(obj)
end
call pipeEnd
lab = wshEditInsLinSt(dst, 0, , o'.BUF')
if dst \= '' then
call wshEditLocate max(1, dst-7)
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
call outPush mCut(ggStem, 0)
call errSay 'compErr' ggTxt
call outPop
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst, 1, , so'.BUF')
call outPush mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst, 1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
call tstZos
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql /* wkTst??? noch einbauen|||
call tstSqlO
call tstSqlEnv */
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*<<tstSorQ
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSorQ */
/*<<tstSorQAscii
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSorQAscii */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*<<tstSort
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSort */
/*<<tstSortAscii
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSortAscii */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*<<tstMatch
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlIni
call jIni
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, :M.+
STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
call tst t, "tstSqlO",
, "*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAM",
|| "E ",
, " e 1: warnings",
, " e 2: state 42704",
, " e 3: stmt = execSql prepare s7 from :src",
, " e 4: with src = select * from sysdummy",
, "REQD=Y col=123 case=--- col5=anonym",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call out 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call out fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call out oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
call tst t, "tstSqlEnv",
, "REQD=Y COL2=123 case=--- COL5=anonym",
, "sql fmtFldRw sl<15",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "sql fmtFldSquashRW",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn sl=",
, "COL1 T DBNAME COL4 ",
, "SYSTABAUTH T DSNDB06 SYSDBASE"
call mAdd t.cmp,
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_ T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn ---",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
call pipeBegin
call out 'select d.*, 123, current timestamp "jetzt und heute",'
call out 'case when 1=0 then 1 else null end caseNull,'
call out "'anonym'"
call out 'from sysibm.sysdummy1 d'
call pipe
call sql 13
call pipeLast
do while envRead(abc)
call out 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call pipeEnd
call out 'sql fmtFldRw sl<15'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call pipeEnd
call out 'sql fmtFldSquashRW'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldSquashRW
call pipeEnd
call out 'sqlLn sl='
call pipeBegin
call out 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13, , ,'sl='
call pipeEnd
call out 'sqlLn ---'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13
call pipeEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*<<tstCompDataConst
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
tstCompDataConst */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*<<tstCompDataConstBefAftComm1
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
tstCompDataConstBefAftComm1 */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*<<tstCompDataConstBefAftComm2
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
tstCompDataConstBefAftComm2 */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*<<tstCompDataVars
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-$.{""$v1} = valueV1; .
tstCompDataVars */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-$.{""""$v1} =" $-$.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*<<tstCompShell
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
tstCompShell */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*<<tstCompShell2
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
tstCompShell2 */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*<<tstCompPrimary
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
tstCompPrimary */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*<<tstCompExprStr
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
tstCompExprStr */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*<<tstCompExprObj
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
tstCompExprObj */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*<<tstCompExprDat
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.$-{"abc"}=!abc
tstCompExprDat */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.$-{""abc""}="$.$-{"abc"}'
/*<<tstCompExprRun
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
tstCompExprRun */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*<<tstCompExprCon
tstCompExprCon */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*<<tstCompStmt1
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
tstCompStmt1 */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*<<tstCompStmt2
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
tstCompStmt2 */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*<<tstCompStmt3
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
tstCompStmt3 */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*<<tstCompStmtDo
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
tstCompStmtDo */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*<<tstCompStmtDo2
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
tstCompStmtDo2 */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*<<tstCompSynPri1
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
tstCompSynPri1 */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*<<tstCompSynPri2
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
tstCompSynPri2 */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*<<tstCompSynPri3
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
tstCompSynPri3 */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*<<tstCompSynPri4
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
tstCompSynPri4 */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*<<tstCompSynFile
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@$.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 18 in line 1: $@$.<$*( co1 $*) $$abc
tstCompSynFile */
call tstComp1 '@ tstCompSynFile +', '$@$.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*<<tstCompSynAss1
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
tstCompSynAss1 */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*<<tstCompSynAss2
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
tstCompSynAss2 */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*<<tstCompSynAss3
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
tstCompSynAss3 */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*<<tstCompSynAss4
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
tstCompSynAss4 */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*<<tstCompSynAss5
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
tstCompSynAss5 */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*<<tstCompSynAss6
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
tstCompSynAss6 */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*<<tstCompSynAss7
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
tstCompSynAss7 */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*<<tstCompSynRun1
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
tstCompSynRun1 */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*<<tstCompSynRun2
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
tstCompSynRun2 */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*<<tstCompSynRun3
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@ =
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@ =
tstCompSynRun3 */
call tstComp1 '@ tstCompSynRun3 +', '$@ ='
/*<<tstCompSynFor4
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
tstCompSynFor4 */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*<<tstCompSynFor5
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
tstCompSynFor5 */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*<<tstCompSynFor6
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
tstCompSynFor6 */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*<<tstCompSynFor7
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
tstCompSynFor7 */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*<<tstCompSynCt8
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
tstCompSynCt8 */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*<<tstCompSynProc9
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
tstCompSynProc9 */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*<<tstCompSynProcA
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
tstCompSynProcA */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*<<tstCompSynCallB
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
tstCompSynCallB */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*<<tstCompSynCallC
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
tstCompSynCallC */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*<<tstCompSynCallD
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
tstCompSynCallD */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*<<tstCompObjRef
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla union = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
tstCompObjRef */
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*<<tstCompObjRefPri
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
tstCompObjRefPri */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*<<tstCompObjRefFile
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
tstCompObjRefFile */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<{ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*<<tstCompObjRun
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
tstCompObjRun */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
return
/*<<tstCompObj
### start tst tstCompObj ##########################################
compile @, 8 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
out .¢ o1, o2!
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
tstCompObj */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompDataIO: procedure expose m.
/*<<tstCompDataHereData
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
tstCompDataHereData */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*<<tstCompDataIO
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@$.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
tstCompDataIO */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = dsn tstFB('::F37', 0)
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
call tstComp1 '= tstCompDataIO',
, ' input 1 $@$.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@$.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*<<tstCompFileBloSrc
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+.
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
tstCompFileBloSrc */
/*<<tstCompFileBlo
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @LINE isA :TstClassVF union = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @LINE isA :TstClassVF union = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @LINE isA :TstClassVF union = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @LINE isA :TstClassVF union = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @LINE isA :TstClassVF union = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @LINE isA :TstClassVF union = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @LINE isA :TstClassVF union = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @LINE isA :TstClassVF union = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
tstCompFileBlo */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*<<tstCompFileObjSrc
$=vv=value-vv-1
$=fE=.$.<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@$.<$dsn
tstCompFileObjSrc */
/*<<tstCompFileObj
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-2
tstR: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
tstCompFileObj */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*<<tstCompPipe1
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
tstCompPipe1 */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*<<tstCompPipe2
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
tstCompPipe2 */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*<<tstCompPipe3
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
tstCompPipe3 */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*<<tstCompPipe4
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
tstCompPipe4 */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*<<tstCompRedir
### start tst tstCompRedir ########################################
compile @, 6 lines: $>}eins $@for vv $$<$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>}eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<}eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*<<tstCompCompShell
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
tstCompCompShell */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*<<tstCompCompData
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
tstCompCompData */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*<<tstCompDirSrc
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
tstCompDirSrc */
/*<<tstCompDir
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
tstCompDir */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*<<tstCompDirPiSrc
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@$#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
tstCompDirPiSrc */
/*<<tstCompDirPi
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$.$#=, 5 lines: zeile +
1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
tstCompDirPi */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$.$#="
return
endProcedure tstCompDir
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*<<tstTstSayEins
### start tst tstTstSayEins #######################################
test eins einzige testZeile
tstTstSayEins */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
/*<<tstTstSayDrei
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
tstTstSayDrei */
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
tstM */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*<<tstMap
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 nicht gefunden
tstMap */
/*<<tstMapInline1
inline1 eins
inline1 drei
tstMapInline1 */
/*<<tstMapInline2
inline2 eins
tstMapInline2 */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3',
, 'nicht gefunden')
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*<<tstMapVia
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
tstMapVia */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*<<tstClass2old
### start tst tstClass2 ###########################################
@CLASS.8 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.7 :class union
. choice u stem 9
. .1 refTo @CLASS.15 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.16 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.10 :class union
. choice r .CLASS refTo @CLASS.8 done :class @CLASS.8
. .3 refTo @CLASS.17 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .4 refTo @CLASS.19 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.18 :class union
. choice s .CLASS refTo @CLASS.10 done :class @CLASS.10
. .5 refTo @CLASS.20 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.12 :class union
. choice u stem 2
. .1 refTo @CLASS.9 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.21 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .7 refTo @CLASS.22 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.23 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.14 :class union
. choice u stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.13 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .9 refTo @CLASS.26 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.25 :class union
. choice n union
. .NAME = w
. .CLASS refTo @CLASS.24 :class union
. choice r .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2old */
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.13 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.12 :class union
. choice u stem 10
. .1 refTo @CLASS.20 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.22 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.21 :class union
. choice w } LASS.21
. .3 refTo @CLASS.23 :class union
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.10 :class union
. choice o obj has no class @o
. .4 refTo @CLASS.24 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.16 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.15 :class union
. choice r .CLASS refTo @CLASS.13 done :class @CLASS.13
. .5 refTo @CLASS.25 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.16 done :class @CLASS.16
. .6 refTo @CLASS.27 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.26 :class union
. choice s .CLASS refTo @CLASS.15 done :class @CLASS.15
. .7 refTo @CLASS.28 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.17 :class union
. choice u stem 2
. .1 refTo @CLASS.14 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.16 done :class @CLASS.16
. .8 refTo @CLASS.29 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .9 refTo @CLASS.30 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .10 refTo @CLASS.31 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.19 :class union
. choice u stem 2
. .1 refTo @CLASS.14 done :class @CLASS.14
. .2 refTo @CLASS.18 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2 */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
tstClass */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n tstClassTf12 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12,' ,
's u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,'*** err: basicClass v' ,
'end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"')
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 n =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 n =className= TstOElf
C4 n =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
tstO */
call tst t, 'tstO'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWOut.jOpen(<obj s of JRWOut>, open<Arg)
*** err: jWrite(<obj s of JRWOut>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
tstJSay */
call jIni
call tst t, 'tstJSay'
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jOpen s, 'open<Arg'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*<<tstJ
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
*** err: already opened jOpen(<buf b>, <)
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
tstJ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*<<tstJ2
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
call tst t, "tstJ2"
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jReadO(b, res)
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), '<'
do while jReadO(c, ccc)
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*<<tstCat
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
tstCat */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*<<tstEnv
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
tstEnv */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipeBeLa '<' b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*<<tstEnvCat
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
tstEnvCat */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipeBeLa '<' b0, '<' b1, '<' b2, '<' c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa '<' c1
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*<<tstPipe
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
tstPipe */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1|FLD')
call pipeBeLa '>' s2o('}theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa '<' s2o('}theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
tstPipeLazy: procedure expose m.
call pipeIni
/*<<tstPipeLazy
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAllFramed *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAllFramed in inIx 0
a2 vor writeAllFramed jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAllFramed in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAllFramed ***
b1 vor barBegin lazy 1 writeAllFramed *** <class TstPipeLazyRdr>
b4 vor writeAllFramed
b2 vor writeAllFramed rdr inIx 1
RdrOpen <
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAllFramed ***
tstPipeLazy */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr"; return in(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
if lz then
call mAdd t'.TRANS', m.j.out '<barBegin out>'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*<<tstEnvClass
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAllFramed *** TY
a5 vor writeAllFramed
a1 vor jBuf()
a2 vor writeAllFramed b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAllFramed
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAllFramed ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
t10 = classNew('n TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n TstEnvClass20 u v, f f24 v, f F25 v')
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*<<tstFile
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
tstFile */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa '<' s2o(tstPdsMbr(pd2, 'eins')), '<' b,
,'<' jBuf(),
,'<' s2o(tstPdsMbr(pd2, 'zwei')),
,'<' s2o(tstPdsMbr(pds, 'wr0')),
,'<' s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
tstFileList */
/*<<tstFileListTSO
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
tstFileListTSO */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
call pipeIni
/*<<tstFmt
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
tstFmt */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFWriteAll fmtFreset(abc), b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, b
call tstEnd t
return
endProcedure tstFmt
tstScan: procedure expose m.
/*<<tstScan.1
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
tstScan.1 */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.2
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
tstScan.2 */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.3
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
tstScan.3 */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*<<tstScan.4
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
tstScan.4 */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*<<tstScan.5
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*<<tstScanRead
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
tstScanRead */
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*<<tstScanReadMitSpaceLn
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
tstScanReadMitSpaceLn */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*<<tstScanJRead
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*<<tstScanWin
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
tstScanWin */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*<<tstScanWinRead
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*<<tstScanSqlId
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
tstScanSqlId */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlDelimited
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
tstScanSqlDelimited */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlQualified
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
tstScanSqlQualified */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNum
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
tstScanSqlNum */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNumUnit
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
tstScanSqlNumUnit */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa '<' m, '>' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '/*<<'name
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say name '*/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
m.class.o2c.arg = m.class.classV
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
m.tstErrHandler.0 = 0
call outPush tstErrHandler
call errSay ggTxt
call outPop
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m, var)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v,'
end
t = classNew('n tstData* u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, rdr, wiTi
b = env2buf(rdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
say ' ' newFo
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = src
return nn
endProcedure comp
m.nn.cmpRdr = scanRead(src)
return compReset(nn, src)
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@'
m.m.chKinC = '.-=@'
return m
endProcedure compReset
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
s = m.m.scan
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKinC) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc s, spec
call compSpComment m
m.m.dirKind = kind
m.m.compSpec = 1
res = oRunner()
nxt = res
doClose = 0
do cx=1 to 100
m.m.dir = ''
kind = m.m.dirKind
if kind == '@' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = comp2Code(m, ';'compShell(m))
end
else do
what = "data("kind")";
expec = "sExpression or block";
src = comp2Code(m, ';'compData(m, kind))
end
if m.m.dir == '' then
call compDirective m
if m.m.dir == '' then
return scanErr(s, expec "expected: compile" what ,
" stopped before end of input")
if abbrev(m.m.dir, '$#') then
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan 'directive' m.m.dir 'mismatch'
if src \== '' then do
call oRunnerCode nxt, src
nxt = m.m.dirNext
end
if wordPos(m.m.dir, 'eof next $#end $#out') > 0 then do
if doClose then
call jClose s
if m.m.dir \== 'next' | \ m.m.compSpec then
return res
call scanReadReset s, m.m.cmpRdr
doClose = jOpenIfNotYet(s)
m.m.compSpec = 0
end
end
call scanErr s, 'loop in compile'
endProcedure compile
compDirective: procedure expose m.
parse arg m, ki
if m.m.dir \== '' then
return ''
lk = scanLook(m.m.scan, 9)
if abbrev(lk, '$#') then do
if pos(substr(lk, 3, 1), m.m.chKinC) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if abbrev(lk, '$#end') then do
m.m.dir = 'eof'
return ''
end
else
call scanErr m.m.scan, 'bad directive after $#'
end
else if scanAtEnd(m.m.scan) then do
if \ m.m.compSpec | m.m.cmpRdr == '' then do
m.m.dir = 'eof'
return ''
end
m.m.dir = 'next'
end
else do
return ''
end
m.m.dirNext = oRunner()
if ki == '@' then
return "; call oRun '"m.m.dirNext"'"
else
return ". '"m.m.dirNext"'"
endProcedure compDirective
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compNewStem(m)
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return 'l*' lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res || one
if \ scanLit(m.m.scan, '$;') then
return res
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsb') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock, m.m.chDol)
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' then
nn = 'call outO' expr
else if fr == '<' then
nn = 'call pipeWriteAll ' expr
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' to 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ $l $0'
to.2 = '= - . < ; ( (- (. (; < ; @ @ $ $'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; <(; '
to.3 = ' 0; l; - - . . ; <; '
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 & trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/* wkTst???syntax start */
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = comp2Code(m, '-'compCheckNE(m,
, compExpr(m, 'b', '='), "variable name after $="))
if \ scanLit(s, "=") then
call scanErr s, '= expected after $=' nm
vl = compCheckNE(m, compBlockExpr(m, '='),
, 'block or expression after $=' nm '=')
if abbrev(vl, '-') then
return '; call envPut' nm',' comp2Code(m, vl)
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNN(m, compObj(m, '@'),
, "objRef expected after $@"))
fu = m.s.tok
if fu == 'for' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m),
, "statement after $@for" v))
return '; do while envReadO('v');' st'; end'
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
suf = comp2Code(m, ':'compCheckNE(m, compExpr(m, 's', ';'),
, "$@do control construct"))
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInterEx(comp2Code(m, '-'nm)), st
return '; '
end
if \ scanLit(s, '(') then
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '$$') then
return compCheckNN(m, compBlockExpr(m, '='),
, 'block or expression expected after $$')
return compDirective(m, '@')
endProcedure compStmt
/* wkTst???syntax end */
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
compInterEx: procedure expose m.
interpret 'return' arg(1)
endProcedure compInterEx
compBlockExpr: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compBlock(m, ki)
if res \== '' then
return res
lk = scanLook(s, 1)
if pos(lk, m.m.chKind) > 0 then
call scanChar s, 1
else
lk = ki
return compExpr(m, 's', lk)
endProcedure compBlockExpr
compObj: procedure expose m.
parse arg m, ki
one = compPrimary(m, translate(ki, '.', '@'))
if one \== '' then
return one
ki = translate(ki, ';', '@')
one = compBlock(m, ki)
if one \== '' then
return ki || one
s = m.m.scan
if scanLit(s, '<') then
return compFile(m)
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKind) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return ki'. compile(comp(env2Buf()), "'m.s.tok'")'
end
return compDirective(m, ki)
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compBlock(m, '=')
if res \== '' then
return '<;'res
s = m.m.scan
ki = scanLook(s, 1)
if pos(ki, m.m.chKind) > 0 then do
call scanLit s, ki
end
else do
ki = '='
res = compDirective(m, '.')
if res \== '' then
return '<'res
end
res = compCheckNE(m, compExpr(m, 's', ki),
, 'block or expr expected for file')
return '<'res
endProcedure compFile
compBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
t2 = scanLook(s, 2)
hasType = pos(left(t2, 1) , m.m.chKind) > 0
start = substr(t2, hasType+1, 1)
if pos(start, '{¢/') < 1 then
return ''
if hasType then
ki = translate(left(t2, 1), ';', '@')
if \ scanLit(s, left(t2, hasType+1)) then
call scanErr s, 'compBlock internal 1'
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
if start == '{' then do
res = compNewStem(m)
if ki == '#' then do
tx = '= '
cb = 1
do forever
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
call mAdd res, tx
end
else do
one = compExpr(m, 'b', ki)
if one \== '' & \ abbrev(one, 'e') then
call mAdd res, one
end
res = 'l*' res
end
else if ki == '#' then do
res = compNewStem(m)
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after' starter
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after' starter
end
res = 'l*' res
end
else if ki == ';' then do
call compSpNlComment m
res = compShell(m)
end
else if ki == '@' then do
call err 'compBlock bad ki' ki
end
else do
res = compData(m, ki)
if res == '' then
res = 'l*' compNewStem(m)
end
if \ scanLit(s, stopper) then
call scanErr s, 'ending' stopper 'expected after' starter
if res = '' then
return '('ki
else
return '('res
endProcedure compBlock
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
e1 = left(ex, 1)
return ex = '' | pos(e1, 'ce') > 0 | e1 = ex
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
sp = 0
co = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else
leave
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose if m.m.closeRdr then call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
m.m.closeRdr = jOpenIfNotYet(m.m.rdr, m.j.cRead)
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call classNew "n PipeFramedRdr u JRWO", "m",
, "jOpen call jOpen never-call-PipeFramedRdr-Open",
, "jReadO call pipePushFrame m;" ,
"res = jReadO(m.m.framedRdr, var);",
"call pipeEnd; return res",
, "jReset never-call-PipeFramedRdr-jReset",
, "jClose call pipeFramedClose m"
call mapReset env.vars
call jReset oMutate("PIPE.framedNoOut", "JRWErr")
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
else if jOpenIfNotYet(m.e.in, m.j.cRead) then
m.e.toClose = m.e.toClose m.e.in
if m.e.out == '' then
m.e.out = m.j.out
else if jOpenIfNotYet(m.e.out, m.e.outOp) then
m.e.toClose = m.e.toClose m.e.out
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
m.e.allInFrame = 1
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, '<')
m.f.out = jOpen(Cat(), '>')
m.f.toClose = m.f.in m.f.out
m.j.in = m.f.in
m.j.out = m.f.out
m.e.allInFrame = 1
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
m.f.allInFrame = 1
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
m.f.allInFrame = m.preF.allInFrame
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFramedRdr: procedure expose m.
parse arg e
m = pipeFrame()
m.m.jReading = 1
m.m.jWriting = 0
m.m.framedRdr = jOpen(jClose(m.e.out), m.j.cRead)
say 'framedRdr <' m.m.framedRdr
m.m.in = m.e.in
m.m.framedToClose = m.e.toClose
m.e.toClose = ''
m.m.out = "PIPE.framedNoOut"
call oMutate m, 'PipeFramedRdr'
return m
endProcedure pipeFramedRdr
pipeFramedClose: procedure expose m.
parse arg m
m.m.allInFrame = 0
call pipeClose m
call oMutate m, 'PipeFrame'
return
endProcedure pipeFramedClose
pipeFrame: procedure expose m.
m = oBasicNew("PipeFrame")
m.m.toClose = ''
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = ''
m.m.allInFrame = 0
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
if m.m.allInFrame == 2 then
return pipeFramedRdr(m)
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
/*--- write all from rdr (rsp in) to out, possibly lazy
do lazy reads within current frame -----------*/
pipeWriteAllFramed: procedure expose m.
parse arg rdr
if rdr == '' then
rdr = m.j.in
px = m.pipe.0
f = m.pipe.px
if m.f.allInFrame = 0 then do
call jWriteNow m.j.out, rdr
return
end
m.f.allInFrame = 2
call jWriteall m.j.out, rdr
return
endProcedure pipeWriteFramed
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outPush: procedure expose m.
parse arg st
call pipeBeLa '>' oNew('JRWOut', st)
return
endProcedure outPush
outPop: procedure expose m.
call pipeEnd
return
endProcedure outPop
/*--- write all from rdr (rsp in) to a new jBuf --------------------*/
env2Buf: procedure expose m. /*wkTst remove |||| */
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, if(rdr=='', m.j.in, rdr)
return jClose(b)
endProcedure env2Buf
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGetO: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envGet: procedure expose m.
parse arg na
return o2String(mapGet(env.vars, na))
endProcedure envGet
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
if \ inO("ENV.VARS.OBJ."na) then
return 0
call envPutO na, "ENV.VARS.OBJ."na
return 1
if \ inO('ENV.XX') then
return 0
call envPut na, m.env.xx
return 1
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na) /*wkTst??? remove?*/
envPutO: procedure expose m.
parse arg na, ref
return mapPut(env.vars, na, ref)
envPut: procedure expose m.
parse arg na, va
call mapPut env.vars, na, s2o(va)
return va
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catRdClose = 0
m.m.catIx = -9e9
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
if m.m.catRdClose then
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' & m.m.catRdClose then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
m.m.catRdClose = jOpenIfNotYet(m.m.catRd , m.j.cRead)
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jReadO(m.m.catRd, var) then
return 1
call catNextRdr m
end
return 0
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
call mAdd m'.RWS', o2File(arg(ax))
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
if abbrev(str, m.j.cVar) then do
var = substr(str, 2)
if envHasKey(var) then
return envGetO(var)
else
return envPutO(var, jBuf())
end
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jReadO return catReadO(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt m.m.stream%%qualify
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.class.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m.m \== value('m.'m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset return fileLinuxListReset(m, arg, arg2)",
, "jOpen return fileLinuxListOpen(m, opt)",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
jclSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure jclSub
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
m.sqlO.cursors = left('', 10, 'r')left('', 30, ' ')
call sqlIni
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
"m.m.fetch = ''; m.m.type=''; m.m.cursor=''",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelRead(m, var)"
/* call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
*/ return
endProcedure sqlOini
sqlSel: procedure expose m.
parse arg src, type
return oNew('SqlSel', src, type)
endProcedure sqlSel
sqlSel1: procedure expose m.
parse arg src, type, var
r = jOpen(oNew('SqlSel', src, type), '<')
if \ jReadO(r, var) then
call err 'eof on 1. Read in sqlSel1'
if jReadO(r, sqlSql.ver) then
call err 'not eof on 2. Read in sqlSel1'
call jClose r
return
endProcedure sqlSel1
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor(m.m.cursor)
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
if m.m.type == '' then do
m.m.type = sqlDA2type('SQL.'m.m.cursor'.D')
m.m.fetch = ''
end
if m.m.fetch == '' then
m.m.fetch = sqlFetchVars(m.m.type, 'M.V')
m.m.jReading = 1
return m
endProcedure sqlOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg last
cx = 0
if datatype(last, 'n') & last>0 & last<=length(m.sqlO.cursors) then
if pos(substr(m.sqlo.cursors, last, 1), 'c ') > 0 then
cx = last
if cx == 0 then
cx = pos(' ', m.sqlo.cursors)
if cx == 0 then
cx = pos('c', m.sqlo.cursors)
if cx = 0 then
call err 'no more cursors' m.sqlo.cursors
m.sqlo.cursors = overlay('o', m.sqlo.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if cx < 1 | cx > length(m.sqlo.cursors) then
call err 'bad cursor sqlFreeCursor('cx')'
m.sqlo.cursors = overlay('c', m.sqlo.cursors, cx)
return cx
endProcedure sqlFreeCursor
/*--- create a type for a sqlDA --------------------------------------*/
sqlDA2type: procedure expose m.
parse arg da , ind
ff = ''
do ix=1 to m.da.sqlD
f1 = word(m.da.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
if (ind == 1 & m.da.ix.sqlType // 2 = 1) | ind == 2 then
ff = ff', f' f1' v, f' f1'.IND v'
else
ff = ff', f' f1 'v'
end
return classNew('n SQL* u' substr(ff, 3))
endProcedure sqlGenType
/*--- create the fetch vars sql syntx -------------------------------*/
sqlFetchVars: procedure expose m.
parse arg cla, pre
vv = ''
f = class4name(cla)'.FLDS'
la = '?'
do fx=1 to m.f.0
if la'.IND' \== m.f.fx then
vv = vv','
vv = vv ':'pre || m.f.fx
end
return substr(vv, 3)
endProcedure sqlFetchVars
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelRead: procedure expose m.
parse arg m, v
call oMutate v, m.m.type
return sqlFetchInto(m.m.cursor, m.m.fetch)
endProcedure sqlSelRead
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.out, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.out, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.out, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx retOk
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, retOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
return sqlExec("disconnect ", ggRet, 1)
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
alRc = adrTso(c rest, '*')
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy sleep begin ***************************************************/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
doClose = jOpenIfNotYet(m, opt)
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if doClose then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jRead(rdr, line)
call jWrite m, m.line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jReadO(rdr, line)
call jWriteO m, line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpenIfNotYet: procedure expose m.
parse arg m, opt
if opt == m.j.cRead & m.m.jReading then
return 0
if (opt == m.j.cWri | opt == m.j.cApp) & m.m.jWriting then
return 0
call jOpen m, opt
return 1
endProcedure jOpenIfNotYet
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
else
call err 'jClose' m 'but already closed'
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, mid
call jOpen m, '<'
if \ jRead(m, line) then
return ''
res = m.line
do while jRead(m, line)
res = res m.line
end
call jClose m
return res
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
m.j.cVar = '}'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, var) then return 0;" ,
"call oMutate arg, m.class.classV; return 1" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead if \ jReadO(m, 'J.GGVAR.'m) then return 0;" ,
"m.var = o2string('J.GGVAR.'m); return 1" ,
, "jReadO" am "jReadO('m',' var')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRW', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), '<')
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m, var)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufRun u JBuf, f RUNNER r", "m",
, "jOpen return jBufRunOpen(m, opt)",
, "jReset return jBufRunReset(m, arg)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
parse arg arg
return jReadO(m.j.in, arg)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
nx = mAdd(m'.BUF', line)
if \ m.m.allV then
m.class.o2c.nx = m.class.classV
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
m.class.o2c.m.buf.ax = m.class.classV
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl = m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
adr = m'.BUF.'ax
m.class.o2c.adr = m.class.classV
end
end
call oCopy ref, m'.BUF.'mInc(m'.BUF.0')
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
m.class.o2c.var = m.class.classV
end
else
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
end
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufRun: procedure expose m.
parse arg oRun
return oNew('JBufRun', oRun) /* calls jBufRunReset */
endProcedure jBufRun
jBufRunReset: procedure expose m.
parse arg m, m.m.runner
return m
endProcedure jBufRunReset
jBufRunOpen: procedure expose m.
parse arg m, opt
call jBufOpen m, m.j.cWri /* to avoid recursive loop in push| */
call pipeBeLa m.j.cWri m
call oRun m.m.runner
li = m.m.buf.0
call pipeEnd
call jBufOpen jClose(m), opt
m.m.buf.0 = li
return m
endProcedure jBufRunOpen
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return JBufRun(m)',
, 'm o2String return jCatLines(JBufRun(m), " ")'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do until m.cl = 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'n' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
r = oNew(classNew('n ORun* u', '\', 'ORun' ,
, 'm oRun call err "undefined method oRun in oRun"'))
if arg() > 0 then
call oRunnerCode r, arg(1)
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
call err 'o2String did not return'
endProcedure o2String
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.)
is done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v string (value)
class expression (ce) allow the following syntax
ce = name | 'v' # value contains a string
| 'w' # string reference =m.class.escW||string
| 'o' # object: dynamic class lookup
| 'r' ce? # reference instance of ce default 'o'
| ('n' # names ce
| 'f' # field
| 'c') name ce # choice if value=name
| 's' ce # stem
| 'm' name code # method
| 'u' (ce (',' ce)*)? # union
# 'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('n v u v', 'm o2String return m.m',
, 'm o2File return file(m.m)')
m.class.escW = '!'
m.class.classW = classNew('n w u v',
, 'm o2String return substr(m, 2)',
, 'm o2File return file(substr(m, 2))')
m.class.classO = classNew('o')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c w w' ,
, 'c o o' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
srch = pos('\', opts) < 1
p = classPermanent(t, srch)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if \srch & p \== t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'vwo') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm == '' then
nm = 'o'
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if m.t = 'o' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
opt = left('K', m.map.keys.a \== '')
if opt == 'K' then
call mAdd m.map.Keys.a, ky
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(MARECWK) cre=2009-05-28 mod=2011-04-08-10.25.25 A540769 ---
/* rexx ****************************************************************
maRec massRecovery Driver
call from tso:
tso maRec new dsnLib
tso maRec lib(phaMbr) opt?
call as editmacro, editing lib(phaMbr)
maRec opt?
Ideen, todo
phaseNew/Ini auftrennen in general Teil und application phase
* history **************************************************************
1.12.09 smsSG heisst richtig db2Nmr
*****/ /****************************************************************
30.11.09 neue Konstanten für job Estimate ts gemessen, ix Finger im Wind
27.11.09 muliple vcat in ANA, ryAnaJ for ANA, smsSG now in JOB
27.11.09 remove mbr zBase, but read previous var Mbrs
19.11.09 variable SHOWMBR fuer zu editierendes Mbr, ##report für monitor
19.11.09 edit job(delete1)
3.11.09 member job30 mit Aenderung anaLib stürzt nicht mehr ab
3.11.09 member err: close't und dealloziert files
20.10.09 mon nimmt gleiche Nummer wie der überwachte job
***********************************************************************/
parse arg opt
pp = 'L DSN.MAREC.DBZF.D090702.T175332.JOB265' ,
'001 YMRCO001 rebu wa'
if 0 then
parse var pp dsn opt
call errReset 'hI'
call wshIni
call phaseIni
call envPutO 'ctl', mNew('Ctl')
m.isEditing = 0
m.ctlMbr = ''
if opt == '' & sysVar('sysISPF') = 'ACTIVE' then do
if adrEdit('macro (opt)', '*') == 0 then do
call adrEdit '(mbr) = member'
call adrEdit '(pds) = dataset'
m.ctlMbr = pds'('mbr')'
m.isEditing = 1
do sx=1
call adrEdit '(cha) = data_changed'
if sx > 3 then
call errEx 'cannot save member'
if cha = 'NO' then
leave
say '...saving member' m.ctlMbr
call adrEdit 'save', '*'
end
end
end
w1 = word(opt, 1)
if pos('(', w1) > 0 then do
m.ctlMbr = dsn2jcl(w1)
m.isEditing = 0
opt = subword(opt, 2)
end
m.ctlMbr = dsn2jcl(m.ctlMbr)
parse var opt o1 o2
parse upper var opt u1 u2
if abbrev(u1, 'T') then
return tst(substr(o1, 2) o2)
else if u1 = 'N' then
return phaseNewWorker(o2)
call readDsn m.ctlMbr, 'M.CI.'
ctlInB = jBufWriteStem(jBuf(), ci)
call envPushName 'ctl', 'as1'
call compRun ':', ctlInB
call envPopWith
/* call objOut envGetO('ctl') */
call histRead
if u1 == 'E' | u1 == 'V' then
return phaseEdit( ,o1, o2)
else if o1 \== '' then
fun = opt
else
fun = envGet('ctl.fun')
if abbrev(fun, '*') then
fun = ''
laCont = 'noNoNo'
do forever
hx = m.zHist.0
dsc = m.zHiPa.1
laPh = m.zHist.phase
laDe = m.laPh.desc
cont = phaseCont(laPh)
if cont = laCont then
exit
laCont = cont
aft = phasePostWork(laPh, cont)
if aft = 'r' then
iterate
if cont \== '' then
exit
if fun == '' then
funDsc = ''
else
funDsc = phaseDescGet(word(fun, 1))
f1 = word(phaseSearchPath(laPh, funDsc, envGet('ctl.goal')), 1)
if f1 == '' then
call err 'internal now what'
if m.funDsc.name \== f1 then
funDsc = phaseDescGet(f1)
ph = phaseDescMake(funDsc, histNext(), m.zHist.phase,
, subWord(fun, 2))
call phaseAlloc ph
cont = phaseWork(ph)
call phaseFree ph
ret = phasePostWork(ph, cont)
if ret \== 'r' then
exit
end
endOf Main
erI: procedure expose m.
parse arg msg
exit errEx('\n'left('--- input Fehler ', 79, '-') ,
||'\n'msg'\n'left('',79,'-'))
erC: procedure expose m.
parse arg msg
exit errEx('\n'left('--- Fehler im ctlMbr ', 79, '-') ,
||'\n'msg'\n'left('',79,'-'))
ctlMbrAddLines: procedure expose m.
parse arg st, chWrds, doWri
do ix=1 to m.ci.0 while \ abbrev( m.ci.ix, '$#end')
do wx=1 to words(chWrds)
if pos(word(chWrds, wx), m.ci.ix) < 1 then
iterate
say word(chWrds, wx) 'already in ctlMbr' ix':' m.ci.ix
return
end
end
if ix > m.ci.0 then do
call erI '$#end not found in ctlMbr'
return
end
call mInsert ci, ix, st
if doWri == 1 then
call ctlMbrUpdate 0
return
endProcedure ctlMbrAddLines
/*** ctl: handle ctlMbr ***********************************************/
ctlMbrUpdate: procedure expose m.
parse arg funDone
upd = ''
if envGet('ctl.fun') \== '' & funDone then do
do lx = 1 to m.ci.0
w1 = word(m.ci.lx, 1)
ex = pos('=', m.ci.lx)
if ex < 1 | \ (w1 == 'fun' | abbrev(w1, 'fun=')) then
iterate
m.ci.lx = overlay('*', m.ci.lx, ex+1)
upd = upd lx
end
end
if \ m.isEditing then do
call writeDsn m.ctlMbr, 'M.CI.', , 1
return
end
call adrEdit 'del all .zf .zl', 4 8 /* 8 for empty file */
do ix=1 to m.ci.0
li = m.ci.ix
call adrEdit 'line_after' (ix-1) '= (li)'
end
return
endProcedure ctlMbrUpdate
ctlMbrWrite: procedure expose m.
parse arg isNew, stems
ox = 0
do wx = 1 to words(stems)
st = word(stems, wx)
do sx = 1 to m.st.0
ox = ox + 1
o.ox = m.st.sx
end
end
ox = ox+1
o.ox = '$#end history'
ox = ox+1
o.ox = 'pha fun ctlMbr lnk opt'
cm = dsnGetMbr(m.ctlMbr)
do ax=1 to m.zHist.addIx
if m.zHist.ax.ctlMbr \== cm then
iterate
ox = ox + 1
o.ox = m.zHistR.ax
end
if \ m.isEditing then do
call writeDsn m.ctlMbr copies('::f',isNew), o., ox, 1
end
else do
call adrEdit 'del all .zf .zl', 4 8 /* 8 for empty file */
do ix=1 to ox
li = o.ix
call adrEdit 'line_after' (ix-1) '= (li)'
end
call adrEdit 'save', 4 /* 4 = new member saved */
end
return
endProcedure ctlMbrWrite
/**** hist: handle history ********************************************/
tst: procedure expose m.
parse upper arg f1 f2
if f1 = 'HIST' then
call tstHistNext
else
call err 'bad test fun' f1 f2
return 0
endProcedure tst
tstHistNext: procedure expose m.
m.zHist.addIx = 0
call tstHistNext1 'abc'
call tstHistNext1 'P00'
call tstHistNext1 'P01'
call tstHistNext1 'P08'
call tstHistNext1 'P09'
call tstHistNext1 'P10'
call tstHistNext1 'P79'
call tstHistNext1 'P80'
call tstHistNext1 'P98'
call tstHistNext1 'P99'
call tstHistNext1 'Q00'
call tstHistNext1 'Q01'
call tstHistNext1 'Q48'
call tstHistNext1 'Q49'
call tstHistNext1 'Q98'
call tstHistNext1 'Q99'
call tstHistNext1 'R00'
call tstHistNext1 'X99'
call tstHistNext1 'Z00'
call tstHistNext1 'Z50'
call tstHistNext1 'Z98'
call tstHistNext1 'Z99'
return
endProcedure tstHistNext
tstHistNext1: procedure expose m.
parse arg fr
lx = m.zHist.addIx
m.zHist.lx.phaId = fr
m.zHist.nextPha = ''
say 'phase' lx fr '==>' histNext()
m.zHist.addIx = lx+1
return
endProcedure tstHistNext1
histRead: procedure expose m.
dsn = dsnSetMbr(m.ctlMbr, "zHist")
if sysDsn("'"dsn"'") \== "OK" then do
m.zHist.0 = 0
m.zHist.phase = ''
end
else do
call readDsn dsn, 'M.ZHISTR.'
do rx = 1 to m.zhistr.0
call histLine rx, m.zHistR.rx
m.zHist.rx.desc = phaseDescGet(m.zHist.rx.fun)
/* m.zHist.rx.desc = phaseDescOpt(dsc, m.zHist.rx.opt) */
dp = m.zHist.rx.lnkO
if dp \== '' then
dp = m.dp.phase
m.zHist.rx.phase = phaseDescMake(m.zHist.rx.desc,
, m.zHist.rx.phaId, dp, m.zHist.rx.opt)
end
hx = m.zHistr.0
m.zHist.0 = hx
m.zHist.phase = m.zHist.hx.phase
end
m.zHist.nextPha = ''
m.zHist.addIx = m.zHist.0
return
endProcedure histRead
histLine: procedure expose m.
parse arg rx, li
parse var li ph 5 fu 11 cm 20 ln 24 o 48 ts
ph = strip(ph)
call mapAdd phaseN2H, ph, 'ZHIST.'rx
if length(ph) \= 3 | ph <= laPha ,
| pos(left(ph, 1), 'PQRSTUVWXYZ') < 1 ,
| verify(substr(ph, 2), '0123456789') > 0 then
call err 'bad phase' ph 'in' rx':' li
m.zHist.rx.phaId = ph
fu = strip(fu)
m.zHist.rx.fun = fu
if length(fu) < 3 | length(fu) > 5 then
call err 'bad fun' fu 'in' rx':' li
m.zHist.rx.ctlMbr = strip(cm)
if m.zHist.rx.ctlMbr = '' | length(m.zHist.rx.ctlMbr) > 8 then
call err 'bad ctlMbr' cm 'in' rx':' li
ln = strip(ln)
m.zHist.rx.link = ln
m.zHist.rx.lnkO = ''
if ln \== '' then
m.zHist.rx.lnkO = mapGet(phaseN2H, ln)
m.zHist.rx.opt = strip(o)
m.zHist.rx.tst = ts
return
endProcedure histLine
histAdd: procedure expose m.
parse arg ph
ds = m.ph.desc
fun = strip(m.ds.name)
if length(fun) < 3 | length(fun) > 5 then
call err 'histAdd bad fun' fun
fun = left(fun, 5)
if length(m.zHist.nextPha) \= 3 then
call err 'histAdd not preceeded by histNext'
ax = m.zHist.addIx
lnk = m.ph.disp
if lnk == '' then
lnk = ' '
else
lnk = m.lnk.phaId
if length(lnk) \== 3 then
call err 'histAdd bad link' lnk lnkX
if m.ph.phaId \== m.zHist.nextPha then
call err 'phaId mismatch'
li = m.zHist.nextPha fun left(dsnGetMbr(m.ctlMbr), 8) lnk m.ph.opt
tst = ' 'userid() date(s) time()
li = overlay(tst, li, 73-length(tst))
ax = ax+1
m.zHist.addIx = ax
m.zHistR.ax = li
call mAdd 'CI', li
call histLine ax, li
hx = m.zHist.0
m.zHist.hx.phase = ph
m.zHist.phase = ph
m.zHist.hx.desc = ds
return
endProcedure histAdd
histNext: procedure expose m.
if m.zHist.nextPha \== '' then
call err 'two histNext in seq'
if m.zHist.addIx = 0 then
m.zHist.nextPha = 'P00'
else do
lx = m.zHist.addIx
la = m.zHist.lx.phaId
if substr(la, 2) < 99 then
m.zHist.nextPha = left(la, 1)right(substr(la, 2)+1, 2, 0)
else do
nx = substr('PQRSTUVWXYZ', 1+pos(left(la, 1), 'PQRSTUVWXY'),
, 1)
if nx == 'P' then
call err 'phase overflow' la
m.zHist.nextPha = nx'00'
end
end
return m.zHist.nextPha
endProcedure histNext
histWrite: procedure expose m.
if m.zHist.addIx == m.zHistR.0 then
return
call writeDsn dsnSetMbr(m.ctlMbr, 'zHist'),
, 'M.ZHISTR.', m.zHist.addIx, 1
return
endProcedure histWrite
/*** phase ************************************************************/
phaseIni: procedure expose m.
if m.phase.ini == 1 then
return
call mapReset phaseN2H
m.phase.ini = 1
call classNew 'n Ctl u f dbSub v, f goal v, f fun v',
',f fromTst v, f toTst v, f image v, f objs s' ,
classNew('u f type v, f crDb v, f tbTs v, f parts v'),
',f vcats s' classNew('u f vcat v')
call classNew 'n IO u f IO v, f TYPE v'
call classNew 'n IOTIn u IO', 'm',
, "new parse arg ., m.m.type; m.m.io='i'" ,
, 'ioInst return ioTInInst(m, pha)'
call classNew 'n IOTAll u IO', 'm',
, "new parse arg ., m.m.type; m.m.io='o'" ,
, "ioInst return ioTAllInst(m, pha)"
call classNew 'n IOTAlV u IO', 'm',
, "new parse arg ., m.m.type; m.m.io='o'" ,
, "ioInst return ioTAlVInst(m, pha)"
call classNew 'n IOInst u IO, f CopyT r, f FREE v', 'm',
, "new call err 'abstract class IOInst'" ,
, "IOAlloc return ''"
call classNew 'n IOCtl u IOInst', 'm',
, "new parse arg ., m.m.type; m.m.io = 'o'"
call classNew 'n IODsn u IOInst, f DD v, f DSN v', 'm',
, "new parse arg ., m.m.io m.m.type, m.m.dsn",
, "IOAlloc return ioDsnAlloc(m)"
call classNew 'n PhaseDesc u f NAME v, f CLASS v, f IO s r'
call mapReset descN
m.descs.0 = 0
call phaseDescAdd 'new PhaseNew'
call phaseDescAdd 'obj PhaseObj',
, mNew('IOTIn', 'objSpec'), mNew('IOTAll', 'ts')
call phaseDescAdd 'copy PhaseCopy'
call phaseDescAdd 'make PhaseMake'
call phaseDescAdd 'pitAn PhasePitAna',
, mNew('IOTIn', 'ts'),mNew('IOTAll', 'pitAn'),
, mNew('IOTAll', 'ts'),
, mNew('IOTAlV', 'rr'),mNew('IOTAlV', 'logRg')
call phaseDescAdd 'pitRe PhasePitRec',
, mNew('IOTIn', 'ts'),mNew('IOTAll', 'pitRe')
call phaseDescAdd 'pitCT PhasePitChgTb',
, mNew('IOTIn', 'ts'),mNew('IOTAll', 'pitCT')
call phaseDescAdd 'Cim PhaseCim',
, mNew('IOTIn', 'tsDsn'),mNew('IOTIn', 'ixDsn') ,
, mNew('IOTAll', 'ts'),mNew('IOTAll', 'ix') ,
, mNew('IOTAll', 'cim1'),mNew('IOTAll', 'cim2')
call classNew 'n Phase u f PHAID v, f DESC r' ,
', f OPT v, f DISP r, f IO s r, f CTL r' ,
',f CTLMBR v, f CTLALL v, f LIBALV v, f DSNPRE v', 'm',
, "new call phaseReset m, arg, arg2, arg3",
, "phaseReset ",
, "phaseWork call err 'call of abstract phaseWork('m",
"':'className(objClass(m))') pArg='m.m.pArg",
, "phaseCont return ''"
call classNew 'n PhaseNew u Phase', 'm',
, "phaseReset call phaseNewReset m",
, "phaseCont return phaseNewCont(m)"
call classNew 'n PhaseObj u Phase', 'm',
, "phaseWork return phaseObjImpl(m)"
call classNew 'n PhaseCopy u Phase', 'm',
, "phaseReset call phaseCopyReset m",
, "phaseWork return phaseCopyWork(m)"
call classNew 'n PhaseMake u Phase', 'm',
, "phaseReset call phaseMakeReset m",
, "phaseWork return phaseMakeWork(m)"
call classNew 'n PhasePitAna u Phase', 'm',
, "phaseReset call phasePitAnaReset m",
, "phaseWork return phasePitAnaWork(m)",
, "phaseCont return phasePitAnaCont(m)"
call classNew 'n PhasePitChgTb u Phase', 'm',
, "phaseWork return phasePitChgTbWork(m)"
call classNew 'n PhasePitRec u Phase', 'm',
, "phaseWork return phasePitReWork(m)"
call classNew 'n PhaseCim u Phase', 'm',
, "phaseWork return phaseCimWork(m)"
return
endProcedure phaseIni
/**** class phase: do the work for a phase ****************************/
phaseReset: procedure expose m.
parse arg m, dsc, aPh dp, m.m.opt
m.m.desc = dsc
m.m.phaId = aPh
m.m.disp = dp
m.m.ctl = envGetO('ctl')
m.m.ctlMbr = m.ctlMbr
m.m.ctlAll = dsnSetMbr(m.ctlMbr)'('aPh
m.m.LIBALV = dsnSetMbr(m.ctlMbr)'.ALV('aPh
m.m.dsnPre = dsnSetMbr(m.ctlMbr)'.'aPh
do dx = 1 to m.dsc.io.0
m.m.io.dx = IOInst(m.dsc.io.dx, m)
end
m.m.io.0 = m.dsc.io.0
interpret objMet(m, 'phaseReset')
return m
endProcedure phaseReset
phaseWork: procedure expose m.
parse arg m
interpret objMet(m, 'phaseWork')
endProcedure phaseWork
phaseCont: procedure expose m.
parse arg m
interpret objMet(m, 'phaseCont')
endProcedure phaseWork
phaseAlloc: procedure expose m.
parse arg m
do fx=1 to m.m.io.0
call IOAlloc m.m.io.fx, m
end
return
endProcedure phaseAlloc
phaseFree: procedure expose m.
parse arg m
do fx=1 to m.m.io.0
f1 = m.m.io.fx
if m.f1.free == '' then
iterate
if m.f1.io = 'i' then
call readDDEnd m.f1.dd
else if m.f1.io = 'o' then
call writeDDEnd m.f1.dd
interpret m.f1.free
m.f1.free = ''
end
call histAdd m
call histWrite
call ctlMbrUpdate 1
return
endProcedure phaseFree
/*** search the next fun **********************************************/
phaseSearchPath: procedure expose m.
parse arg p, funDsc, goal
o = ''
pTo =
done = ''
oldPa = ''
dp = m.zHist.phase
already = ''
m.sePa.0 = 0
do while dp \== ''
dsc = m.dp.desc
oldPa = m.dsc.name oldPa
done = m.dsc.name done
do dx = 1 to m.dp.io.0
f1 = m.dp.io.dx
if m.f1.IO == 'o' then do
if wordPos(m.f1.type, o) < 1 then
o = o m.f1.type
if m.f1.type \= goal then
iterate
say 'warning goal' goal 'already reached in' m.dp.phaId
if funDsc == '' then
erI(' entweder neues goal setzen,' ,
'\n oder Funktion angeben')
done = repAllWords(done, m.dsc.name)
o = repAllWords(o , m.f1.type)
end
end
dp = m.dp.disp
end
if funDsc == '' then do
funNm = '*'
pa = phaseSearchPathAll(o, done, goal, 0)
end
else do
funNm = m.funDsc.name
pa = phaseDescSearchPath(funDsc 1, o, done, goal, 1)
end
ch = ''
do sx = 1 to m.sepa.0
c1 = word(m.sePa.sx, words(done)+1)
if wordPos(c1, ch) < 1 then
ch = ch c1
end
if words(ch) = 1 then
return subword(m.sepa.1, words(done)+1)
say 'from' oldPa 'fun' funNm 'to goal' goal
do sx = 1 to m.sepa.0
say ' by path' subword(m.sePa.sx, words(done)+1)
end
if words(ch) < 1 then
call erI 'fun' fun 'cannot reach goal' goal
else
call erI 'multiple paths, choose one fun from'ch
endProcedure phaseSearchPath
phaseSearchPathAll: procedure expose m.
parse arg o, pa, goal, firstOnly
px = 0
do dx=1 to m.descs.0
d1 = m.descs.dx
if m.d1.io.0 < 1 then
iterate
if phaseDescSearchPath(d1, o, pa, goal, firstOnly) then do
if firstOnly then
return 1
px = px + 1
end
end
return px > 0
endProcedure phaseSearchPathAll
phaseDescSearchPath: procedure expose m.
parse arg d force, o, pa, goal, firstOnly
if wordPos(m.d.name, pa) > 0 & force \== 1 then
return 0
pa = pa m.d.name
do dx = 1 to m.d.io.0
f1 = m.d.io.dx
if m.f1.IO == 'o' then
o = o m.f1.type
else if m.f1.IO == 'i' then
if wordPos(m.f1.type, o) < 1 then
return 0
end
if wordPos(goal, o) > 0 then
return searchPathMerge(pa)
return phaseSearchPathAll(o, pa, goal, firstOnly)
endProcedure phaseDescSearchPath
searchPathMerge: procedure expose m.
parse arg pa
do sx = 1 to m.sepa.0
do wx=1
if word(pa, wx) \== word(m.sepa.sx, wx) then
leave
if word(pa, wx) == '' then do
/* say '???mrg path' pa '= m.sepa.'sx m.sepa.sx */
return 1
end
end
if wrdisSubset(subWord(m.sepa.sx, wx), subWord(pa, wx)) then do
/* say '???mrg path' pa 'super of m.sepa.'sx m.sepa.sx */
return 1
end
if wrdisSubset(subWord(pa, wx), subWord(m.sepa.sx, wx)) then do
/* say '???mrg path' pa 'sub of m.sepa.'sx m.sepa.sx */
m.sepa.sx = pa
return 1
end
end
call mAdd sepa, pa
return 1
endProcedure searchPathMerge
wrdIsSubset: procedure expose m.
parse arg sma, big
do sx=1
s1 = word(sma, sx)
if s1 == '' then
return 1
if wordPos(s1, big) < 1 then
return 0
end
endProcedure wrdIsSubset
/*--- postwork: user actions after a phase is completed --------------*/
phasePostWork: procedure expose m.
parse arg ph, cont
cx = 0
res = ''
do while cx < length(cont)
ex = pos(';', cont, cx+1)
if ex <= cx then
ex = length(cont)+1
parse value substr(cont, cx+1, ex-cx-1) with c1 cr
cr = strip(cr)
cx = ex
if c1 == '' then
iterate
if c1 == 'q' then
exit
if c1 == 'e' | c1 == 'v' then do
if phaseEdit(ph, c1, cr) then
res = 'r'
end
else if c1 == 'm' then
say cr
else
say 'bad cont' c1 'with' cr
end
return res
endProcedure phasePostWork
/*--- edit a file of a phase -----------------------------------------*/
phaseEdit: procedure expose m.
parse arg p, f, aObj
obj = aObj
tIO = 'o'
fun = if(translate(f)='E', 'edit', 'view')
do while words(obj) > 1
parse var obj w1 obj
u1 = translate(w1)
if u1 == 'I' | u1 == 'O' | u1 == 'IO' | u1 = 'OI' then
tIO = translate(w1, 'io', 'IO')
else if length(u1) \== 3 then
call erI 'bad' f 'option' u1', i,o,io or phase expected'
else if \ mapHasKey(phaseN2H, u1) then
call erI 'phase' u1 'not in history'
else do
p = mapGet(phaseN2H, u1)
p = m.p.phase
end
end
if p == '' then
p = m.zHist.phase
obj = strip(obj)
ed = ''
do while ed == '' & p \== ''
do sx=1 to m.p.io.0 while ed == ''
i1 = m.p.io.sx
if pos(m.i1.io, tIO) > 0 ,
& abbrev(translate(m.i1.type), translate(obj)) then
ed = m.i1.dsn
end
p = m.p.disp
end
if ed == '' then
call erI 'edit has not found:' aObj
else if sysvar('sysEnv') \== 'FORE' ,
| sysvar('sysISPF') \== 'ACTIVE' then
say fun ed
else
return adrIsp(fun "dataset('"ed"')", 4) == 0 & f = 'e'
return 0
endProcedure phaseEdit
phaseIOFind: procedure expose m.
parse arg m, aTy, aIOs
if aIOs == '' then
aIOs = 'io'
cP = m
do while cP \== ''
do fx=1 to m.cP.io.0
f1 = m.cP.io.fx
if m.f1.type == aTy & pos(m.f1.io, aIOs) > 0 then
return f1
end
cP = m.cP.disp
end
return ''
endProcedure ioTInInst
/**** PhaseNew *********************************************************
first phase *************************************************/
phaseNewReset: procedure expose m.
parse arg m
if envGet('ctl.objs.0') > 0 then
call mAdd m'.IO', mNew('IOCtl', 'objSpec')
return
endProcedure phaseNewReset
phaseNewCont: procedure expose m.
parse arg m
if m.M.io.0 > 0 then
return ''
return 'm please specify db2 objects in objs'
endProcedure phaseNewCont
phaseNewWorker: procedure expose m.
parse upper arg subsys f1
if length(subsys) \= 4 then
call erI 'invalid db2 subsys' subsys 'for function n'
call envPut 'dbSub', subsys
call envPut 'f1', f1
if m.ctlMbr == '' then
m.ctlMbr = 'DSN.MAREC.D'substr(date('s'), 3),
|| '.T'translate('124578', time(), '12345678')'(A)'
else do
so = sysDsn("'"m.ctlMbr"'")
if so == "DATASET NOT FOUND" then
nop
else if so == 'OK' then do
call readDsn m.ctlMbr, i.
if i.0 <> 0 then
call erI 'fun new but cltMbr' m.ctlMbr 'not empty'
end
else if so \== 'MEMBER NOT FOUND' then
call erI 'fun new but cltMbr' m.ctlMbr 'sysDsn' so
end
call histRead
if m.zHist.0 > 0 & (m.zHist.1.fun \== 'new',
| word(m.zHist.1.opt, 1) \== subSys) then
call erI 'db subSys' subSys 'mismatch to' m.zHist.1.opt
phId = histNext()
dsc = phaseDescGet('new')
pha = phaseDescMake(dsc, phId, , subsys f1)
m.ci.0 = 0
call histAdd pha
nb = runInline2St('new')
ax = m.zHist.addIx
call ctlMbrWrite 1, nb
call histWrite
if m.isEditing then
nop /* we edit the member already, just return| */
else if sysvar('sysEnv')='FORE' & sysvar('sysISPF')='ACTIVE' then
call adrIsp "edit dataset('"m.ctlMbr"')", 4
return 0
endProcedure phaseNewWorker
runInline2St: procedure expose m.
parse arg inl
jIn = jBufWriteStem(jBuf(), mapInline(inl))
jOut= jBuf()
call compRun '=', jIn, jOut
return jOut'.BUF'
endProcedure runInline2St
/*
$</new/
* pit Recovery analyze parameters
dbSub = $dbSub
goal = pitAn
fun = *
<|/objs/
type crDb tbTs parts
tb OA1P name 3-7,88
/objs/
$/new/
*/
/**** PhaseCopy ********************************************************
copy and edit an existing output file ***********************/
phaseCopyReset: procedure expose m.
parse arg m
opts = m.m.opt
do ox=1 to words(opts)
w1 = word(opts, ox)
o0 = phaseIOFind(m.m.disp, w1, 'o')
i1 = ioCopy(o0, 'i')
m.i1.dd = 'copyIn'
o1 = ioInst(m.o0.copyT, m)
m.o1.io = 'o'
m.o1.dd = 'copyOut'
call mAdd m'.IO', i1, o1
end
if ox <= 1 then
call erI 'copy ohne option'
return m
endProcedure phaseCopyReset
phaseCopyWork: procedure expose m.
parse arg m
call readDD 'copyIn', i., '*'
call writeDD 'copyOut', i.
do fx=1 to m.m.io.0
i1 = m.m.io.fx
if m.i1.IO = 'o' & m.i1.dd = 'copyOut' then
return 'e' m.i1.type
end
call err 'copyOut not found'
endProcedure phaseCopyWork
/**** PhaseMake ********************************************************
make and edit an new output *********************************/
phaseMakeReset: procedure expose m.
parse arg m
opts = m.m.opt
do ox=1 to words(opts)
w1 = word(opts, ox)
o1 = ioInst(mNew('IOTAll', w1), m)
m.o1.dd = '-'
call mAdd m'.IO', o1
end
if ox <= 1 then
call erI 'make ohne option'
return m
endProcedure phaseMakeReset
phaseMakeWork: procedure expose m.
parse arg m
a = ''
do fx=1 to m.m.io.0
i1 = m.m.io.fx
a = a';e' m.i1.type
end
return a
endProcedure phaseMakeWork
/**** PhaseDesc: description for a phase ******************************/
phaseDescAdd: procedure expose m.
n = mNew('PhaseDesc')
parse arg m.n.name m.n.class
call mAdd descs, mapAdd(descN, translate(m.n.name), n)
do ix=2 to arg()
call mAdd n'.IO', arg(ix)
end
return n
endProcedure phaseDescAdd
phaseDescGet: procedure expose m.
parse arg fun
if mapHasKey(descN, translate(fun)) then
return mapGet(descN, translate(fun))
call erI 'phaseDesc' fun 'not implemented'
endProcedure phaseDescGet
phaseDescMake: procedure expose m.
parse arg m, phase, dp, opt
return mNew(m.m.class, m, phase dp, opt)
endProcedure phaseDescMake
/**** IO: IOTemplates and IOInstances *********************************/
/**** IOT: IO Templates ***********************************************/
ioInst: procedure expose m.
parse arg m, pha
interpret objMet(m, 'ioInst')
endProcedure ioInst
ioCopy: procedure expose m.
parse arg o, aIo
n = oCopyNew(o)
m.n.io = aIo
m.n.dd = ''
return n
endProcedure ioCopy
/**** IOTIn: Input file ***********************************************/
ioTInInst: procedure expose m.
parse arg m, pha
f = phaseIoFind(m.pha.disp, m.m.type, 'o')
if f == '' then
return ''
return ioCopy(f, 'i')
endProcedure ioTInInst
/**** IOTAll: IO Template for Mbr in CtlLibrary **********************/
ioTAllInst: procedure expose m.
parse arg m, pha
cP = m.pha.disp
t5 = strip(left(m.m.type, 5))
i = mNew('IODsn', 'o' m.m.type, m.pha.ctlAll || t5')')
m.i.copyT = m
return i
endProcedure ioTAllInst
/* wkTst???
ioAllONew: procedure expose m.
parse arg m, m.m.type m.m.suf .
m.m.io ='o'
if m.m.suf == '' then
m.m.suf = strip(left(m.m.type, 5))
return
endProcedure ioAllONew
*/
/**** IOTAlV: IO Template for Mbr in ALV Library **********************/
ioTAlVInst: procedure expose m.
parse arg m, pha
cP = m.pha.disp
t5 = strip(left(m.m.type, 5))
i = mNew('IODsn', 'o' m.m.type, m.pha.libAlV || t5')')
m.i.copyT = m
return i
endProcedure ioTAllInst
/**** IOInstances: implement a file ***********************************/
ioAlloc: procedure expose m.
parse arg m, pha
interpret objMet(m, 'IOAlloc')
endProcedure ioAlloc
/**** IODsn: IO for a DSN *********************************************/
ioDsnAlloc: procedure expose m.
parse arg m
if m.m.dsn == '' then
call err 'empty dsn'
if m.m.dd == '-' then
return ''
if m.m.dd == '' then
m.m.dd = m.m.type
res = dsnAlloc("shr dd("m.m.dd") dsn('"m.m.dsn"')")
if word(res, 1) \== translate(m.m.dd) then
call err 'dd mismatch'
m.m.free = subword(res, 2)
return m.m.free
endProcedure ioDsnAlloc
/**** application phases: *********************************************/
/**** PhaseObj *********************************************************
expand an object list ***************************************/
phaseObjImpl: procedure expose m.
parse arg m
call mapReset dbTs, 'k'
call sqlConnect envGet('ctl.dbSub')
laTy = ''
wh = ''
laCrTb =''
do sx=1 to envGet('ctl.objs.0')
call assIf 'ty', envGet('ctl.objs.'sx'.type')
call assIf 'cd', envGet('ctl.objs.'sx'.crDb')
call assIf 'tt', envGet('ctl.objs.'sx'.tbTs')
pa = envGet('ctl.objs.'sx'.parts')
/* say 'objs' sx ty 'crDb' cd 'tbTs' tt 'pa' pa */
if ty = '' | tt == '' then do
say 'skipping line' sx 'type' envGet('ctl.objs.'sx'.type'),
'crDb' envGet('ctl.objs.'sx'.crDb'),
'tbTs' envGet('ctl.objs.'sx'.tbTs')
iterate
end
if ty == 'tb' | ty == 'ts' then do
wh = ''
if ty == 'tb' then do
if cd \= '' then
wh = wh 'and t.creator' sqlClause(cd)
wh = wh 'and t.name' sqlClause(tt)
end
else do
if cd \= '' then
wh = wh 'and s.dbName' sqlClause(cd)
wh = wh 'and s.name' sqlClause(tt)
end
if pa \== '' then
wh = wh 'and (' sqlList('p.partition', pa) ')'
sq = 'select t.dbName, t.tsName, t.creator, t.name' ,
',s.partitions, p.partition',
'from sysibm.sysTables t' ,
'join sysibm.sysTableSpace s',
'on s.dbName = t.dbName and s.name = t.tsName',
'join sysibm.sysTablePart p',
'on p.dbName = s.dbName and p.tsName = t.tsName',
'where' substr(wh, 6),
'order by dbName, tsName, partition'
end
else
call erC 'objSpec bad type' ty
/* say sq */
sr = jOpen(sqlRdr(sq), '<')
do cx=0 while assNN('PP', jReadO(sr))
/* call outO pp */
ky = strip(m.pp.dbName)'.'strip(m.pp.tsName)
obj = ky
pa = m.pp.partition
if \ mapHasKey(dbTs, ky) then do
call mapAdd dbTs, ky, pa
m.obj = m.pp.partitions
m.obj.one = pp
do px=0 to m.pp.partitions+1
m.obj.px = ''
end
end
if m.pp.partitions <> m.obj then
call err 'bad parts' m.pp.partitions 'in' ky':'m.obj
if pa > m.obj then
call err 'bad partition' pa 'in' ky':'m.obj
m.obj.pa = pp
end
call jClose sr
if cx < 1 then
say 'warning no objects/partitions for' ty cd'.'tt':'pa
end
call sqlDisConnect
call sort mapKeys(dbTs), dbts, '<'
if m.dbts.0 < 1 then
exit erI('no db objects found')
m.out.0 = 0
do ox=1 to m.dbts.0
obj = m.dbts.ox
p = m.obj.one
li = left(m.p.dbName, 8) left(m.p.tsName, 9),
m.p.creator m.p.name
lx = ''
ls = ''
do px=0 to m.obj+1
if m.obj.px == '' then do
if lx = '' then
nop
else if lx=px-1 then
ls = ls || lx','
else
ls = ls || lx'-' || (px-1)','
lx = ''
end
else if lx == '' then
lx = px
end
if (ls = '0,' & m.p.partitions = 0) ,
| (ls = '1,' & m.p.partitions = 1) ,
| (ls = '1-'m.p.partitions',') then
li = li 'all='m.p.partitions
else if m.p.partitions < 2 then
call err li 'with' m.p.partitions 'but partList' ls
else
li = li left(ls, length(ls) - 1)
call mAdd out, li
end
call writeDD 'ts', 'M.OUT.'
return 'v ts'
endProcedure phaseObjImpl
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
sqlList: procedure expose m.
parse arg fld, lst
ex = listExpReset(sqlList, lst)
res = ''
do while ass('e1', listExp(ex)) \== ''
res = res',' e1
end
res = substr(res, 3)
if pos(',', res) < 1 then
return fld '=' res
return fld 'in ('res')'
endProcedure sqlList
listExpReset: procedure expose m.
parse arg m, m.m.src
m.m.rg.1 = 'reset'
m.m.rg.2 = ''
m.m.pos = 1
return m
endProcedur listExpReset
listExp: procedure expose m.
parse arg m
la = m.m.rg.1
if la > m.m.rg.2 then
if listExpRg(m) == '' then
return ''
else
la = m.m.rg.1
m.m.rg.1 = la + 1
return la
endProcedure listExp
listExpRg: procedure expose m.
parse arg m
m.m.rg.1 = 'end'
m.m.rg.2 = ''
x0 = m.m.pos
do lx=1 to 2
x1 = verify(m.m.src, ' ', 'n', x0)
if x1 < 1 then do
m.m.pos = length(m.m.src)+1
leave
end
x2 = verify(m.m.src, '0123456789', 'n', x1)
if x2 = 0 then
x2 = length(m.m.src)+1
if x2 <= x1 then
call err 'non numeric listelement' substr(m.m.src, x1),
'in list' m.m.src
m.m.rg.lx = substr(m.m.src,x1, x2-x1)
x3 = verify(m.m.src, ' ', 'n', x2)
if x3 = 0 then do
m.m.pos = length(m.m.src)+1
leave
end
if substr(m.m.src, x3, 1) == ',' then do
m.m.pos = x3+1
leave
end
if substr(m.m.src, x3, 1) \== '-' | lx > 1 then
call err 'bad op' substr(m.m.src, x3) 'in list' m.m.src
x0 = x3+1
end
if m.m.rg.1 == 'end' then
return ''
if m.m.rg.2 == '' then
m.m.rg.2 = m.m.rg.1
if m.m.rg.1 <= m.m.rg.2 then
return m.m.rg.1 m.m.rg.2
say 'empty range' m.m.rg.1'-'m.m.rg.2 'in list' m.m.src
return listExpRg(m)
endProcedure listExpRg
/**** PhasePitAna ******************************************************
analysis for pit recovery ***********************************/
phasePitAnaReset: procedure expose m.
parse arg m
do ix=1 to m.m.io.0
f1 = m.m.io.ix
if m.f1.io \== 'i' then
m.f1.dd = '-'
end
return
endProcedure phasePitAnaReset
phasePitAnaWork: procedure expose m.
parse arg m
call createDsn m.m.libAlv')', '::v'
f1 = phaseIOFind(m, 'pitAn')
rr = phaseIOFind(m, 'rr')
lg = phaseIOFind(m, 'logRg')
c = 'call pitAna' envGet('ctl.dbSub') m.f1.dsn m.rr.dsn m.lg.dsn
call readDD ts, ts., '*'
do tx=1 to ts.0
parse var ts.tx db ts cr tb pa
e = db'.'ts'>'cr'.'tb
if e.e == 1 then
iterate
e.e = 1
c = c e
end
say '???' c
i.1 = 'hierhier wird der Job für pit analyse geschrieben'
call writeDsn m.f1.dsn, i., 1, 1
return 'e pitAn'
endProcedure phasePitAnaWork
phasePitAnaCont: procedure expose m.
parse arg m
res = ''
do ix=1 to m.m.io.0
f1 = m.m.io.ix
if m.f1.io == 'i' then
inDsn = m.f1.dsn
else if m.f1.type == 'ts' then do
outDsn = m.f1.dsn
if sysDsn("'"outDsn"'") = 'OK' then
return ''
end
else if m.f1.type == 'pitAn' then do
if sysDsn("'"m.f1.dsn"'") \= 'OK' then
call 'erI pitAn Job has not been created' m.f1.dsn
end
else if sysDsn("'"m.f1.dsn"'") = 'OK' then
res = res';v' m.f1.type
else
res = res';m wait until job has written' m.f1.type
end
if pos(';m', res) > 0 then
return res
call readDsn inDsn, i.
call writeDsn outDsn, i., , 1
return res ';m please fix list of tables ;e o ts'
endProcedure phasePitAnaCont
createDsn: procedure expose m.
parse arg lib, na
call dsnAlloc "dd(alLib) '"lib"'" na
call adrTso 'free dd(alLib)'
return
endProcedure createDsn
/**** PhasePitChgTb ****************************************************
Pit Recovery Variante 3: change table ***********************/
phasePitChgTbReset: procedure expose m.
parse arg m
f1 = phaseIOFind(m, 'pitCT')
m.f1.dd = '-'
return
endProcedure phasePitChgTbReset
phasePitChgTbWork: procedure expose m.
parse arg m
e = ''
if envGet('ctl.fromTst') == '' | envGet('ctl.image') == '' then do
call putCurTstLrsn
call ctlMbrAddLines runInline2St('PitChgTb'), 'fromTst image', 1
e = e', image, fromTst'
end
if envGet('ctl.toTst') == '' then do
call putCurTstLrsn
call ctlMbrAddLines runInline2St('PitToTst'), 'toTst', 1
e = e", toTst"
end
if e \== '' then
call erC 'please specify' substr(e, 3)
frTst = decodeTst('fromTst')
toTst = decodeTst('toTst')
ba = translate(envGet('ctl.image'))
if wordPos(ba, 'A B') < 1 then
call erC 'specify image as A or B'
call createDsn m.m.libAlv')', '::v'
ct = phaseIOFind(m, 'pitCT')
c = 'call pitChgTb' envGet('ctl.dbSub') m.ct.dsn frTst toTst ba
call readDD ts, ts., '*'
do tx=1 to ts.0
parse var ts.tx db ts cr tb pa
e = db'.'ts'>'cr'.'tb
if e.e == 1 then
iterate
e.e = 1
c = c e
end
say '???' c
i.1 = 'hierhier kommt der Job für pit chgTb via logAnalyser'
call writeDsn m.ct.dsn, i., 1, 1
return 'e pitAn'
endProcedure phasePitChgTbWork
putCurTstLrsn: procedure expose m.
cTst = translate('1234-56-78', date('s'),'12345678'),
|| '-'translate(time('l'), '.', ':')
numeric digits 22 /* ???wkTst transparent handling in time || */
call envPut 'curTst', cTst
call envPut 'curLrsn', timeLZT2Lrsn(cTst)
return
endProcedure putCurTstLrsn
/*
$</PitChgTb/
image = $-{left('a', 26)} $'$** a=afterImage, b=beforeImage'
* fromTst = $curTst $'$** Zeitpunkt/Lrsn von'
$/PitChgTb/
$</PitToTst/
* toTst = $curTst $'$** timestamp'
* toTst = $-{left($curLrsn, 26)} $'$** oder LRSN'
$/PitToTst/ */
*/
/**** PhasePitRe: generate PitRecovery Jobs ***************************/
phasePitReWork: procedure expose m.
parse arg m
if envGet('ctl.toTst') == '' then do
call putCurTstLrsn
call ctlMbrAddLines runInline2St('PitToTst'), 'toTst', 1
call erC 'please specify toTst in ctlMbr'
end
if e \== '' then
call decodeTst 'toTst'
call readDD ts, 'I.', '*'
call classNew 'n TS u f DB v, f TS v, f PA v', 'm',
, 'new parse arg , m.m.db m.m.ts m.m.pa'
b = jOpen(jBuf(), '>')
p = jOpen(jBuf(), '>')
do ix = 1 to i.0
parse var i.ix db ts cr tb pa r
if r \= '' | tb = '' then
call err 'bad ts line' ix i.ix
call jWriteO b, mNew('TS', db ts pa)
if abbrev(pa, 'all=') then do
call jWriteO p, mNew('TS', db ts '--' pa)
end
else do
ex = listExpReset(m'.liEx', pa)
do while ass('e1', listExp(ex)) \== ''
call jWriteO p, mNew('TS', db ts e1)
end
end
end
call envPutO 'ts', jClose(b)
call envPutO 'tsPa', jClose(p)
/* call jWriteAll m.j.out, envGetO('ts') */
jIn = jBufWriteStem(jBuf(), mapInline('pitRe'))
jOut= jBuf()
call compRun '@', jIn, file('dd(pitRe)')
return 'v pitRe'
endProcedure phasePitReWork
/*
$@/pitRe/
$=c=-'//' || '*'
$=jobName=YPITRECO
$@with ctl $@=¢
//$jobName JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
${c}MAIN CLASS=LOG
${c}----------------------- -sta ut -----------------------------
//STAUT EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSub)
$!
$; $<.$ts $@forWith one $@=¢
-sta db($DB) spacenam($TS) acc(ut)
-dis db($DB) spacenam($TS)
$!
$@with ctl $@=¢
${c}----------------------- copy before -------------------------
$@ut{COPYBEF}
LISTDEF LST
$!
$; $<.$ts $@forWith one $@=¢
INCLUDE TABLESPACE $DB.$TS PARTLEVEL
$! $;
$@=¢
COPY LIST LST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL REFERENCE
$!
$@with ctl $@=¢
${c}----------------------- copy before -------------------------
$@ut{PITREC}
-- lrsn $toTstLrsn
-- locale Zurich time $toTstLzt
-- gmt $toTstGmt
LISTDEF LST
$!
$; $<.$tsPa $@forWith one $@=¢
INCLUDE TABLESPACE $DB.$TS PARTLEVEL $PA
$! $;
$@with ctl $@=¢
RECOVER LIST LST TOLOGPOINT X'$toTstLrsn'
PARALLEL
LISTDEF IXLST
INCLUDE INDEXSPACES LIST LST
REBUILD INDEX LIST IXLST
SORTDEVT SYSDA
-- SORTNUM 100
WORKDDN(TSYUTD)
$!
$@with ctl $@=¢
${c}----------------------- copy before -------------------------
$@ut{COPYAFT}
LISTDEF LST
$!
$; $<.$ts $@forWith one $@=¢
INCLUDE TABLESPACE $DB.$TS PARTLEVEL
$! $;
$@=¢
COPY LIST LST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL REFERENCE
$!
$@proc ut $@¢ parse arg , step; $=step=-step
$@=¢
//$-{left($step,9)} EXEC PGM=DSNUTILB,TIME=1440,
// PARM=($dbSub,'$jobName.$step'),
// REGION=0M
//DSSPRINT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSub.DBAA.LISTDEF(TEMPL)
//SYSIN DD *
$!
$!
$/pitRe/
*/
decodeTst: procedure expose m.
parse arg nm
numeric digits 22
tst = translate(envGet('ctl.'nm))
if tst == '' then
call erC nm 'missing'
if verify(tst, '0123456789ABCDEF', 'n') = 0 then
lrsn = left(tst, 12, 0)
else
lrsn = timeLZT2Lrsn(tst)
LZT = timeLrsn2LZt(lrsn)
GMT = timeLrsn2GMT(lrsn)
say left(nm, 20) tst '==> lrsn' lrsn
say right('==> localZurich', 20) lzt
say right('==> gmt', 20) gmt
call envPut nm'Lrsn', lrsn
call envPut nm'Lzt', lzt
call envPut nm'Gmt', gmt
return lzt
endProcedure decodeTst
/**** PhaseCim: Dsn Deletes, CimAnalyse und Cleanup ******************/
phaseCimWork: procedure expose m.
parse arg m
if envGet('ctl.vcats.0') < 1 then do
call ctlMbrAddLines runInline2St('cim'), '/vcats/', 1
call erI 'please specify one or several vcats'
end
vars = 'vcat.0<ctl.vcats.0'
do cx=1 to envGet('ctl.vcats.0')
vars = vars 'vcat.'cx'<ctl.vcats.'cx'.vcat'
end
call envPut 'rexxLib', marecCfg()
rx = genRexx('rexxLib DBSUB<ctl.dbSub' vars)
trace ?r
call maRecJob 'cim' rx
return 'e cim1'
endProcedure phaseCimWork
/*
$=/cim/
* mass recovery analyze parameters
* the list of vCats (High Level Qualifiers of DB datasets)
* normally the same as the db2 subsys
* for ELAR there may be several entries:
* enter each entry on a separate line
* directly under the header vcat
<|/vcats/ vcat
${ctl.dbSub}
/vcats/
$/cim/ */
/* marec10Vars *****************************************
setVar 'LIB', lib -> library of current mbr
setVar 'MBR', mbr
setVar 'PHASE', pha
setVar 'ARGS', opt
setVar 'SHOWMBR', showMbr -> ZU EDITIER. MBR in <upd>Lib
call setVar prePha'LIB', preLib -> previous phase
call setVar upd'LIB', m.lib'.'nl ->current phase (ANA, JOB, MON)
all vars in mbr
***************************************************/
genRexx: procedure expose m.
parse arg lst
vars = ''
co = ''
do wx=1 to words(lst)
w1 = word(lst, wx)
if pos('<', w1) > 0 then do
parse var w1 nm '<' src
va = envGet(src)
end
else do
nm = w1
va = envGet(nm)
end
vars = vars nm
if translate(nm) \= nm then
co = co'; ggNm ='quote(nm)'; v.ggNm'
else
co = co'; v.'nm
co = co'='quote(va)
end
return 'v.vars='quote(vars)co
/* wkTst???? old */
if src == '' then
src = nm
if \ isStem then do
re = re';' vNm '=' quote(m.nm)
vars = vars nm ?????????
re = 'v.vars =' quote(m.all)
do nx=1 to words(m.all)
nm = word(m.all, nx)
isStem = right(nm, 2) == '.*'
if isStem then
nm = left(nm, length(nm)-2)
vNm = 'v.'nm
if translate(nm) \= nm then do
re = re'; ggNm =' quote(nm)
vNm = 'v.ggNm'
end
if \ isStem then do
re = re';' vNm '=' quote(m.nm)
end
else do
re = re';' vNm'.0 =' m.nm.0';'
do sx=1 to m.nm.0
re = re';' vNm'.'sx '=' quote(m.nm.sx)
end
end
end
return re
endProcedure genRexx
/**** old stuff *******************************************************/
$=/newJOB/
* mass recovery job generation parameters
DBSUB = $DBSUB
ANALIB = ?
* the storage group in the diskSubsystem - for CIM
smsSG = DB2NMR
est.ts.const = 0
est.ts.part = .41
est.ts.byte = 1.1e-7
est.ix.const = 5
est.ix.part = 1
est.ix.byte = 2e-7
* the list of system and number of jobs on this system
* optionally the 3. word gives the db2Member
/sys/
S21 10
S22 10
S23 10
S24 10
S25 10
S26 10
/sys/
$/newJOB/ */
/*/new MON/
DBSUB = $DBSUB
JOBLIB = ?
/new MON/ */
/*/new ZHIST/
* history for massrevoery
/new ZHIST/ */
mbrVars: procedure expose m.
parse arg dsn, ggPha
i = 'I.'translate(dsnGetMbr(dsn))
call readDsn dsn, 'M.'i'.'
sx = -99
do ix=1 to m.i.0
li = m.i.ix
cx = pos('*', li)
if cx > 0 then
li = left(li, cx-1)
wx = 1
w = word(li, wx)
if w = '' | abbrev(li, '*') then
iterate
if abbrev(w, '/') then do
if sx >= -1 then do
if w \== '/'st'/' then
call err 'closing /'st'/ expected not line' ,
ix':' strip(m.i.ix) 'in' dsn
if sx >= 0 then
m.st.0 = sx
sx = -99
iterate
end
if right(w, 1) \== '/' then
call err '/.../ expected not' w 'in line' ,
ix':' strip(m.i.ix) 'in' dsn
st = substr(w, 2, length(w)-2)
sx = -1 + regVar(st'.*', ggPha)
iterate
end
if sx >= -1 then do
if sx >= 0 then do
sx = sx+1
m.st.sx = strip(li)
end
iterate
end
cx = pos('=', w)
if cx > 0 then do
nm = left(w, cx-1)
w = substr(w, cx+1)
end
else do
nm = w
wx = wx + 1
w = word(li, wx)
if \ abbrev(w, '=', 1) then
call err '= missing in line' ix':' strip(m.i.ix) ,
'in' dsn
w = substr(w, 2)
end
va = strip(w subWord(li, wx+1))
call setVar nm, va, ggPha
end
return
endProcedure mbrVars
maRecLogJob: procedure expose m.
parse arg dsnPre txt
say 'logging dsn' dsnPre':' txt
ff = dsnAllocWait('MOD dd(LOG)' dsnPre'.LOG', 5)
txt.1 = date(s)':'time() txt
call writeDDBegin log
call writeDD log, 'txt.', 1
call writeDDEnd log
call maRecLogStaAll dsnPre'(STAALL)', txt
interpret subWord(ff, 2)
return 0
endProcedure maRecLogJob
maRecLogStaAll: procedure expose m.
parse arg dsn, jNr jNa step msg
say 'status update in' dsn
say ' job nr' jNr 'name' jNa
say ' step' step 'msg' msg
call readDsn dsn, i.
do y=1 to i.0
if word(i.y, 1) = jNr & word(i.y, 2) = jNa then
leave
end
err = ''
allStates = 'OK WA ER'
oldSta = ''
newSta = ''
if y > i.0 then do
err = 'could not find' jNr jNa 'in' dsn
end
else do
li = i.y
wc = words(li)
if wc < 9 then do
err = 'only' wc 'words in jobline:' li ':line' y 'in' dsn
end
else if wc > 9 then do
oldSta = translate(word(li, min(wc, 11)))
if wordPos(oldSta, allStates 'START RESTART') < 1 then
err = 'bad old state' laWo
end
say 'old state' oldSta 'in line' y':' strip(i.y)
end
if err == '' & msg \= '' then do
newSta = translate(word(msg, words(msg)))
if wordPos(newSta, allStates) < 1 then do
err = 'bad new state' newSta
end
else if oldSta \== '' then do
newSta = word(allStates, max(wordPos(oldSta, allStates),
, wordPos(newSta, allStates)))
end
end
if err \== '' & newSt \= 'ER' then
newSta = 'er'
else if translate(step) = 'REBU' ,
| ( translate(step) = 'RECO' & word(li, 7) = 0) then
newSta = strip(newSta 'ej')
neLi = subword(li, 1, 9) step strip(newSta)
say 'new status:' subword(neLi, 10)
if length(neLi) > 72 then do
neLi = left(neLi, 71-length(newSta)) newSta
err = 'overflow msg' msg
end
if y <= i.0 then do
i.y = neLi
say 'new line: ' neLi
end
if err \== '' then do
z = i.0 + 1
i.z = 'error' err ':line' y 'step' step 'msg' msg
i.0 = z
end
call writeDsn dsn, i.
if err \== '' then
return err(err 'step:' step 'msg:' msg 'at line' y':' li)
return 0
endProcedure maRecLogStaAll
/* rexx ****************************************************************
wsh: walter's rexx shell
interfaces:
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.WshSyn
--- history ------------------------------------------------------------------
16. 3.11 w.keller basic new r '' ==> r m.class.classO
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
********/ /*** end of help ********************************************
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
m.wsh.version = 2.1
parse arg spec
if spec = '?' then
return help('wsh version' m.wsh.version)
os = errOS()
isEdit = 0
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
if sysvar('sysISPF') = 'ACTIVE' then
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
if spec = '?' then
return help('version' m.wsh.version)
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & m.editDsn = 'A540769.WK.REXX(WSH)' then
spec = 't'
end
end
call scanIni
f1 = spec
rest = ''
if pos(verify(f1, m.scan.alfNum), '1 2') > 0 then
parse var spec f1 2 rest
u1 = translate(f1)
if u1 = 'T' then
return wshTst(rest)
else if u1 = 'I' then
return wshInter(rest)
else if u1 = 'S' then
spec = '$<.$sqlIn $$begin sqlIn' rest,
'$@sqlIn() $$end sqlIn' rest '$#sqlIn#='
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = s2o('-wsh')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = s2o('-out')
end
end
else if os == 'LINUX' then do
inp = s2o('&in')
out = s2o('&out')
end
else
call err 'implemnt wsh for os' os
call compRun spec, inp, out
if isEdit then
call wshEditEnd
exit 0
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call tstSqlO2
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
return
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
/* if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
*/
ln = max(1, min(ln, la - 37))
say '??? locating' ln
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
call outPush mCut(ggStem, 0)
call errSay ggTxt
call outPop
isComp = 0
if wordPos("pos", m.ggStem.3) > 0 ,
& pos(" in line ", m.ggStem.3) > 0 then do
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
isComp = lin \== ''
end
if isComp then do
m.ggStem.1 = 'compErr:' m.ggStem.1
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
end
else do
m.ggStem.1 = '*** run error' m.ggStem.1
if m.wsh.editOut \== '' then do
do sx=1 to m.ggStem.0
call jWrite m.wsh.editOut, m.ggStem.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, ggStem
end
else do
do sx=1 to m.ggStem.0
say m.ggStem.sx
end
end
end
exit 0
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstScanUtilInto: procedure expose m.
call pipeBeLa '< !DSN.MFUNL.MF03A1P.A009A.PUN'
call in l1
say 'tst l1' strip(m.l1)
if \ scanUtilInto(abc) then
say 'no into found'
else
say 'table' m.abc.tb 'part' m.abc.part 'found'
if in(l1) then
say 'tst lNext' strip(m.l1)
else
say 'tst no more lines'
call pipeEnd
return
endProcedure tstSCanUtilInto
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.scan.alfLC)
c1 = substr(m.scan.alfLC, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jRead(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl, fi1)
nm = substr(m.fi1, lastPos('/', m.fi1)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
if errOS() = 'TSO' then
call tstZos
call tstTut0
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO1
call tstSqlO2
call tstSqls1
call tstSqlO
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*
$=/tstSorQ/
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSorQ/ */
/*
$=/tstSorQAscii/
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSorQAscii/ */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
$/tstMatch/ */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlIni
call jIni
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.sqlInd, :M.STST.B :M.STST.B.sqlInd, :M.+
STST.C :M.STST.C.sqlInd
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
$/tstSql/ */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlOIni
call tst t, "tstSqlO"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call sqlOIni
call tst t, "tstSqlO1"
call sqlConnect dbaf
sq = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen sq, m.j.cRead
call mAdd t.trans, className(m.sq.type) '<tstSqlO1Type>'
do while assNN('ABC', jReadO(sq))
call outO abc
end
call jClose sq
call out '--- writeAll'
call pipeWriteAll sq
call tstEnd t
call sqlDisconnect
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlOIni
call tst t, "tstSqlO2"
call sqlConnect dbaf
call pipeBegin
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe
call sqlSel
call pipeLast
call fmtFWriteAll fmtFreset(abc)
call pipeEnd
call tstEnd t
call sqlDisconnect
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlOIni
call tst t, "tstSqlS1"
call sqlConnect dbaf
s1 = fileSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, fileSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompStmtA
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
$/tstCompPrimary/ */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.-{"abc"}=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.-{""abc""}="$.-{"abc"}'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*
$=/tstCompExprCon/
$/tstCompExprCon/ */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompStmtA: procedure expose m.
call pipeIni
/*
$=/tstCompStmtAssAtt/
### start tst tstCompStmtAssAtt ###################################
compile @, 19 lines: call tstCompStmtAA "begin", "tstAssAtt"
run without input
begin tstAssAtt F1=F1val1 F2= F3= FR=
gugus1
ass1 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=
ass2 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=<oAAR2>
ass2 tstAssAr2 F1=FRF1ass2 F2= F3= FR=
gugus3
ass3 tstAssAtt F1=F1val1 F2=F2ass3 F3=F3ass1 FR=<oAAR2>
ass3 tstAssAr2 F1=FRF1ass2 F2=FrF2ass3 F3= FR=<oAAR3>
ass3 tstAssAr3 F1=r2F1as3 F2=r2F2as3 F3= FR=
*** err: no field falsch in class tstAssAtt in EnvPut(falsch, +
falsch, 1)
$/tstCompStmtAssAtt/
*/
call classNew 'n? tstAssAtt u f F1 v, f F2 v,' ,
'f F3 v, f FR r tstAssAtt'
call envPutO 'tstAssAtt', mNew('tstAssAtt')
call envPut 'tstAssAtt.F1', 'F1val1'
call tstComp1 '@ tstCompStmtAssAtt',
, 'call tstCompStmtAA "begin", "tstAssAtt"',
, '$=tstAssAtt=:¢F2=F2ass1 $$gugus1',
, 'F3=F3ass1',
, '!',
, 'call tstCompStmtAA "ass1", "tstAssAtt"',
, '$=tstAssAtt.FR.F1 = FRF1ass2',
, '$=tstAssAr2 =. ${tstAssAtt.FR}',
, 'call mAdd T.trans, $.$tstAssAr2 "<oAAR2>"',
, 'call tstCompStmtAA "ass2", "tstAssAtt"',
';call tstCompStmtAA "ass2", "tstAssAr2"',
, '$=tstAssAtt=:¢F2=F2ass3 $$gugus3',
, ':/FR/ F2= FrF2ass3',
, 'FR=:¢F1=r2F1as3',
, 'F2=r2F2as3',
, ' * blabla $$ sdf',
, '!',
, '/FR/ !',
, '$=tstAssAr3 =. ${tstAssAtt.FR.FR}',
, 'call mAdd T.trans, $.$tstAssAr3 "<oAAR3>";',
'call tstCompStmtAA "ass3", "tstAssAtt";',
'call tstCompStmtAA "ass3", "tstAssAr2";',
'call tstCompStmtAA "ass3", "tstAssAr3"',
, '$=tstAssAtt=:¢falsch=falsch$!'
/*
$=/tstCompStmtAsSuTy/
### start tst tstCompStmtAsSuTy ###################################
compile @, 4 lines: call tstCompStmtA2 "begin", "tstAsSuTy"
run without input
begin tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GTF1ini1 F2= F3= FR=
as2 tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GtF1ass2 F2=F2ass2 F3= FR=
$/tstCompStmtAsSuTy/
*/
call classNew 'n? tstAsSuTy u f G1 v, f GT tstAssAtt'
call envPutO 'tstAsSuTy', mNew('tstAsSuTy')
call envPut 'tstAsSuTy.G1', 'G1ini1'
call envPut 'tstAsSuTy.GT.F1', 'GTF1ini1'
call tstComp1 '@ tstCompStmtAsSuTy',
, 'call tstCompStmtA2 "begin", "tstAsSuTy"',
, '$=tstAsSuTy.GT =:¢F1= GtF1ass2',
, 'F2= F2ass2 $!',
, 'call tstCompStmtA2 "as2", "tstAsSuTy"'
/*
$=/tstCompStmtAssSt/
### start tst tstCompStmtAssSt ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSt H1=H1ass2 HS.0=1 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSt/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', mNew('tstAssSt')
call oClear envGetO('tstAssSt')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSt', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass2',
, 'HS =<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"',
, ''
/*
$=/tstCompStmtAssSR/
### start tst tstCompStmtAssSR ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASR>.HS class <clSR??> in EnvPut(ts+
tAssSR.HS.1.F1, HS.1.ini0, )
begin tstAssSR H1=H1ini1 HS.0=1 .
_..1 tstAssSR. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSR H1=H1ass2 HS.0=1 .
_..1 tstAssSR. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSR H1=H1ass3 HS.0=3 .
_..1 tstAssSR. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSR. F1= F2= F3= FR=
_..3 tstAssSR. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSR/
*/
cl = classNew('n? tstAssSR u f H1 v, f HS s r tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSR', mNew('tstAssSR')
call oClear envGetO('tstAssSR')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSR.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSR', '',
, "call mAdd t.trans, $.$tstAssSR '<oASR>'",
", m.tstCl '<clSR??>'",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSR.HS.0', 1",
";call envPutO 'tstAssSR.HS.1', ''",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass2',
, 'HS =<<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, ';call tstCompStmtSt "ass2", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSR"',
, ''
/*
$=/tstCompStmtassTb/
### start tst tstCompStmtassTb ####################################
compile @, 19 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
tstR: @tstWriteoV4 isA :<assCla H1>
tstR: .H1 = H1ass2
ass2 tstAssSt H1=H1ini1 HS.0=2 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
_..2 tstAssSt. F1= F2=h3+f2as2 F3=h3+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=f3as3 FR=
$/tstCompStmtassTb/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', mNew('tstAssSt')
call oClear envGetO('tstAssSt')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtassTb', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢ $@|¢ H1 ',
, ' H1ass2 ',
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<assCla H1>'} $!",
, 'HS =<|¢ $*(...',
, '..$*) F2 F3 ',
, ' hs+f2as2 hs+f3as2 ' ,
, ' * kommentaerliiii ' ,
, ' ' ,
, ' h3+f2as2 h3+f3as22222$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
'$=tstAssSt =:¢H1= H1ass3',
, 'HS =<|¢F2 F3',
, ' f2as3' ,
, ' ',
, ' $""',
, ' f3as3 $! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"'
/*
$=/tstCompStmtassInp/
### start tst tstCompStmtassInp ###################################
compile @, 11 lines: .
run without input
tstR: @tstWriteoV2 isA :<cla123>
tstR: .eins = l1v1
tstR: .zwei = l1v2
tstR: .drei = l1v3
tstR: @tstWriteoV3 isA :<cla123>
tstR: .eins = l2v1
tstR: .zwei = l2v2
tstR: .drei = l21v3
*** err: undefined variable oo in envGetO(oo)
oo before 0
oo nachher <oo>
tstR: @tstWriteoV5 isA :<cla123>
tstR: .eins = o1v1
tstR: .zwei = o1v2
tstR: .drei = o1v3
$/tstCompStmtassInp/
*/
call envRemove 'oo'
call tstComp1 '@ tstCompStmtassInp', '',
, "$@|¢eins zwei drei ",
, " l1v1 l1v2 l1v3",
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<cla123>'}" ,
, " l2v1 l2v2 l21v3",
, "!",
, "$$ oo before $.$oo",
, "$; $>.$oo $@|¢eins zwei drei",
, " o1v1 o1v2 o1v3 $!",
, "$; call mAdd 'T.TRANS', $.$oo '<oo>'",
, "$; $$ oo nachher $.$oo $@$oo"
return
endProcedure tstCompStmtA
tstCompStmtAA: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'F1='left(envGet(ggN'.F1'), 8),
'F2='left(envGet(ggN'.F2'), 8),
'F3='left(envGet(ggN'.F3'), 8),
'FR='envGetO(ggN'.FR')
return
endSubroutine
tstCompStmtA2: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'G1='left(envGet(ggN'.G1'), 8)
call tstCompStmtAA '_..GT', ggN'.GT'
return
endSubroutine
tstCompStmtSt: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'H1='left(envGet(ggN'.H1'), 8),
'HS.0='left(envGet(ggN'.HS.0'), 8)
do sx=1 to envGet(ggN'.HS.0')
call tstCompStmtAA '_..'sx, ggN'.HS.'sx
end
return
endSubroutine tstCompStmtSt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 17 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@|
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
*** err: scanErr comp2code bad fr | to | for @|| .
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@|'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<={ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith with $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun()
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call envPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun()', '$@oRun-{}' ,
, ' $@oRun-{$"-{1 arg only}" ''oder?''}' ,
, ' $@oRun.{$".{1 obj only}" ''oder?''} $=v2=zwei' ,
, ' $@oRun-{$"{2 args}", "und" $v2"?"}' ,
, ' $@oRun-{$"{3 args}", $v2, "und drei?"}'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+ abc
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@.<$dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $>.$eins $@for vv $$ <$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>.$eins $@for vv $$ <$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.$eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
$/tstCompDirSrc/ */
/*
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
$/tstCompDir/ */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@pi2()
$#pi2#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#=, 6 lines: +
zeile 1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#="
return
endProcedure tstCompDir
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
call sqlOIni
call sqlConnect dbaf
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fmtFWriteAll fmtFreset(abc)
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 11 lines: call sqlOIni
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
*/
call tstComp2 'tstCompSql', '@'
return
endProcedure tstCompFile
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DBAF
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* -{sysvar(sysnode) date() time()} ts=$ts 10*len=$-{length($ts) * 10}
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out 20101230 14:34:35
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* -{sysvar(sysnode) date() time()} ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DBAF,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DBAF
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out 20101229 13
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DBAF
$@|¢
db ts
DGDB9998 A976
DA540769 A977
!
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DBAF
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , name ts
from sysibm.sysTablespace
where dbName = '$db' and name < 'A978'
order by name desc
fetch first 2 rows only
$!
$| call sqlSel
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out 20101229
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 36 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977A EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976A EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#@
$=subsys = dbaf
$=lst=<:¢
db = DGDB9998
ts =<|¢
ts
A976
A977
!;
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. mNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out 201012
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dbtf
$@|¢ ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fmtFtab
$|
$=jx=0
$@forWith t $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect dbaf
$#out 20101231 11:56:23
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 46 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlOIni
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
call tstComp2 'tstTut04'
call tstComp2 'tstTut05'
call tstComp2 'tstTut07'
return
endProcedure tstTut0
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call tstOGet
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstEnvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile
call tstFileList
call tstFmt
call tstFmtUnits
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=nZwei new 3=nDrei old free fEins nEins new 4=nVier n+
ew
iter nDrei old free fEins nEins new
iter nZwei new
iter nVier new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1, ,
, "if symbol('m.m') \== 'VAR' then m.m = arg(2) 'new';" ,
"else m.m = arg(2) 'old' m.m",
, "m.m = 'free' arg(2) m.m"
t1 = mNew('tst'm1, 'nEins')
t2 = mNew('tst'm1, 'nZwei')
call mFree t1, 'fEins'
t3 = mNew('tst'm1, 'nDrei')
t4 = mNew('tst'm1, 'nVier')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2o2/
### start tst tstClass2 ###########################################
@CLASS.5 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice v union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .2 refTo @CLASS.6 :class = c
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.7 :class = u
. choice u stem 0
. .3 refTo @CLASS.8 :class = c
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.9 :class = c
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .5 refTo @CLASS.10 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.12 :class = r
. choice r .CLASS refTo @CLASS.5 done :class @CLASS.5
. .6 refTo @CLASS.13 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .7 refTo @CLASS.14 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.16 :class = c
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.15 done :class @CLASS.15
. .9 refTo @CLASS.19 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.20 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.11 done :class @CLASS.11
. .10 refTo @CLASS.21 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.20 done :class @CLASS.20
. .11 refTo @CLASS.22 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.23 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.24 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
$/tstClass2o2/
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.84 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2/ */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: bad type v: classBasicNew(v, tstClassTf12, )
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.3
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.3
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: bad type v:' ,
'classBasicNew(v, tstClassTf12, )'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class.classV m.class.classW m.class.classO) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'m.t.class)
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :CLASS.3
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstO/ */
call tst t, 'tstO'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOGet: procedure expose m.
/*
$=/tstOGet/
### start tst tstOGet #############################################
class.NAME= class
class.NAME= class : w
class| = u
*** err: bad stem index 91>7 @ CLASS.4 class class in oGet(CLASS.4,+
. 91)
class.91 = 0
class.1 = CLASS.1 |= u
class.2 = CLASS.5 |= c
$/tstOGet/ */
call oIni
call tst t, 'tstOGet'
cc = m.class.class
call tstOut t, 'class.NAME=' oGet(cc, 'NAME')
o = oGetO(cc, 'NAME')
call tstOut t, 'class.NAME=' o2String(o) ':' className(objClass(o))
call tstOut t, 'class| =' oGet(cc, '|')
call tstOut t, 'class.91 =' className(oGet(cc, 91))
call tstOut t, 'class.1 =' oGetO(cc, '1') '|=' oGet(cc, '1||')
call tstOut t, 'class.2 =' className(oGetO(cc, '2')) ,
'|=' oGet(cc, '2||')
call tstEnd t
/*
$=/tstOGet2/
### start tst tstOGet2 ############################################
tstOGet1 get1 w
tstOGet1.f1 get1.f1 v
tstOGet1.f2 get1.f2 w
tstOGet1.F3| get1.f3 v
tstOGet1.f3.fEins get1.f3.fEins v
tstOGet1.f3.fZwei get1.f3.fZwei w
tstOGet1.f3%fDrei !get1.f3.fDrei w
tstOGet1.f3.fDrei get1.f3.fDrei w
tstOGet1.f3%1 get1.f3.fDrei.1 w
tstOGet1.f3.2 TSTOGET1
tstOGet1.f3.2|f1 get1.f1 v
tstOGet1.f3.2|f3.2|f2 get1.f2 w
*** err: bad stem index 4>3 @ TSTOGET1.F3 class TstOGet0 in oGet(TS+
TOGET1, F3.4)
tstOGet1.f3.4 0
tstOGet1.f3.3 get1.f3.fDrei.3 w
*** err: bad stem index 3>3A @ TSTOGET1.F3 class TstOGet0 in oGet(T+
STOGET1, F3.3)
tstOGet1.f3.2 0
$/tstOGet2/
*/
c0 = classNew('n? TstOGet0 u f FEINS v,f FZWEI w,f FDREI r,v,' ,
's r TstOGet0')
cl = classNew('n? TstOGet u r, f F1 v, f F2 r, f F3 TstOGet0')
call oMutate tstOGet1, cl
m.tstOGet1 = s2o('get1 w')
m.tstOGet1.f1 = 'get1.f1 v'
m.tstOGet1.f2 = s2o('get1.f2 w')
m.tstOGet1.f3 = 'get1.f3 v'
m.tstOGet1.f3.fEins = 'get1.f3.fEins v'
m.tstOGet1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstOGet1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstOGet1.f3.0 = 3
m.tstOGet1.f3.1 = s2o('get1.f3.fDrei.1 w')
m.tstOGet1.f3.2 = tstOGet1
m.tstOGet1.f3.3 = s2o('get1.f3.fDrei.3 w')
call tst t, 'tstOGet2'
call tstOut t, 'tstOGet1 ' oGet(tstOGet1, )
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call tstOut t, 'tstOGet1.f2 ' oGet(tstOGet1, f2)
call tstOut t, 'tstOGet1.F3| ' oGet(tstOGet1, 'F3|')
call tstOut t, 'tstOGet1.f3.fEins ' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3.fZwei ' oGet(tstOGet1, f3.fZwei)
call tstOut t, 'tstOGet1.f3%fDrei ' oGetO(tstOGet1, 'F3%FDREI')
call tstOut t, 'tstOGet1.f3.fDrei ' oGet(tstOGet1, f3.fDrei)
call tstOut t, 'tstOGet1.f3%1 ' oGet(tstOGet1, 'F3%1')
call tstOut t, 'tstOGet1.f3.2 ' oGetO(tstOGet1, 'F3.2')
call tstOut t, 'tstOGet1.f3.2|f1 ' oGet(tstOGet1, 'F3.2|F1')
call tstOut t, 'tstOGet1.f3.2|f3.2|f2' ,
oGet(tstOGet1, 'F3.2|F3.2|F2')
call tstOut t, 'tstOGet1.f3.4 ' oGet(tstOGet1, 'F3.4')
call tstOut t, 'tstOGet1.f3.3 ' oGet(tstOGet1, 'F3.3')
m.tstOGet1.f3.0 = 3a
call tstOut t, 'tstOGet1.f3.2 ' oGet(tstOGet1, 'F3.3')
call tstEnd t
/*
$=/tstOPut3/
### start tst tstOPut3 ############################################
tstOGet1.f1 get1.f1 v
tstOGet1.f1 aPut1 f1.put1
tstOGet1.f2 aPut2 f2.put2
tstOGet1.f3.fEins p3 f3.fEins,p3
tstOGet1.f3%0 3A
tstOGet1.f3%0 =4 4
tstOGet1.f3.4.feins val f3.4|feins
$/tstOPut3/
*/
call tst t, 'tstOPut3'
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call oPut tstOget1, f1, 'f1.put1'
call tstOut t, 'tstOGet1.f1 aPut1' oGet(tstOGet1, f1)
call oPut tstOget1, f2, 'f2.put2'
call tstOut t, 'tstOGet1.f2 aPut2' oGet(tstOGet1, f2)
call oPut tstOget1, f3.fEins, 'f3.fEins,p3'
call tstOut t, 'tstOGet1.f3.fEins p3' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3%0 ' oGet(tstOGet1, 'F3%0')
call oPut tstOget1, f3.0, 4
call tstOut t, 'tstOGet1.f3%0 =4' oGet(tstOGet1, 'F3%0')
call oPutO tstOget1, 'F3.4', ''
call oPut tstOget1, 'F3.4|FEINS', 'val f3.4|feins'
call tstOut t, 'tstOGet1.f3.4.feins' ,
oGet(tstOGet1, 'F3.4|FEINS')
call tstEnd t
return
endProcedure tstOGet
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWOut.jOpen(<obj s of JRWOut>, <)
*** err: jWrite(<obj s of JRWOut>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jOpen s, m.j.cRead
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while assNN('res', jReadO(b))
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while assNN('ccc', jReadO(c))
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipeBeLa m.j.cRead b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa m.j.cRead c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipeBeLa m.j.cRead b0, m.j.cRead b1, m.j.cRead b2,
, m.j.cRead c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa m.j.cRead c1
call pipeWriteNow
call pipeEnd
call pipeBeLa m.j.cRead c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
$/tstEnvVars/ */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
call pipeBeLa '>' envGetO('theBuf', '-b')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa m.j.cRead envGetO('theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
tstEnvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1| get1 w
tstK1%f1 get1.f1 v
tstK1.f2 get1.f2 w
tstK1%F3 get1.f3 v
ttstK1.F3.FEINS get1.f3.fEins v
tstK1%F3%FZWEI get1.f3.fZwei w
tstK1.F3.FDREI !get1.f3.fDrei w
tstK1%F3%FDREI| get1.f3.fDrei w
tstK1.F3.1 get1.f3.1 w
tstK1%F3%2 TSTEW1
tstK1.F3.2|F1 get1.f1 v
tstK1%F3%2|F3.2|F2 get1.f2 w
*** err: undefined variable F1 in envGet(F1)
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3%FDREI !get1.f3.fDrei w
F3%FDREI| get1.f3.fDrei w
F3%1 get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined variable F1 in envGet(F1)
po-1 F1 0
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call envPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1| ' envGet('tstK1|')
call tstOut t, 'tstK1%f1 ' envGet('tstK1%F1')
call tstOut t, 'tstK1.f2 ' envGet('tstK1.F2')
call tstOut t, 'tstK1%F3 ' envGet('tstK1%F3|')
call tstOut t, 'ttstK1.F3.FEINS ' envGet('tstK1.F3.FEINS')
call tstOut t, 'tstK1%F3%FZWEI ' envGet('tstK1%F3%FZWEI')
call tstOut t, 'tstK1.F3.FDREI ' envGetO('tstK1.F3.FDREI')
call tstOut t, 'tstK1%F3%FDREI| ' envGet('tstK1%F3%FDREI')
call tstOut t, 'tstK1.F3.1 ' envGet('tstK1.F3.1')
call tstOut t, 'tstK1%F3%2 ' envGetO('tstK1%F3%2')
call tstOut t, 'tstK1.F3.2|F1 ' envGet('tstK1.F3.2|F1')
call tstOut t, 'tstK1%F3%2|F3.2|F2' ,
envGet('tstK1%F3%2|F3%2|F2')
call tstOut t, 'F1 ' envGet('F1')
call envPushWith tstEW1
call tstOut t, 'F1 ' envGet('F1')
call tstOut t, 'f2 ' envGet('F2')
call tstOut t, 'F3 ' envGet('F3|')
call tstOut t, 'F3.FEINS ' envGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' envGet('F3.FZWEI')
call tstOut t, 'F3%FDREI ' envGetO('F3%FDREI')
call tstOut t, 'F3%FDREI| ' envGet('F3%FDREI|')
call tstOut t, 'F3%1 ' envGet('F3%1')
call tstOut t, 'pu1 F1 ' envGet('F1')
call envPushWith tstEW2
call tstOut t, 'pu2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-1 F1 ' envGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3.F1 = v(c3.f1)
*** err: no reference @ <c3>.F1 class CLASS.1 in envGet(c3.F1.FEINS+
)
. s c3.F1.FEINS = 0
. s c3.F3.FEINS = .
. s c3.F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS @ <c3> class TstEW in envGet(c3.FEINS)
. s c3.FEINS = 0
*** err: null @ <c3> class TstEW in envGet(c3|FEINS)
. s c3|FEINS = 0
aft Put s c3|FEINS = val(c3|FEINS)
Push c3 s F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS aftPuP= pushPut(F3 @ <c3>.F3 class TstEW0 i+
n envGet(F3.FEINS aftPuP= pushPut(F3.FEINS))
. s F3.FEINS aftPuP= 0
push c4 s F1 = v(c4.f1)
put f2 s F2 = put(f2)
*** err: no field F222 in class TstEW in EnvPut(F222, f222 stopped,+
. 1)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3.f1)
*** err: undefined variable F1 in envGet(F1)
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = mNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3.f1)'
call envPutO 'c3', c3
call tstEnvSG , 'c3.F1'
call tstEnvSG , 'c3.F1.FEINS'
call tstEnvSG , 'c3.F3.FEINS'
call envPut 'c3.F3.FEINS', 'val(c3.F3.FEINS)'
call tstEnvSG , 'c3.F3.FEINS'
call tstEnvSG , 'c3.FEINS'
call tstEnvSG , 'c3|FEINS'
call envPut 'c3|FEINS', 'val(c3|FEINS)'
call tstEnvSG 'aft Put', 'c3|FEINS'
call envPushWith c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call envPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG , 'F3.FEINS aftPuP=' envGet('F3.FEINS')
c4 = mNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4.f1)'
call envPut f222, 'f222 no stop'
call envPushWith c4
call tstEnvSG 'push c4', f1
call envPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call envPut f222, 'f222 stopped', 1
call envPut f3.fEins, 'put(f3.fEins)'
call tstEnvSG 'put .. ', f3.fEins
call envPopWith
call tstEnvSG 'popW c4', f1
call envPopWith
call envPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
/*
$=/tstEW4/
### start tst tstEW4 ##############################################
tstO4 S.0 0 R.0 0 class TstEW4
*** err: no field FZWEI in class in EnvPut(FZWEI, v 1.fZwei, 1)
1 fEins s FEINS = v 1.fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1.fEins .# 1 vor
v 1.fEins .# 2 nach withNext e
*** err: undefined variable FEINS in envGet(FEINS)
? fEins s FEINS = 0
1 fEins s FEINS = v 1|fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1|fEins .# 2
$/tstEW4/
*/
c4 = classNew('n? TstEW4 u f S s TstEW0, f R s r TstEW0')
o4 = mReset('tstO4', 'TstEW4')
call tst t, 'tstEW4'
call tstout t, o4 'S.0' m.o4.s.0 'R.0' m.o4.r.0 ,
'class' className(objClass(o4))
call envPushWith o4'.S', m.c4.f2c.s, 'asM'
call envPut fZwei, 'v 1.fZwei', 1
call envWithNext 'b'
call envPut feins, 'v 1.fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
m.o4.s.2.feins = 'vorher'
m.o4.s.2.fZwei = s2o('vorher')
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'vor'
call envWithNext 'e'
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'nach withNext e'
call envPopWith
call tstEnvSG '? fEins ', fEins
call envPushWith o4'.R', m.c4.f2c.r, 'asM'
call envWithNext 'b'
call envPut fEins, 'v 1|fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call envWithNext 'e'
call envPopWith
o41r = m.o4.r.1
call tstOut t, m.o41r.fEins '.#' m.o4.r.0
call tstEnd t
return
endProcedure tstEnvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' envGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen oCast(m, "JBuf"), opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose oCast(m, "JBuf"), opt')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr";' ,
'return jRead(m.m.rdr, var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa m.j.cRead s2o(tstPdsMbr(pd2, 'eins')), m.j.cRead b,
,m.j.cRead jBuf(),
,m.j.cRead s2o(tstPdsMbr(pd2, 'zwei')),
,m.j.cRead s2o(tstPdsMbr(pds, 'wr0')),
,m.j.cRead s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFWriteAll fmtFreset(abc), b
call fmtFAddFlds fmtFReset(abc), oFlds(m.st.1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, b
call tstEnd t
return
endProcedure tstFmt
tstfmtUnits: procedure
/*
$=/tstFmtUnits/
### start tst tstFmtUnits #########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -59s0 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -59s0 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -10m1 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -59m5 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -23h1 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -23h3 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d0 --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d1 --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> ----d --> -9999d
. 863965440 ==> ++++d ++> 10000d -+> ----d --> -----d
. 8.6400E+9 ==> ++++d ++> +++++d -+> ----d --> -----d
. .3 ==> 0.300 ++> 0.300 -+> -0.300 --> -0.300
. .8 ==> 0.800 ++> 0.800 -+> -0.800 --> -0.800
. 1 ==> 1.000 ++> 1.000 -+> -1.000 --> -1.000
. 1.2 ==> 1.200 ++> 1.200 -+> -1.200 --> -1.200
. 59 ==> 59.000 ++> 59.000 -+> -59.000 --> -59.000
. 59.07 ==> 59.070 ++> 59.070 -+> -59.070 --> -59.070
. 59.997 ==> 59.997 ++> 59.997 -+> -59.997 --> -59.997
. 60 ==> 60.000 ++> 60.000 -+> -60.000 --> -60.000
. 60.1 ==> 60.100 ++> 60.100 -+> -60.100 --> -60.100
. 611 ==> 611.000 ++> 611.000 -+> -611.00 --> -611.000
. 3599.4 ==> 3k599 ++> 3k599 -+> -3k599 --> -3k599
. 3599.5 ==> 3k600 ++> 3k600 -+> -3k600 --> -3k600
. 3661 ==> 3k661 ++> 3k661 -+> -3k661 --> -3k661
. 83400 ==> 83k400 ++> 83k400 -+> -83k400 --> -83k400
. 999999.44 ==> 999k999 ++> 999k999 -+> -999k99 --> -999k999
. 999999.5 ==> 1M000 ++> 1M000 -+> -1M000 --> -1M000
. 567.6543E6 ==> 567M654 ++> 567M654 -+> -567M65 --> -567M654
. .9999991E9 ==> 999M999 ++> 999M999 -+> -999M99 --> -999M999
. .9999996E9 ==> 1G000 ++> 1G000 -+> -1G000 --> -1G000
. .9999991E12 ==> 999G999 ++> 999G999 -+> -999G99 --> -999G999
. .9999996E12 ==> 1T000 ++> 1T000 -+> -1T000 --> -1T000
. 567.6543E12 ==> 567T654 ++> 567T654 -+> -567T65 --> -567T654
. .9999991E15 ==> 999T999 ++> 999T999 -+> -999T99 --> -999T999
. .9999996E15 ==> 1P000 ++> 1P000 -+> -1P000 --> -1P000
. .9999991E18 ==> 999P999 ++> 999P999 -+> -999P99 --> -999P999
. .9999996E18 ==> 1E000 ++> 1E000 -+> -1E000 --> -1E000
. 567.6543E18 ==> 567E654 ++> 567E654 -+> -567E65 --> -567E654
. .9999991E21 ==> 999E999 ++> 999E999 -+> -999E99 --> -999E999
. .9999996E21 ==> 1000E ++> 1000E -+> -1000E --> -1000E
. .9999992E24 ==> 999999E ++> 999999E -+> ------E --> -999999E
. .9999995E24 ==> ++++++E ++> 1000000E -+> ------E --> -------E
. 10.6543E24 ==> ++++++E ++> +++++++E -+> ------E --> -------E
$/tstFmtUnits/ */
call jIni
call tst t, "tstFmtUnits"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)
end
lst = subword(lst, 1, 14) 999999.44 999999.5,
567.6543e6 .9999991e9 .9999996e9 .9999991e12 .9999996e12 ,
567.6543e12 .9999991e15 .9999996e15 .9999991e18 .9999996e18 ,
567.6543e18 .9999991e21 .9999996e21 .9999992e24 .9999995e24 ,
10.6543e24
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)
end
call tstEnd t
return
endProcedure tstfmtUnits
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b), m.j.cRead)
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b), '>')
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)), '>')
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa m.j.cRead m, '>' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
return s2o(m.m.in.ix)
end
call tstOut m, '#jIn eof' ix'#'
return ''
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
m.tstErrHandler.0 = 0
call outPush tstErrHandler
call errSay ggTxt
call outPop
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy time begin ---------------------------------------------------*/
timeTest: procedure
numeric digits 32
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
say 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call timeReadCvt 1
say 'tst2jul('t1') ' tst2jul(t1)
say 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
say 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
say 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
say 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
say 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
say 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
say 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
say 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
/* say 'conv2tod('t1')' conv2tod(t1) /* gmt --> stck */
say 'conv2ts('s1')' conv2ts(s1) /* stck --> gmt */
*/ return
endProcedure timeTest
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 32
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutin timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN:
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/* copy time end -----------------------------------------------------*/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFTab: procedure expose m.
call fmtFWriteAll fmtFReset('FMTF.F')
return
endProcedure fmtFTab
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, rdr, wiTi
b = env2buf(rdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(m.st.1)
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, m.st.sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = m.st.sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa */
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo */
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
call compIniKI '=', "skeleton", "expression or block"
call compIniKI '.', "object", "expression or block"
call compIniKI '-', "string", "expression or block"
call compIniKI '@', "shell", "pipe or $;"
call compIniKI ':', "assignAttributes", "assignment or statement"
call compIniKI '|', "assignTable", "header, sfmt or expr"
call compIniKI '#', "text", "literal data"
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@:|'
m.m.chKin2 = '.-=#;:|'
m.m.chKinC = '.-=@'
m.m.chOp = '.-<@|?'
m.m.chOpNoFi = '.-@|?'
return m
endProcedure compReset
compIniKI: procedure expose m.
parse arg ki, m.comp.kind.ki.name, m.comp.kind.ki.expec
return
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
if src \== '' then
m.nn.cmpRdr = o2File(src)
else
m.nn.cmpRdr = ''
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO
cmp = comp(inO)
r = compile(cmp, spec)
if ouO \== '' then
call pipeBeLa '>' ouO
call oRun r
if ouO \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKind) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc m.m.scan, spec
m.m.compSpec = 1
res = compCUnit(m, kind, 1)
do while abbrev(m.m.dir, '$#')
call envPutO substr(m.m.dir, 3, length(m.m.dir)-4),
, compCUnit(m, right(m.m.dir, 1))
end
if \ m.m.compSpec then
call jClose m.m.scan
return res
endProcedure compile
/*--- cUnit = compilation Unit = separate compilations
no nesting| --------------------------------------------*/
compCUnit: procedure expose m.
parse arg m, ki, isFirst
s = m.m.scan
code = ''
do forever
m.m.dir = ''
src = compUnit(m, ki, '$#')
if \ compDirective(m) then
return scanErr(s, m.comp.kind.ki.expec "expected: compile",
m.comp.kind.ki.name "stopped before end of input")
if \ compIsEmpty(m, src) then do
/*wkTst??? allow assTb in separatly compiled units */
if isFirst == 1 & m.src.type == ':' ,
& pos(' ', src) < 1 & abbrev(src, 'COMP.AST.') then
call mAdd src, '', ''
code = code || ';'compAst2code(m, src, ';')
end
if m.m.dir == 'eof' then do
if \ m.m.compSpec | m.m.cmpRdr == '' then
return oRunner(code)
call scanReadReset s, m.m.cmpRdr
call jOpen s, m.j.cRead
m.m.compSpec = 0
end
else if length(m.m.dir) == 3 then
ki = substr(m.m.dir, 3, 1)
else
return oRunner(code)
end
endProcedure compCUnit
/*--- directives divide cUnits ---------------------------------------*/
compDirective: procedure expose m.
parse arg m
m.m.dir = ''
s = m.m.scan
lk = scanLook(s)
cx = pos('#', lk, 3)
if \ abbrev(lk, '$#') then do
if \ scanAtEnd(m.m.scan) then
return 0
m.m.dir = 'eof'
return 1
end
else if scanLit(s, '$#end' , '$#out') then do
m.m.dir = 'eof'
return 1
end
else if pos(substr(lk, 3, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if cx > 3 & pos(substr(lk, cx+1, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, cx+1)
end
else
call scanErr s, 'bad directive:' strip(l)
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan, 'directive mismatch' m.m.dir
return 1
endProcedure compDirective
/**** parse the whole syntax *******************************************
currently, with the old code generation,
parsing and code generation is intermixec
migrating to AST should will separate these tasks
***********************************************************************/
compUnit: procedure expose m.
parse arg m, kind, stopper
s = m.m.scan
if pos(kind, m.m.chKind';') < 1 then
return scanErr(s, 'bad kind' kind 'in compUnit(...'stopper')')
if stopper == '}' then do
if kind \== '#' then do
one = compExpr(m, 'b', translate(kind, ';', '@'))
if compisEmpty(m, one) then
return compAST(m, 'block')
else
return compAST(m, 'block', one)
end
tx = '= '
cb = 1
do forever /* scan nested { ... } pairs */
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
return compAst(m, 'block', tx)
end
else if pos(kind, '.-=') > 0 then do
return compData(m, kind)
end
else if pos(kind, '@;') > 0 then do
call compSpNlComment m
return compShell(m)
end
else if kind == '|' | kind == ':' then do
if kind == '|' then
res = compAssTab(m)
else
res = compAssAtt(m)
if abbrev(res, '#') then
return compAst(m, ':', substr(res, 3))
else
return compAst(m, ';', substr(res, 3))
end
else if kind == '#' then do
res = compAST(m, 'block')
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata until' stopper
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then do
if stopper = '$#' then
leave
call scanErr s, 'eof in heredata until' stopper
end
end
return res
end
endProcedure compUnit
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compAST(m, 'block')
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
a = compAst(m, ';')
m.a.text = ''
do forever
one = compPipe(m)
if one \== '' then
m.a.text = m.a.text || one
if \ scanLit(m.m.scan, '$;') then
return a
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsbw') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock,
, if(type=='w', m.m.chNotWord,m.m.chDol))
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki, 1)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki, withChain
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if withChain then do
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
compObj: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '?')
one = compBlock(m, ki pk)
if one \== '' then
return compAstAddOp(m, one, ki)
pp = ''
if pk \== '' then do
ki = right(pk, 1)
pp = left(pk, length(pk)-1)
end
one = compPrimary(m, translate(ki, '.', '@'), 0)
if one \== '' then
return pp || one
if ki == '.' then do
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKinC) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return pp'. compile(comp(env2Buf()), "'m.s.tok'")'
end
end
call scanBack s, pk
return ''
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compCheckNE(m, compExprBlock(m, '='),
, 'block or expr expected for file')
if \ abbrev(res, '.') then do
end
else if substr(res, verify(res, '.', n), 3) == '0* ' then do
st = word(res, 2)
if m.st.0 = 1 & abbrev(m.st.1, '. envGetO(') then
/* if undefined variable use new jbuf */
if pos(')', m.st.1) == length(m.st.1) then
m.st.1 = left(m.st.1, length(m.st.1)-1) ,
|| ", '-b')"
end
return compASTAddOp(m, res, '<')
endProcedure compFile
/*--- scan an operator chain and a kind ------------------------------*/
compOpKi: procedure expose m.
parse arg m, opt
s = m.m.scan
op = ''
if opt == '<' then do
call scanVerify s, m.m.chOpNoFi
op = m.s.tok
if scanLit(s, '<') then
return op'<'
end
call scanVerify s, m.m.chOp
op = op || m.s.tok
k1 = scanLook(s, 1)
if k1 \== '' & pos(k1, m.m.chKind) > 0 then do
call scanLit s, k1
return op || k1
end
if opt == '?' | op == '' | pos(right(op, 1), m.m.chKind) > 0 then
return op
call scanErr s, 'no kind after ops' op
endProcedure compOpKi
/*--- block or expression --------------------------------------------*/
compExprBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '<')
if right(pk, 1) == '<' then
return compAstAddOp(m, compFile(m), pk)
res = compBlock(m, ki pk)
if res \== '' then
return res
if pk \== '' then
lk = right(pk, 1)
else
lk = translate(ki, '.', '@')
res = compExpr(m, 's', lk)
if res \== '' then
return compASTAddOp(m, res, pk)
call scanBack s, pk
return res
endProcedure compExprBlock
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
res = compAss(m)
if res == '' then
call scanErr s, 'assignment expected after $='
return res
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNE(m, compExprBlock(m, '@'),
, "block or expr expected after $@"))
fu = m.s.tok
if fu == 'for' | fu == 'with' | fu == 'forWith' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m, 'with'),
, "statement after $@for" v))
if fu == 'forWith' then
st = 'call envSetWith envGetO('v');' st
if abbrev(fu, 'for') then
st = 'do while envReadO('v');' st'; end'
if fu == 'forWith' then
st = 'call envPushWith "";' st '; call envPopWith'
else if fu == 'with' then
st = 'call envPushName' v';' st '; call envPopWith'
return ';' st
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
call compSpComment m
suf = compExpr(m, 's', ';')
if \ compIsEmpty(m, suf) then
suf = comp2Code(m, ':'suf)
else if var \== '' then
call scanErr s, "$@do control construct expected"
else
suf = ''
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInter('return' comp2Code(m, '-'nm)), st
return '; '
end
if scanLit(s, '(') then do
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '{', '.{', '-{', '={') then do
br = m.s.tok
a = compExpr(m, 'b', if(br == '{', '-', left(br, 1)))
if \ scanLit(s, '}') then
call scanErr s, 'closing } expected after $@'fu || br
res = '; call oRun envGetO("'fu'")'
if pos(left(a, 1), 'ec') < 1 then
res = res',' comp2code(m, a)
return res
end
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
end
if scanLit(s, '$$') then
return compCheckNN(m, compExprBlock(m, '='),
, 'block or expression expected after $$')
return ''
endProcedure compStmt
compAss: procedure expose m.
parse arg m, aExt
s = m.m.scan
sla = scanLook(s)
slx = verify(sla, m.m.chKind'/'m.m.chOp, 'n')
if slx > 0 then
sla = left(sla, slx-1)
sla = pos('/', sla) > 0
nm = ''
if \ sla then do
nm = compExpr(m, 'b', '=')
if compIsEmpty(m, nm) then
return ''
nm = comp2Code(m, '-'nm)
if \ scanLit(s, "=") then
return scanErr(s, '= expected after $=' nm)
end
m.m.bName = ''
vl = compCheckNE(m, compExprBlock(m, '='),
, 'block or expression after $=' nm '=')
if sla then
if m.m.bName == '' then
call scanErr s, 'missing blockName'
else
nm = "'"m.m.bName"'"
va = compAstAftOp(m, vl)
if va \== '' & m.va.type == ':' then do
pu = "call envPushName" nm
if abbrev(m.m.astOps, '<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else if abbrev(m.m.astOps, '<<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else
call mAdd va, pu ", 'as1'", "call envPopWith"
return va
end
if compAstKind(m, vl) == '-' then
return '; call envPut' nm',' comp2Code(m, vl)aExt
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)aExt
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, dKi ops
s = m.m.scan
if \ scanLit(s, '{', '¢', '/') then
return ''
start = m.s.tok
if (ops \== '' & pos(right(ops, 1), m.m.chKind) < 1) ,
| pos(dKi, m.m.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block (def' dKi')')
if ops == '' then do
ki = dKi
end
else do
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
end
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper) then do
if pos(ki, ':|') < 1 | \ abbrev(stopper, '$') then
call scanErr s, 'ending' stopper 'expected after' starter
else if \ scanLit(s, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'or' substr(stopper, 2),
'expected after' starter
end
if abbrev(starter, '/') then
m.m.bName = substr(starter, 2, length(starter)-2)
else
m.m.bName = ''
if m.res.text == '' then
m.res.text = ' '
return compAstAddOp(m, res, ops)
endProcedure compBlock
compAssAtt: procedure expose m. aClass
parse arg m
res = ''
aClass = ''
s = m.m.scan
last = ''
do forever
if compSpNlComment(m, '*') then do
end
else if pos(scanLook(s, 1), '/!}') > 0 then do
leave
end
else if scanLit(s, ';', '$;') then do
if last = ';' then
res = res'; call envWithNext'
last = ';'
end
else do
s1 = compAss(m, ", 1")
if s1 == '' then do
s1 = compStmt(m)
if s1 == '' then
leave
end
else do
if last == ';' then
res = res'; call envWithNext'
last = 'a'
end
res = res';' comp2code(m, ';'s1)
end
if res == '' then
res = ';'
end
if last == '' then
return res
else
return '# call envWithNext "b";' res ,
'; call envWithNext "e";'
endProcedure compAssAtt
compAssTab: procedure expose m. aClass
parse arg m
s = m.m.scan
call compSpNlComment m, '*'
hy = 0
tab = ''
do forever
bx = m.s.pos
if \ scanName(s) then
leave
hx = hy + 1
h.hx.beg = bx
if hx > 1 & bx <= h.hy.end then
call scanErr s, 'header overlap' m.s.tok 'pos' bx
h.hx = m.s.tok
tab = tab', f' m.s.tok 'v'
h.hx.end = m.s.pos
hy = hx
call compSpComment m, '*'
end
if tab \== '' then
aClass = classNew('n* Ass u' substr(tab, 3))
res = ''
isFirst = 1
do while scanReadNl(s)
do forever
call compSpNlComment m, '*'
s1 = compStmt(m)
if s1 == '' then
leave
res = res';' comp2code(m, ';'s1)
last = 's'
end
if pos(scanLook(s, 1), '/!}') > 0 then
leave
do qx=1
bx = m.s.pos
s1 = compExpr(m, 'w', '=')
if compIsEmpty(m, s1) then
leave
ex = m.s.pos
if ex <= bx then
return scanErr(s, 'colExpr backward')
do hy=1 to hx while bx >= h.hy.end
end
hz = hy+1
if hz <= hx & ex > h.hz.beg then
call scanErr s, 'value on hdr' h.hy 'overlaps' h.hz
else if hy > hx | bx >= h.hy.end | ex <= h.hy.beg then
call scanErr s, 'value from' bx 'to' ex ,
'no overlap with header' h.hy
if qx > 1 then
nop
else if isFirst then do
res = res"; call envWithNext 'b', '"aClass"'"
isFirst = 0
end
else
res = res"; call envWithNext"
res = res"; call envPut '"h.hy"'," comp2Code(m, "-"s1)", 1"
call compSpComment m, '*'
end
end
if isFirst then
return res
else
return '#' res"; call envWithNext 'e'"
endProcedure compassTab
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
sp = 0
co = 0
do forever
if scanVerify(s, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else if xtra == '' then
leave
else if \ scanLit(s, xtra) then
leave
else do
co = 1
m.s.pos = 1+length(m.s.src)
end
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/**** small helper routines ******************************************/
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
if pos(' ', ex) < 1 & pos('COMP.AST.', ex) > 0 then do
a = substr(ex, pos('COMP.AST.', ex))
a = compAstAftOp(m, a)
if m.a.type = 'block' then
return 0 /* m.a.0 == 0 */
else
return m.a.text == ''
end
e1 = word(ex, 1)
return ex = '' | verify(e1, 'ec', 'm') > 0
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Graph ***************************************
goal is to migrate to migrate to old codeGenerator to AST
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, tp
n = mNew('COMP.AST')
m.n.type = tp
if wordPos(tp, 'block') > 0 then do
do cx=1 to arg()-2
m.n.cx = arg(cx+2)
end
m.n.0 = cx-1
end
else do
m.n.text = arg(3)
m.n.0 = 0
end
m.a.isAnnotated = 1
return n
endProcedure compAST
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if ops == '' then
return a
if pos('COMP.AST.', a) < 1 then
return ops || a
if m.a.type = 'ops' then do
m.a.text = ops || m.a.text
return a
end
n = compAst(m, 'ops', ops)
call mAdd n, a
return n
endProcedure compAstAddOp
/*--- return the first AST after the operand chain
put the operands into m.m.astOps ---------------------------*/
compASTaftOp: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return ''
do while m.a.type == 'ops'
m.m.astOps = m.a.text || m.m.astOps
a = m.a.1
end
return a
endProcedure compASTAftOpType
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.type == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
/*--- return the code for an AST with operand chain trg --------------*/
compAst2Code: procedure expose m.
parse arg m, a, aTrg
if pos(' ', a) > 0 | \ abbrev(a, 'COMP.AST.') then
return comp2Code(m, aTrg || a)
if \ abbrev(a, 'COMP.AST.') then
call err 'bad ast' a
do while m.a.type == 'ops'
aTrg = aTrg || m.a.text
a = m.a.1
end
trg = compAstOpsReduce(m, aTrg)
if m.a.type == translate(right(trg, 1), ';', '@') then do
if length(trg) == 1 then do
if pos(trg, ';@') > 0 then
return 'do;' m.a.text ';end'
else
return m.a.text
end
else
return compAST2Code(m, a, left(trg, length(trg)-1))
end
if m.a.type == 'block' then do
op = right(trg, 1)
tLe = left(trg, length(trg)-1)
call compASTAnnBlock m, a
if pos(m.a.maxKind, '.-<') > 0 & pos(op, '.-|?') > 0 then do
if m.a.0 = 1 then do
o1 = if(op=='-', '-', '.')
r = compAst2Code(m, m.a.1, o1)
r = compC2C(m, o1, compAstOpsReduce(m, tLe||o1), r)
if pos(op, '.-<') > 0 then
return '('r')'
else
return r
end
if m.a.0 = 0 & op == '?' then
return compC2C(m, '.', compAstOpsReduce(m, tLe'.'))
if op == '-' then do
cd = ''
do cx = 1 to m.a.0
cd = cd '('compAst2Code(m, m.a.cx, '-')')'
end
return compC2C(m, '-', trg, substr(cd, 2))
end
call scanErr m.m.scan, 'bad block cardinality' aTrg
end
cd = ''
do cx = 1 to m.a.0
cd = cd';' compAst2Code(m, m.a.cx, ';')
end
if right(trg, 1) == '@' then
trg = overlay(';', trg, length(trg))
return compC2C(m, ';', trg, 'do;' cd'; end')
end
else if m.a.type == ';' then do
return compC2C(m, ';', trg, m.a.text)
if right(trg, 1) == '-' then
return compAst2Code(m, "- o2String('"oRunner(m.a.text)"')",
, trg)
if right(trg, 1) == '<' then
return compAst2Code(m, "< o2File('"oRunner(m.a.text)"')",
, trg)
end
else if m.a.type == ':' then do
if m.a.0 = 0 then
call mAdd a, 'call envPushWith', 'call envPopWith'
return compC2C(m, ';', trg,
, 'do;' m.a.1';' m.a.text';' m.a.2'; end')
end
trace ?r
call scanErr m.m.scan, 'implement type' m.a.type 'for' a 'trg' trg
endProcedure compAst2Code
/*--- do a chain of code transformations
from code of kind fr by opList
op as from kind operand
= constant -
- rexx string Expr cast to string/ concat file/output
. rexx object Expr cast to object
< rexx file Expr cast to file
; rexx Statements execute, write obj, Str
@ - cast to ORun, run an obj, write file
| - extract exactlyOne
? - extract OneOrNull
----------------------------------------------------------------------*/
compC2C: procedure expose m.
parse arg m, fr, opList, code
oldCode = fr':' code '==>' opList '==>'
do tx=length(opList) by -1 to 1
to = substr(opList, tx, 1)
if fr == to then
iterate
nn = '||||'
if to == '-' then do
if fr == '=' then
nn = quote(code)
else if abbrev(fr code, '. envGetO(') then
nn = 'envGet(' || substr(code, 9)
else if fr == ';' then
nn = "o2String('"oRunner(code)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("code")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(code))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('code')'
else if fr == '<' then
nn = code
else if fr == ';' then
nn = quote(oRunner(code))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' code
else if fr == '<' then
nn = 'call pipeWriteAll' code
else if fr == ';' then
nn = code
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(code)
else if fr == '-' then
nn = 'call out' code
else if fr == '.' | fr == '<' then
nn = 'call outO' code
end
else if to == ':' then do
if fr == '=' then
nn = quote(code)
else
nn = code
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('code')'
else if fr == '=' then
nn = "file("quote(code)")"
else if fr == '.' then
nn = 'o2File('code')'
else if fr == ';' then
nn = 'o2File('oRunner(code)')'
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then
nn = 'fileSingle('code if(to == '|','', ", ''")')'
else if fr == '@' | fr == ';' then
/* ???wkTst optimize: do it directly */
nn = compC2C(m, fr, to'<', code)
to = '.'
end
if nn == '||||' then
return scanErr(m.m.scan,
,'compC2C bad fr' fr 'to' to 'list' opList)
fr = to
code = nn
end
return code
endProcedure compC2C
/*--- reduce a chain of operands -------------------------------------*/
eliminate duplicates and identity transformations ----------*/
compAstOpsReduce: procedure expose m.
parse arg m, ops
ki = ops
ki = space(translate(ops, ' ', 'e('), 0)
fr = ';<; <;< -.- <@<'
to = '; < - < '
fr = fr '== -- .. << ;; @@ @('
to = to '= - . < ; @ (@'
wc = words(fr)
do until ki = oldKi
oldKi = ki
do wx=1 to wc
do forever
wf = word(fr, wx)
cx = pos(wf, ki)
if cx < 1 then
leave
ki = left(ki, cx-1) || word(to, wx) ,
|| substr(ki, cx+length(wf))
end
end
end
return ki
endProcedure compASTOpsReduce
/*--- annotate a block if necessary ----------------------------------*/
compASTAnnBlock: procedure expose m.
parse arg m, a
if m.a.isAnnotated == 1 then
return
mk = ''
do cx=1 to m.a.0
c = m.a.cx
if pos(' ', c) > 0 | \ abbrev(c, 'COMP.AST.') then
ki = left(c, 1)
else if \ abbrev(c, 'COMP.AST.') then
return scanErr(m.m.scan, 'bad ast' c 'parent' a) /0
else
call scanErr m.m.scan, 'implement kind of' c 'type' m.c.type
if pos(ki, '=-.<;@:|') < 1 then do
if pos(ki, 'el0') < 1 then
call err 'bad kind' ki
end
else if mk == '' | pos(ki, '=-.<;@:|') > pos(mk, '=-.<;@:|') then
mk = ki
end
m.a.maxKind = mk
m.a.isAnnotated = 1
return
endProcedrue compASTAnnBlock
/**** old code generator ***********************************************
plan is to replace it with AST ******************************/
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
if expr == '' & pos(' ', ki) < 1 & pos('COMP.AST.', ki) > 0 then do
cx = pos('COMP.AST.', ki)
return compAst2Code(m, substr(ki, cx), left(ki, cx-1))
end
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 | (to == '*' & fr == '*') then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
toBef = to
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' | fr == '<' then
nn = 'call outO' expr
else if fr == '#' then
nn = 'call envPushWith ;'expr'; call envPopWith'
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then do
nn = 'fileSingle('expr if(to == '|','', ", ''")')'
to = '.'
end
else if fr == '@' | fr == ';' then do
to = to'<'fr
nn = expr
end
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' toBef 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ @( $l $0 @#'
to.2 = '= - . < ; ( (- (. (; < ; @ @ (@ $ $ ;#'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; ;<( <(; @(- @(l |(l ?(l'
to.3 = ' 0; l; - - . . ; ;< <; ;(- ;(l (|l (?l'
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 then do
if trgt == '|' | trgt == '?' then
return left(m.st.1, 1) comp2Code(m, m.st.1)
else if trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
end
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
do forever
cl = scanUtil(sc)
if cl == '' then
return 0
if cl = 'n' & m.sc.tok == 'INTO' then
leave
end
if scanUtil(sc) \== 'n' | m.sc.tok \== 'TABLE' then
call scanErr sc, 'bad into table '
if \ scanSqlQuId(scanSkip(sc)) then
call scanErr sc, 'table name expected'
if m.sc.utilBrackets \== 0 then
call scanErr sc, 'into table in brackets' m.sc.utilBrackets
m.m.tb = m.sc.val
m.m.part = ''
do forever
cl = scanUtil(sc)
if cl == '' then
call scanErr sc, 'eof after into'
if cl == 'n' & m.sc.tok == 'PART' then
if scanUtil(sc) == 'v' then
m.m.part = m.sc.val
else
call scanErr sc, 'bad part'
if cl == 'n' & m.sc.tok == 'WHEN' then do
if scanUtil(sc) \== '(' then
call scanErr sc, '( nach when expected'
do while m.sc.utilBrackets > 0
call scanUtil sc
end
end
if cl == '(' then
leave
end
oX = m.sc.lineX
oL = overlay('', m.sc.src, 1, m.sc.pos-2)
do while m.sc.utilBrackets > 0
call scanUtil sc
if oX \== m.sc.lineX then do
call out strip(oL, 't')
oX = m.sc.lineX
oL = m.sc.src
end
end
call out left(oL, m.sc.pos)
call jClose sc
return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call mapReset env.vars
m.env.with.0 = 0
call mapReset env.c2w
call mNewArea 'ENV.WICO', '='
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
call jOpen m.e.in, m.j.cRead
if m.e.out == '' then
m.e.out = m.j.out
call jOpen m.e.out, m.e.outOp
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, m.j.cRead)
m.f.out = jOpen(Cat(), '>')
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFrame: procedure expose m.
m = oMutate(mBasicNew("PipeFrame"), "PipeFrame")
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = '>'
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
call jClose m.m.in
call jClose m.m.out
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outPush: procedure expose m.
parse arg st
call pipeBeLa '>' oNew('JRWOut', st)
return
endProcedure outPush
outPop: procedure expose m.
call pipeEnd
return
endProcedure outPop
/*--- returnall from rdr (rsp in) to a new jBuf --------------------*/
env2Rdr: procedure expose m.
parse arg rdr
if rdr == '' then
return m.j.in
cl = objClass(rdr, '')
if cl == '' then
return jBuf(rdr)
if classInheritsOf(cl, class4Name('JRW')) then
return r
trace ?r
say cl rdr
return jBuf(o2string(rdr))
endProcedure env2Rdr
envCatLines: procedure expose m.
parse arg rdr, opt
if rdr == '' then
return jCatLines(m.j.in, opt)
cl = objClass(rdr, '')
if cl == '' then
return jCat1(rdr, opt)
if classInheritsOf(cl, class4Name('JRW')) then
return jCatLines(rdr, opt)
return jCat1(o2String(rdr), opt)
endProcedure envCatLines
env2Buf: procedure expose m.
parse arg rdr
if rdr == '' then do
rdr = m.j.in
cl = objClass(rdr, '')
end
else do
cl = objClass(rdr, '')
if cl == '' then
return jBuf(rdr)
if \ classInheritsOf(cl, class4Name('JRW')) then
return jBuf(o2String(rdr))
end
if classInheritsOf(cl, class4Name('JBuf')) & m.rdr.jUsers < 1 then
return rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure env2Buf
envIsDefined: procedure expose m.
parse arg na
return '' \== mapValAdr(env.vars, na)
endProcedure envIsDefined
envPushWith: procedure expose m.
parse arg obj, cl, fn, elCl
tos = m.env.with.0 + 1
m.env.with.0 = tos
m.env.with.tos.fun = fn
m.env.with.tos.muElCl = ''
if fn == '' then do
call envSetWith obj, cl
return
end
if cl == '' then
cl = objClass(obj)
if fn == 'as1' then do
call envSetWith obj, cl
m.env.with.tos.muElRef = m.cl.valueCl \== '',
& m.cl.valueCl \== m.class.classV
if m.env.with.tos.muElRef then
m.env.with.tos.muElCl = m.cl.valueCl
else
m.env.with.tos.muElCl = cl
return
end
else if fn \== 'asM' then
call err 'bad fun' fn
if m.cl.stemCl == '' then
call err 'class' className(cl) 'not stem'
cc = m.cl.stemCl
isRef = m.cc == 'r'
m.env.with.tos.muElRef = isRef
if m.cc \== 'r' then
m.env.with.tos.muElCl = cc
else if elCl \== '' then
m.env.with.tos.muElCl = elCl
else if m.cc.class == '' then
call err 'elCl null for envPushWith('obj ','cl ','multi', ...)'
else
m.env.with.tos.muElCl = m.cc.class
m.env.with.tos.class = ''
m.env.with.tos.muCla = cl
m.env.with.tos.muObj = obj
return
endProcedure envPushWith
envSetWith: procedure expose m.
parse arg obj, cl
if cl == '' & obj \== '' then
cl = objClass(obj)
tos = m.env.with.0
m.env.with.tos = obj
m.env.with.tos.class = cl
return
endProcedure envSetWith
envWithObj: procedure expose m.
tos = m.env.with.0
if tos < 1 then
call err 'no with in envWithObj'
return m.env.with.tos
endProcedure envWithObj
envAccPath: procedure expose m. m cl
parse arg pa, stop, nllNw
nullNew = nllNw == 1
dx = verify(pa, m.class.cPath, 'm')
if dx = 0 then do
n1 = pa
p2 = ''
end
else do
n1 = left(pa, dx-1)
p2 = substr(pa, dx)
end
wCla = ''
do wx = m.env.with.0 by -1 to if(stop==1, m.env.with.0, 1)
wCla = m.env.with.wx.class
if symbol('m.wCla.f2c.n1') == 'VAR' then
return oAccPath(m.env.with.wx, pa, m.env.with.wx.class)
end
if stop == 1 then
return 'no field' n1 'in class' className(wCla)
vv = mapValAdr(env.vars, n1)
if vv \== '' then
if p2 == '' then
return oAccPath(vv, '', m.class.classR)
else
return oAccPath(vv, '|'p2, m.class.classR)
else if nullNew & p2 == '' then
return oAccPath(mapValAdr(env.vars, n1,'a'), p2,m.class.classR)
else
return 'undefined variable' pa
endProcedure envAccPath
envWithNext: procedure expose m.
parse arg beEn, defCl, obj
tos = m.env.with.0
if tos < 1 then
call err 'envWithNext with.0' tos
st = m.env.with.tos.muObj
if beEn == 'b' then do
if m.env.with.tos.fun == 'asM' then
m.st.0 = 0
if m.env.with.tos.muElCl == '' then
m.env.with.tos.muElCl = defCl
end
else if m.env.with.tos.fun == 'asM' then
m.st.0 = m.st.0 + 1
else if m.env.with.tos.fun == '' then
call outO m.env.with.tos
else if beEn = '' then
call err 'no multi allowed'
if beEn == 'e' then
return
if m.env.with.tos.fun == 'as1' then do
if m.env.with.tos == '' then
call err 'implement withNext null'
return
end
/* if obj \== '' then do
if \ m.env.with.tos.muElRef then
call err 'obj but not ref'
m.nn = obj
call envSetWith obj
end
*/
if m.env.with.tos.fun == '' then do
call envSetWith mNew(m.env.with.tos.muElCl)
return
end
nn = st'.' || (m.st.0 + 1)
if m.env.with.tos.muElRef then do
m.nn = mNew(m.env.with.tos.muElCl)
call envSetWith m.nn
end
else do
call mReset nn, m.env.with.tos.muElCl
call envSetWith nn
end
return
endProcedure envWithNext
envPushName: procedure expose m.
parse arg nm, multi, elCl
res = envAccPath(nm, , 1)
if res \== 1 then
return err(res 'in envPushName('nm',' multi')')
do while m.cl == 'r'
if m.m == '' then do
res = oRefSetNew(m, cl)
if res \== 1 then
call err res 'in envPushName('nm',' multi')'
end
m = m.m
cl = objClass(m)
end
call envPushWith m, cl, multi, elCl
return
endProcedure envPushName
envNewWiCo: procedure expose m.
parse arg co, cl
k1 = strip(co cl)
n = mapGet('ENV.C2W', k1, '')
if n \== '' then
return n
k2 = k1
if co \== '' then do
k2 = strip(m.co.classes cl)
n = mapGet('ENV.C2W', k2, '')
end
k3 = k2
if n == '' then do
cx = wordPos(cl, m.co.classes)
if cx > 0 then do
k3 = space(subWord(m.co.classes, 1, cx-1),
subWord(m.co.classes, cx+1) cl, 1)
n = mapGet('ENV.C2W', k3, '')
end
end
if n == '' then
n = envNewWico2(co, k3)
call mapAdd 'ENV.C2W', k1, n
if k2 \== k1 then
call mapPut 'ENV.C2W', k2, n
if k3 \== k2 & k3 \== k1 then
call mapPut 'ENV.C2W', k3, n
return n
endProcedure envNewWiCo
envNewWiCo2: procedure expose m.
parse arg co, clLi
n = mNew('ENV.WICO')
if co == '' then
m.n.level = 1
else
m.n.level = m.co.level + 1
m.n.classes = clLi
na = ''
do cx = 1 to words(clLi)
c1 = word(clLi, cx)
na = na className(c1)
do qx=1 to 2
ff = c1 || word('.FLDS .STMS', qx)
do fx = 1 to m.ff.0
fn = m.ff.fx
if fn == '' then
iterate
fn = substr(fn, 2)
m.n.f2c.fn = cx
end
end
end
m.n.classNames = space(na, 1)
return n
endProcedure envNewWiCo2
envPopWith:procedure expose m.
tos = m.env.with.0
m.env.with.0 = tos - 1
return
endProcedure envPopWith
envGet: procedure expose m.
parse arg na
res = envAccPath(na)
if res == 1 then
res = oAccStr(m, cl)
if res == 1 then
return str
return err(res 'in envGet('na')')
endProcedure envGet
envGetO: procedure expose m.
parse arg na, opt
res = envAccPath(na, , opt == '-b')
if res == 1 then
res = oAccO(m, cl, opt)
if res == 1 then
return ref
return err(res 'in envGetO('na')')
endProcedure envGetO
envPutO: procedure expose m.
parse arg na, ref, stop
res = envAccPath(na, stop, 1)
if res == 1 then
res = ocPutO(m, cl, ref)
if res = 1 then
return ref
return err(res 'in envPutO('na',' ref',' stop')')
endProcedure envPutO
envPut: procedure expose m.
parse arg na, va, stop
res = envAccPath(na, stop , 1)
if res == 1 then
res = ocPut(m, cl, va)
if res == 1 then
return va
return err(res 'in EnvPut('na',' va',' stop')')
endProcedure envPut
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
res = inO()
if res == '' then
return 0
call envPutO na, res
return 1
endProcedure envReadO
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
res = jReadO(m.m.catRd)
if res \== '' then
return res
call catNextRdr m
end
return ''
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
fileSingle: procedure expose m.
parse arg m
call jOpen m, '<'
res = jReadO(m)
two = jReadO(m)
call jClose m
if res == '' then
if arg() < 2 then
call err 'empty file in fileSingle('m')'
else
res = arg(2)
if two \== '' then
call err '2 or more recs in fileSingle('m')'
return res
endProcedure fileSingle
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
call oAdd1Method m.class.classV, 'o2File return file(m.m)'
call oAdd1Method m.class.classW, 'o2File return file(substr(m,2))'
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.class.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class.classV
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.fileTso.buf = m.fileTso.buf + 1
m.m.defDD = 'CAT'm.fileTso.buf
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
m.m.dsn = m.dsnAlloc.dsn
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = mNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
interpret fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, var)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
m.sqlO.cursors = left('', 10, 'r')left('', 30, ' ')
call sqlIni
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
"m.m.fetch = ''; m.m.cursor=''",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
/* call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
*/ return
endProcedure sqlOini
sqlSel: procedure expose m.
parse arg src, type
call pipeWriteAll oNew('SqlSel', envCatLines(src, '-s'), type)
return
endProcedure sqlSel
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', envCatLines(src, '-s'), type)
endProcedure sqlRdr
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor(m.m.cursor)
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
if m.m.fetch == '' then
call sqlFetchIni m, 'M.V'
m.m.jReading = 1
return m
endProcedure sqlOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg last
cx = 0
if datatype(last, 'n') & last>0 & last<=length(m.sqlO.cursors) then
if pos(substr(m.sqlo.cursors, last, 1), 'c ') > 0 then
cx = last
if cx == 0 then
cx = pos(' ', m.sqlo.cursors)
if cx == 0 then
cx = pos('c', m.sqlo.cursors)
if cx = 0 then
call err 'no more cursors' m.sqlo.cursors
m.sqlo.cursors = overlay('o', m.sqlo.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if cx < 1 | cx > length(m.sqlo.cursors) then
call err 'bad cursor sqlFreeCursor('cx')'
m.sqlo.cursors = overlay('c', m.sqlo.cursors, cx)
return cx
endProcedure sqlFreeCursor
/*--- create a type for a sqlDA --------------------------------------*/
sqlDA2type: procedure expose m.
parse arg da , ind
endProcedure sqlDA2Type
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchIni: procedure expose m.
parse arg m, pre
da = 'SQL.'m.m.cursor'.D'
if m.m.type = '' | m.m.type == '*' then do
ff = ''
do ix=1 to m.da.sqlD
/* fetch uppercases variable names */
f1 = translate(word(m.da.ix.sqlName, 1))
if f1 == '' | pos(', f' f1 'v', ff) > 0 then
f1 = 'COL'ix
ff = ff', f' f1 'v'
end
m.m.type = classNew('n* SQL u' substr(ff, 3))
end
vv = ''
cn = ''
cl = class4name(m.m.type)
f = cl'.FLDS'
do ix=1 to min(m.f.0, m.da.sqlD)
if translate(m.f.ix) \== m.f.ix then
call err 'fld' ix m.f.ix 'not uppercase for sql'
vv = vv', :'pre || m.f.ix
if m.da.ix.sqlType // 2 = 1 then do
cn = cn'; if' pre || m.f.ix'.'m.sqlInd '< 0 then',
pre || m.f.ix '= "'m.sqlNull'"'
vv = vv' :'pre || m.f.ix'.'m.sqlInd
end
end
m.m.fetch = substr(vv, 3)
m.m.checkNull = substr(cn, 3)
return
endProcedure sqlFetchIni
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
v = mNew(m.m.type)
if \ sqlFetchInto(m.m.cursor, m.m.fetch) then
return ''
interpret m.m.checkNull
return v
endProcedure sqlSelRead
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
delsqlFetch: procedure expose m.
parse arg cx, dst
if \ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
call sqlPushRetOk
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
res = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if res == 0 then
return 1
if res == 100 then
return 0
return res
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return res
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRetOk
return sqlExec("disconnect ", ggRetOk, 1)
endProcedure sqlDisconnect
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCodeWarn()
end
else do
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\n',
|| sqlCodeWarn()
end
signal off syntax
end
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
sqlCodeWarn:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
return 'no warnings'
else
return 'warnings'ggWarn
endProcedure sqlCodeWarn
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, opt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = jCat1(m.line)
if \ abbrev(opt, '-', 1) then
do while jRead(m, line)
res = res || opt || m.line
end
else if opt == '-s' then
do while jRead(m, line)
res = res strip(m.line)
end
else if opt == '-72' then
do while jRead(m, line)
res = res || left(m.line, 72)
end
call jClose m
return res
endProcedure jCatLines
jCat1: procedure expose m.
parse arg v, opt
if \ abbrev(opt, '-', 1) then
return v
if opt == '-s' then
return strip(v)
if opt == '-72' then
return left(v, 72)
call err 'bad opt' opt 'in jCat1('v',' opt')'
endProcedure jCat1
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRWO', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), " ")')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0 /* ?????wktst */
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
/* ?????wktst */
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
return 0
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
if arg() > 0 then
say ' ' arg(1)
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/