zOs/war/rexo131
}¢--- A540769.WK.REXX.O13(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.O13(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.O13(DREP) cre=2013-01-22 mod=2013-01-23-12.06.49 A540769 ---
/* rexx ***************************************************************
dRep: distribute rc Query user defined reports
synopsis: dRep fun dbSy
fun : Funktion
a: alle Loeschen und mit kidi63 standard reports ueberschreiben
d: alle Loeschen
i: insert kidi63 standard reports, die noch nicht definiert sind
o: overwrite existing and nonExisting ones with kidi63 standards
n: kein update und nicht mehr fragen
u: update kidi63 standart reports, if a new release
?: this help
dbSy: list of db2Systems (group Name, z.B. DBAF) oder * for all
**********************************************************************/
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, 'ADINOUV') < 1 then
call err '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 'no db2System in dRep' fun allDb
cr = userid()
say '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 'bad db2System' dbSy 'in dRep' fun allDb
call sqlConnect dbSy
if fun = 'U' then do
fun = needUpdate(fun, cr)
if fun == '' then
return
end
say dbSy'...'
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
say 'already current version' m.cVers
return ''
end
say 'A = alle bestehenden UserDefined Reports Loeschen'
say ' und mit kidi63 standard reports ueberschreiben'
say 'I = nur noch nicht existierende einfuegen'
say 'N = kein update und nicht mehr nachfragen'
say '- = Ende ohne Mutation'
parse upper pull ant
a1 = left(strip(ant), 1)
if pos(a1, 'ADINO') > 0 then
return a1
say 'keine Mutationen, manuelle Mutation mit 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' 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 = '??'"
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 = 'RZ1 RZ2 RZ8 RZZ RR2 RQ2'
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.rz8.dbSys = 'DC0G DCVG DD0G DV0G DP8G DX0G'
m.rzInfo.rzz.dbSys = 'DE0G DEVG'
return
endProcedure rzInfo
/* copy sql begin ***************************************************
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
/*--- 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
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
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(-1, sqlCode,,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(-1, 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 cx, res, cnt, verb src, plus
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt == '' then
if cx \== -1 & m.sql.cx.updateCount \== '' then
cnt = m.sql.cx.updateCount
else if symbol('SQLERRD.3') == 'VAR' then
cnt = sqlErrd.3
if cnt \== '' then
if \ datatype(cnt, 'n') then
res = res',' cnt
else if wordPos(m.sql.cx.fun, 'DELETE INSERT UPDATE') > 0 then
res = res"," cnt 'rows' ,
translate(m.sql.cx.fun, m.mAlfLC, m.mAlfUC)'d'
else if cnt <> 0 then
res = res"," cnt 'rows updated'
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if verb \== '' then do
ll = 75 - length(res)
aa = strip(verb 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.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 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 = ''
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 *****************************************************/
/* 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.O13(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.O13(DSNRLI) cre=2010-06-16 mod=2010-06-16-13.24.14 A540769 ---
/* rexx */
say 'calling'
call dsnRli 'abc'
say rc
}¢--- A540769.WK.REXX.O13(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.O13(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.O13(EDLI) cre=2006-05-29 mod=2006-05-29-10.56.30 F540769 ---
/* REXX *************************************************************
this editmacro replaces all #dt# by the current date time
**********************************************************************/
call adrEdit('macro (args) NOPROCESS')
say 'macro args' args
call adrEdit '(l3Be) = line 3'
call adrEdit 'process dest range Q R'
call adrEdit '(lfr) = linenum .zfrange'
call adrEdit '(lTo) = linenum .zLrange'
call adrEdit '(lAf) = linenum .zDest'
call adrEdit '(l3Af) = line 3'
say 'from' lfr 'to' lTo 'after' lAf
say 'line 3 before' l3Be
say 'line 3 after ' l3Af
exit
call isrEdit 'linnums dest range q'
tst = time('N')
tst = 'D'date('j')'.T'left(tst,2)substr(tst, 4, 2)right(tst,2)
say 'timestamp' tst
call adrEdit "c '#dt#' '"tst"' all"
exit 0
/************** member copy adr **************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnGetLLQ: get the llq from a dsn
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
***********************************************************************/
say dsnApp("a.b c(d e) f' ))) h")
say dsnApp("'a.b c(d e) f' ))) h")
call help
call errHelp(test errHelp)
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return dsn"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnGetLLQ: procedure
parse arg dsn
rx = pos('(', dsn) - 1
if rx < 0 then
rx = length(dsn)
lx = lastPos('.', dsn, rx)
return strip(substr(dsn, lx+1, rx-lx), 'b', "'")
endProcedure dsnGetLLQ
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg lvGrp, lvSt
return readNext(lvGrp, lvSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
end lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
call sequence: readBegin, readNext*, readEnd
1. arg (dd) dd name, wird alloziert in begin und free in end
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr reuse dsn('dsn')'
return /* end readBegin */
readNext:
parse arg lv_DD, lv_St
if adrTsoRc('execio 100 diskr' lv_DD '(stem' lv_St')') = 0 then
return 1
else if rc = 2 then
return (value(lv_St'0') > 0)
else
call err 'execio 100 diskr' lv_DD 'rc' rc
return /* end readNext */
readEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
call adrTso 'free dd('dd')'
return /* end readEnd */
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
variable Expansion: replace variable by their value
***********************************************************************/
varExpandTest: procedure
m.v.eins ='valEins'
m.v.zwei ='valZwei'
m.l.1='zeile eins geht unverändert'
m.l.2='$EINS auf zeile ${ZWEI} und \$EINS'
m.l.3='...$EINS?auf zeile ${ZWEI}und $EINS'
m.l.4='...$EINS,uf zeile ${ZWEI}und $EINS$$'
m.l.5='${EINS}$ZWEI$EINS${ZWEI}'
m.l.0=5
call varExpand l, r, v
do y=1 to m.r.0
say 'old' y m.l.y
say 'new' y m.r.y
end
return
endProcedure varExpandTest
varExpand: procedure expose m.
parse arg old, new, var
varChars = ,
'0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
do lx=1 to m.old.0
cx = 1
res = ''
do forever
dx = pos('$', m.old.lx, cx)
if dx < cx then do
m.new.lx = res || strip(substr(m.old.lx, cx), 't')
leave
end
res = res || substr(m.old.lx, cx, dx - cx)
if dx >= length(m.old.lx) then
call err '$ at end line m.'old'.'lx'='m.old.lx
if substr(m.old.lx, dx+1, 1) = '$' then do
res = res || '$'
cx = dx + 2
iterate
end
if substr(m.old.lx, dx+1, 1) = '{' then do
cx = pos('}', m.old.lx, dx+1)
if cx <= dx then
call err 'ending } missing line m.'old'.'lx'='m.old.lx
na = substr(m.old.lx, dx+2, cx-dx-2)
cx = cx + 1
end
else do
cx = verify(m.old.lx, varChars, 'N', dx+1);
if cx <= dx then
cx = length(m.old.lx) + 1
na = substr(m.old.lx, dx+1, cx-dx-1)
end
if symbol('m.v.na') = 'VAR' then
res = res || m.var.na
else
call err 'var' na 'not defined line m.'old'.'lx'='m.old.lx
end
m.new.0 = m.old.0
end
return /* var expand */
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggStmt, ggNo
if ggNo <> '1' then
ggStmt = 'execSql' ggStmt
address dsnRexx ggStmt
if rc = 0 then
nop /* say "sql ok:" ggStmt */
else if rc > 0 then
say "sql warn rc" rc sqlmsg()':' ggStmt
else
call err "sql rc" rc sqlmsg()':' ggStmt
return
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 0 then do
sRC = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
say 'subcom' sRc
end
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
if sqlCode = 0 then
return 'ok (sqlCode=0)'
else
return 'sqlCode='sqlCode,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
err:
parse arg txt
parse source s1 s2 s3 .
say 'fatal error in' s3':' txt
exit 12
errHelp: procedure
parse arg errMsg
say 'fatal error:' errMsg
call help
call err errMsg
endProcedure errHelp
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return
endProcedure help
showtime:
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
}¢--- A540769.WK.REXX.O13(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.O13(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.O13(ELARDROP) cre=2013-06-07 mod=2013-07-29-13.58.54 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
elarDrop v grp vsam rename/alter (job erstellen)
nach check
elarDrop d grp vsam rename/alter (job erstellen)
nach check
http://chw20025641/host/db2wiki/pmwiki.php?n=App.ElarDrop
20. 6.13 Walter neu
***********************************************************************/
parse arg mArg
if pos('?', fun grp rest) > 0 then
exit help()
m.noVsamFail = 0
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 disp01'
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 '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
db = strip(substr(i.lx, 22, 8))
/* if sql2one("select count(*) from" m.tb ,
"where db = '"db"'") <> 0 then
call err 'db' db 'already in' m.tb
*/ call sqlUpdate , "insert into" m.tb "(tst,kind,nm,db,info)" ,
"values ('"m.tst"', 'disp req', '"grp"', '"db"'" ,
", '"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, 10)
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
db = 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(db), 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'
call oRun compInline('db2Cmd')
do dx= 1 to m.dbs.0
db = m.dbs.dx
/* call sql2St "select strip(name) ts from sysibm.sysTablespace" ,
"where dbName = '"db"'", tsL
do tx=1 to m.tsL.0
call out '-sto db('db')' */
call out '-sto db('db') sp(*)'
/* end */
end
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'
call err 'implement drop'
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 == '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
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
call getDbs grp
if wordPos(fun, 's r p') < 1 then
call err 'checkInfos bad fun' fun
fuNo = 'e}'fun 'for' grp 'not allowed:'
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
call err fuNo 'check=ollOK but dbs='m.dbs.0 '<>' ci
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 = 'lastStart lastStaUt rtCopyUpdate rtUpdTst riUpdTst'
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
limDays = if(fun == 's', 7, 30)
limit = sql2One("select current timestamp -" limDays "days lim" ,
", current timestamp now" ,
", current timestamp - 1 days lim1" ,
"from sysibm.sysDummy1",dt)
afLim = 'newer' limDays 'days'
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 fu \== '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
call err 'checkInfos ok for' fun
do dx=dx by -1 to 2 while m.disp.dx.tst >> limit
end
if dx <= 2 then
call err fuNo 'last info' afLim
td = fWord('tsDis=', iL, fuNo)
if td \== 'tsDis=STOP' then
call err fuNo td 'at' m.disp.dx.tst
ti = fWord('ixDis=', iL, fuNo)
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='m.o.tsDis 'ixDis='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
statsDisMerge: procedure expose m.
parse arg l, r
if pos('+'r'+', '+'l'+') > 0 then
return l
l = translate(l, ' ', '+')
r = translate(r, ' ', '+')
do rx=1 to words(r)
if wordPos(word(r, rx), l) < 1 then
l = l word(r, rx)
end
return translate(strip(l), '+', ' ')
endProcedure statsDisMerge4
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(*)'
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 do
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
e = 'db' db 'bad -dis line' m.dsp.dx
m = getTsIx(word(m.dsp.dx, 1), 'TP IP')
if (dKi = 'TS' & m.m.kind \== 'tp') ,
| (dKi = 'IX' & m.m.kind \== 'ip') then
e = 'ts ix mismatch' dx m.dsp.dx
if m.m.dis \== '' then
e = 'db' db '.dis already' m.m.dis 'dis' m.dsp.dx
m.m.dis = word(m.dsp.dx, 3)
end
if e == '' then do
dx = dx+1
if dx <> m.dsp.0 | \ abbrev(m.dsp.dx, 'DSN9022I') then
e = '-dis bad end' dx m.dsp.dx
end
rTp = ''
do xTp = 1 to m.tp.0
if m.tp.xTp.dis = '' then
call e = e xTp 'tp' m.tp.xTp.nm 'not in -dis'
m.tp.xTp.info = m.tp.xTp.info 'dis='m.tp.xTp.dis
if wordPos(m.tp.xTp.dis, rTp) < 1 then
rTp = rTp m.tp.xTp.dis
end
rTp = translate(strip(rTp), '+', ' ')
m.ds.1.tsDis = rTp
if pos(';'rTp';', m.o.tsDis) < 1 then
m.o.tsDis = statsDisMerge(m.o.tsDis, rTp)
m.o.tsDis = statsDisMerge(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='m.ip.xIp.dis
if wordPos(m.ip.xIp.dis, rIx) < 1 then
rIx = rIx m.ip.xIp.dis
end
rIx = translate(strip(rIx), '+', ' ')
m.ds.1.ixDis = rIx
m.o.ixDis = statsDisMerge(m.o.ixDis, rIx)
m.ds.1.info = m.ds.1.info 'tsDis='rTp 'ixDis='rIx
if e == '' then
return
say 'error' e
call saySt dsp
call err e':'dx m.dsp.dx
endProcedure dbDisplay
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=T,TIME=1440,SCHENV=$dbSys,
// NOTIFY=&SYSUID,REGION=0M
//$'*'MAIN CLASS=LOG
$/jc/
$=/dbCmd/
//DB2CMD EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSys)
$/dbCmd/
$=/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/
//SQL 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, 4)
$=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=A540769.WK.REXX
//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=A540769.WK.REXX
//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=A540769.WK.REXX
//SYSTSIN DD *
%elarDrop $fun $grp
$/exeED/
$=/db2Cmd/
//DB2CMD EXEC PGM=IKJEFT01
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYS($dbSys)
$/db2Cmd/
*/
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
queryStartOld: procedure expose m.
parse arg aGrp
s = m.disp.1.info
s = word(substr(s, pos('stop=', s)+5), 1)
s = translate('1234-56-78-00.00.00', s, '12345678')
do dx=m.disp.0 by -1 to 2 ,
while pos('tsDis=STOP ', m.disp.dx.info) > 0
end
dx = dx+1
if dx > m.disp.0 then
return 'restart=notStopped'
if s << m.disp.dx.tst then
s = m.disp.dx.tst
since = "(timestamp('"s"') - 1 months)"
if staSq << s then
res = 'reStart=ok lastStart='word(staSq, 1)
else
res = 'reStart=err lastStart='translate(space(staSq,1),'+',' ')
????????
queryStart: procedure expose m.
parse arg aGrp
dx=m.disp.0
if pos('tsDis=STOP ', m.disp.dx.info) < 1 then
return ''
call sqlConnect envGet('dp2g')
staSq = m.sqlNull
staUt = m.sqlNull
since = 'current timestamp - 12 months'
do dx=1 to m.dbs.0
db = m.dbs.dx
tstCmd = "left(char(timestamp), 19) || ' ' || strip(cmd)"
call sql2st "select" ,
"max(case when upper(cmd) not like '%ACC(UT)%'",
"then" tstCmd "else null end) sta",
",max(case when upper(cmd) like '%ACC(UT)%'",
"then" tstCmd "else null end) stut",
"from oa1p.tAdmCmd",
"where timestamp >=" since "and verb = 'START'" ,
"and upper(cmd) like '%"db"%'" , qs
if m.qs.1.sta >> staSq then
staSq = m.qs.1.sta
if m.qs.1.stUt >> staUt then
staUt = m.qs.1.stUt
end
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' db k1 ox ,
"\nnm:" m.oo.ox.nm '>>' m.nn.ox.nm,
"\ninfo:" m.oo.ox.info "\n>>>>:" m.nn.ox.info
call queryInfoComp db, 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' db k1 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
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'
call csiNext csD, fd
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 = 'orph'
if symbol('m.ms.vsamCl') <> 'VAR' then do
m.ms.vsamCl = 0
m.ms.vsamDa = 0
m.ms.kind = 'orphan'
m.ms.nm = 'orphan'
end
end
m.ms.vsamCl = m.ms.vsamCl + 1
vx = vx+1
dsd = overlay('D', m.fc, cx)
rbas=''
do while abbrev(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
m.ms.vsamDa = m.ms.vsamDa + 1
if \ csiNext(csD, fd) then
m.fd = ' eof '
end
if m.ms.vsamCl \== m.ms.vsamDa then
call err 'cl' m.ms.vsamCl '<> da' m.ms.vsamDa
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 err '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 err '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 err '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
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 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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(ERR) cre=2013-01-23 mod=2013-09-23-11.29.53 A540769 ---
/* 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 *****************************************************/
}¢--- A540769.WK.REXX.O13(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.O13(EXALL) cre= mod= -------------------------------------
/* rexx */
call checkDsn sysproc file
call checkDsn tmp.jcl
call checkDsn 'tmp.jcl(noex)'
call checkDsn "'OMS.DIV.P0.STAT.RZ1.Y04M03'"
call checkDsn "'PVSP.U0000.T0.PVXDUMP.D05161.T144149'"
call checkDsn "'PVSP.U0000.T0.PVXDUMP.D05164.T081555'"
exit
dsn = 'tmp.ex'
address tso delete dsn
address tso 'alloc dsn('dsn') dd(x) reuse new ' ,
'dataclas(VB0256S0) mgmtclas(S005Y000)'
say 'alloc rc' rc
call checkDsn dsn
exit
checkDsn:
parse arg dsn
say 'dsn' dsn
say ' sysdsn ' sysdsn(dsn)
drop sysmsglvl1 sysmsglvl2 sysused sysalloc
ff = listDsi(dsn 'norecall')
say ' listDsi no' ff ', sysReason' sysReason
say ' dsName ' SYSDsName
say ' volume ' SYSVolume 'unit' sysUnit
say ' msglvl1 ' SYSMSGLVL1
say ' msglvl2 ' SYSMSGLVL2
say ' used ' sysUsed', alloc' sysAlloc sysUnits
address tso 'alloc dd(dd0) shr dsn('dsn')'
say ' alloc rc' rc
address tso 'free dd(dd0)'
say ' free rc' rc
return
}¢--- A540769.WK.REXX.O13(EXARGS) cre=2009-05-28 mod=2013-05-22-10.02.33 A540769 ---
/* rexx ****************************************************************
example rexx arguments:
say number of arguments and each argument
***********************************************************************/
parse arg a1, a2
say 'rexx exArgs at' time() 'on' sysvar(sysnode) 'user' userid()
say 'with' arg() 'arguments:' a1',' a2
say 'rexx exArgs 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.O13(EXCSM) cre=2013-05-17 mod=2013-06-03-15.32.23 A540769 ---
/* rexx ----------------------------------------------------------------
csm examples |||||||| include neue incs ||||||
functions:
sub rz: submit job to local or remote rz
exe rz cmd: execute rexx on remote rz
----------------------------------------------------------------------*/
call errReset hi
parse arg mArg
if mArg = '' then
address isrEdit 'macro (mArg)'
if mArg = '' then
call errHelp 'no input'
call adrTso 'csmAppc get cvidvar(aha)', '*'
m.inCsmAppc = wordPos(rc, 0 25) > 0
say 'get cvidvar rc='rc appc_cvid 'inCsmAppc' m.inCsmAppc
say 'exCsm calling' mArg
rc = '?'
result = '?'
interpret 'call' mArg
say 'rc='rc 'result='result 'after call' mArg
exit
sub: procedure expose m.
parse arg rz
if rz = '' | rz = sysvar(sysNode) then
rz = 'local'
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 == 'local' then
call adrTso 'alloc dd(sub) sysout writer(intRdr)'
else /* mit freeClose braeuchte es keine Free */
call adrTso 'csmExec allocate system('rz')' ,
'ddName(rmtsprt) rmtddname(systsprt) writer(intRdr)'
call writeDD 'sub', i., 4
call writeDDEnd 'sub'
call adrTso 'free dd(sub)' /* csmExec free macht dasselbe */
return
endProcedure sub
/*--- start a rexx locally under csmAppc
sta1 ---> sta2 ----------------------------------------*/
sta1: procedure expose m.
parse arg rz
call adrTso "CSMAPPC START PGM(CSMEXEC)",
"Parm('Select Cmd(''%exCsm sta2 ''''" rz "und via pct exCsm'''''')')"
/* "PARM(""SELECT TSOCMD('exec ''A540769.WK.REXX(exCsm)''" ,
"''sta2" rz "und viel weiter''')"")" */
return
endProcedure sta1
sta2: procedure expose m.
parse arg rz
say 'called sta2 with arg' rz
return
endProcedure sta2
/*--- 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 adrTso 'csmExec allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrTso 'csmExec allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrTso 'csmExec allocate system('rz')' ,
'ddName(rmtsin) disp(new) space(5,10) cylinder lrecl(80)' ,
'recfm(fb) rmtddn(systsin) dataset(tmp.tsin)' ,
'blksize(8000)'
call adrTso 'csmExec 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 adrTso 'csmExec allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrTso 'csmExec 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 adrTso 'csmExec allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrTso 'csmExec allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
call csmAppcRc 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 adrTso "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 adrTso 'csmExec allocate system('rz') disp(shr)',
"dataset('"A540769.wk.rexx"') ddname(sysproc)"
call adrTso 'csmExec 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 adrTso 'csmExec allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrTso 'csmExec allocate ddName(rmtSys) system('rz')' ,
'timeout(60) disp(new) dataset(tmp.rmt)'
call adrTso 'csmExec allocate system('rz')' ,
'ddName(rmtsprt) disp(new) space(5,10) cylinder lrecl(133)' ,
'recfm(fba) rmtddn(systsprt) dataset(tmp.prt)'
call adrTso 'csmExec 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 csmAppcRc ggTsoCmd
buf = 'erstes send' time() 'von dlg2'
call adrTso "csmAppc send CVID(X'"pId"') buffer(buf) TYPE(2)", '*'
call csmAppcRc ggTsoCmd
buf = 'zweites send' time() 'von dlg2 soso'
call adrTso "csmAppc send CVID(X'"pId"') buffer(buf) TYPE(3)", '*'
call csmAppcRc ggTsoCmd
call adrtso "csmappc receive cvid(x'"pId"') buffer(BUF)", '*'
call csmAppcRc ggTsoCmd
say 'buf' length(buf)':' buf
call adrTso "CSMAPPC DEALLOC CVID(X'"pId"') TYPE(3)", '*'
call csmAppcRc 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 adrTso 'CSMAPPC GET CVIDVAR(var)', '*'
call csmAppcRc ggTsoCmd
say ' appc_DD='appc_ddName 'llu='appc_llu 'plu='appc_plu
pId = appc_cvid
call adrtso "csmappc receive cvid(x'"pId"') buffer(BUF)"
call csmAppcRc ggTsoCmd
say 'buf' length(buf)':' buf
call adrtso "csmappc receive cvid(x'"pId"') buffer(BUF)"
call csmAppcRc ggTsoCmd
say 'buf' length(buf)':' buf
buf = 'antwort von dlg3' args 'um' time() 'an dlg2 auf:' buf
call adrTso "csmAppc send CVID(X'"pId"') buffer(buf) TYPE(3)", '*'
call csmAppcRc ggTsoCmd
return
endProcedure dlg3
csmAppcRc: 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 csmAppcRc
/*--- send an sql to csmASql and fetch result ------------------------*/
sql: procedure expose m.
parse arg rz dbSys
sql_query = 'select current server "srv", current timestamp',
'from sysibm.sysDummy1'
sql_host = rz
sql_db2ssid = dbSys
drop sql_cvid sql_option
call sendSql rz, dbSys,
, 'select current server "srv", current timestamp',
'from sysibm.sysDummy1'
return
endProcedure sql
/*--- send an sql to csmASql and display result ----------------------*/
sendSql: procedure expose m. sql_Option sql_cvid sqlcvid
/* fill variables */
parse arg sql_host, sql_db2ssid, sql_query
say 'exCsm sql sending with csmASql to' sql_host'/'sql_db2ssid
say 'sql_query' sql_query
address linkPgm csmAsql
if m.inCsmAppc then /* wir sind schon in csmAPPC */
call adrTso "CSMASQL"
else /* wir muessen die csmAPPC Umgebung
erst aufbauen| */
call adrTso "CSMAPPC START PGM(CSMASQL)", '*'
/* show result, filled in variables/stems */
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_name.'i Left(Sqlda_Name.I,20),
'sqlda_rexxname.'i Left(Sqlda_Rexxname.I,20),
'sqlda_type.'i Sqlda_Type.I,
'sqlda_types.'i Left(Sqlda_Types.I,25),
'sqlda_len.'iSqlda_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
/*--- start sqlUOW2 locally in csmAppc -------------------------------*/
sqlUOW1: procedure expose m.
parse arg rz dbSys .
call adrTso "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.inCsmAppc 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 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
readDD returns true if data read, false at eof
***********************************************************************/
/*--- 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
writeDDClose:
parse arg dd
return adrTso('execio 0 diskw' dd '(finis)')
/*--- 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)
m.m.dd = m.tso.allocDD
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 SYSOUT DUMMY') > 0 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 tsoDD(dd, 'o') 'call tsoFree dd'
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
m.tso.allocDD = tsoDD(dd, 'a')
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
return csmAlloc(na m.tso.allocDD di rest, retRc)
else
return tsoAlloc(na m.tso.allocDD di rest, retRc)
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) < 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 dd 'call tsoFree' dd';'
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.
arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList,dx)
call adrTso 'execio 0 diskr' dd '(finis)', ggRet
if wordPos(dd, m.tso.ddAlloc) > 0 then
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
parse arg opt
call tsoFree m.tso.ddAlloc, '*'
call tsoFree m.tso.ddOpen, '*'
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(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')
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
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 = 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
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 *****************************************************/
/*--- 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 ********************************************************/
}¢--- A540769.WK.REXX.O13(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.O13(EXDB2LOG) cre=2012-07-24 mod=2012-09-17-16.47.07 A540769 ---
/* REXX */
/******************************************************************/
/* EXDB2LOG */
/* -------- */
/* */
/* 1 HISTORY: */
/* 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) */
/* */
/* 2 PARMS EXDB2LOG <PARM1> */
/* PARM1 = DB2 SUBSYSTEM */
/* */
/* 3 LOCATION TSO.RZ?.P0.USER.EXEC */
/* */
/******************************************************************/
m.debug = 0 fds
m.wkTest = 1
call errReset 'h'
call errAddCleanup "if m.sql.conSSID <> '' then do;" ,
"say 'rollback';call sqlExec Rollback; call sqlRxDisconnect; end"
PARSE UPPER arg SSID .
/*----------------------------------------------------------------*/
/*-------------- VARIABLEN INITIALISIEREN ------------------------*/
/*----------------------------------------------------------------*/
if 0 then do /* online test ........ */
call resourceTypeIni
CALL sqlRxConnect dbtf
call readMstrLog
say m.to.0 'timeout deadlocks:'
cD = 0
cT = 0
do tx=1 to m.to.0
if m.to.tx.tst = '' ,
| m.to.tx.evTy = '' ,
| m.to.tx.v.dbMb = '' ,
| m.to.tx.v.plan = '' ,
| m.to.tx.v.conn = '' ,
| m.to.tx.v.corr = '' ,
| m.to.tx.h.dbMb = '' ,
| m.to.tx.h.plan = '' ,
| m.to.tx.h.conn = '' ,
| m.to.tx.h.corr = '' ,
| m.to.tx.reason = '' ,
| m.to.tx.type = '' ,
| m.to.tx.name = '' then do
say tx m.to.tx.tst ,
m.to.tx.evTy
say ' v' m.to.tx.v.dbMb ,
m.to.tx.v.plan ,
m.to.tx.v.conn ,
m.to.tx.v.corr
say ' h' m.to.tx.h.dbMb ,
m.to.tx.h.plan ,
m.to.tx.h.conn ,
m.to.tx.h.corr
say ' r' m.to.tx.reason ,
m.to.tx.type ,
m.to.tx.name
end
cD = cD + (m.to.tx.evTy == 'D')
cT = cT + (m.to.tx.evTy == 'T')
end
say 'dead' cD', timeO' cT', tot' m.to.0
call err 'end of tst'
end
tadmSSID = ''
ANZ_DDIN1 = 0
F_SSID = ''
F_DATUM = ''
F_TIME = ''
F_DATA = ''
CHECK_MAX_TST = ''
m.lastDeadlock = ''
m.lastTimeout = ''
SQL_MAX_TST_U = ''
SQL_MAX_TST_C = ''
SQL_MAX_TST_E = ''
SQL_MAX_TST_A = ''
m.tadmCreator = ''
SQL_DBID = ''
SQL_OBID = ''
SQL_DOT = ''
SQL_DBID_OBJECT = ''
SQL_OBID_OBJECT = ''
EVENT_SSID = ''
EVENT_DATE = ''
EVENT_TYPE = ''
EVENT_V_PLAN = ''
EVENT_V_CORRID = ''
EVENT_V_CONNID = ''
EVENT_S_PLAN = ''
EVENT_S_CORRID = ''
EVENT_S_CONNID = ''
EVENT_REASON = ''
EVENT_O_TYPE = ''
EVENT_O_NAME = ''
EVENT_UOW_SSID = ''
EVENT_UOW_DATE = ''
EVENT_UOW_TYPE = ''
EVENT_UOW_LOGREC = ''
EVENT_UOW_CORRID = ''
EVENT_UOW_CONNID = ''
EVENT_UOW_PLAN = ''
EVENT_UOW_AUTHID = ''
EVENT_LES_SSID = ''
EVENT_LES_DATE = ''
EVENT_LES_TYPE = ''
EVENT_LES_PLAN = ''
EVENT_LES_PACKAGE = ''
EVENT_LES_COLLID = ''
EVENT_LES_CORRID = ''
EVENT_LES_CONNID = ''
EVENT_LES_RESOURCE = ''
EVENT_LES_LOCKSTATE = ''
EVENT_LES_STATEMENT = ''
EVENT_EOT_SSID = ''
EVENT_EOT_DATE = ''
EVENT_EOT_TYPE = ''
EVENT_EOT_USER = ''
EVENT_EOT_CONNID = ''
EVENT_EOT_CORRID = ''
EVENT_EOT_JOBNAME = ''
EVENT_EOT_ASID = ''
EVENT_EOT_TCB = ''
CNT_OUTPUT = 1
CNT_OUTPUT_UOW = 1
CNT_OUTPUT_LES = 1
CNT_OUTPUT_EOT = 1
/*----------------------------------------------------------------*/
/*-------------- PROGRAMM-PARAMETER VERARBEITEN ------------------*/
/*----------------------------------------------------------------*/
SAY "PROGRAMMVERSION = v2.2 vom 18.4.12"
SAY "DB2 SUBSYSTEM = "SSID
/*----------------------------------------------------------------*/
/*-------------- HAUPTPROGRAMM -----------------------------------*/
/*----------------------------------------------------------------*/
CALL OWNER_SSID_ZUWEISEN /* ZUWEISEN VON OWNER & SSID FÜR SQL*/
CALL sqlRxConnect tadmSSID /* DB2 SUBSYSTEM VERBINDEN */
CALL GET_MAX_WERT_TIMEOUT /* MAX TIMEOUT EINTRAG VON TABELLE LESEN */
CALL GET_MAX_WERT_DEADLOCK /* MAX DEADLOCK EINTRAG VON TABELLE LESEN */
CALL GET_MAX_WERT_UNCOMUOW /* MAX UNCOMUOW EINTRAG VON TABELLE L*/
CALL GET_MAX_WERT_CHECKPNT /* MAX CHECKPNT EINTRAG VON TABELLE L*/
CALL GET_MAX_WERT_LOCKESCA /* MAX LOCKESCA EINTRAG VON TABELLE L*/
CALL GET_MAX_WERT_EOT /* MAX EOT EINTRAG VON TABELLE LESEN */
CALL sqlRxDisconnect /* DISCONNECT DB2 SUBSYSTEM */
call resourceTypeIni
CALL sqlRxConnect ssid /* DB2 SUBSYSTEM VERBINDEN */
CALL readMstrLog /* INPUT-DS lesen und analysieren */
if 0 then do
CALL READ_TIMEOUT /* TIMEOUTS AUS INPUT-DS LESEN */
CALL READ_DEADLOCK /* TIMEOUTS AUS INPUT-DS LESEN */
CALL ZUWEISUNG_TYPE /* RESOURCE TYPE ZUWEISEN */
CALL SELECT_DBID_OBID /* DBID/OBID SELEKTIEREN */
CALL READ_UNCOMMITED_UOW /* UNCOMMITED UOW AUS INPUT-DS LESEN */
CALL READ_CHECKPOINT /* CHECKPOINTS AUS INPUT-DS LESEN */
CALL READ_LOCKESCALATION /* LOCK ESCALATION AUS INPUT-DS LESEN */
CALL READ_EOT /* ABNORMAL EOT AUS INPUT-DS LESEN */
end
CALL sqlRxDisconnect /* DISCONNECT DB2 SUBSYSTEM */
CALL sqlRxConnect tadmSSID /* DB2 SUBSYSTEM VERBINDEN */
CALL INSERT_TADM60A1 /* INSERT IN DB2 TABELLE */
if 0 then do
CALL INSERT_TADM63A1 /* INSERT IN DB2 TABELLE */
CALL INSERT_TADM64A1 /* INSERT IN DB2 TABELLE */
CALL INSERT_TADM65A1 /* INSERT IN DB2 TABELLE */
end
CALL sqlRxDisconnect /* DISCONNECT DB2 SUBSYSTEM */
EXIT;
/*----------------------------------------------------------------*/
/*-------------- OWNER UND SSID FÜR SQL ABFRAGE ZUWEISEN --------*/
/*----------------------------------------------------------------*/
OWNER_SSID_ZUWEISEN:
IF m.debug THEN SAY "ENTER PROCEDURE OWNER_SSID_ZUWEISEN..."
SELECT
WHEN SSID = 'DBAF' THEN info = 'DAF OA1A DBAF' /* rz1 */
WHEN SSID = 'DBTF' THEN info = 'DTF OA1A DBAF'
WHEN SSID = 'DBZF' THEN info = 'DZF OA1A DBAF'
WHEN SSID = 'DBOC' THEN info = 'DOC OA1A DBAF'
WHEN SSID = 'DBBA' THEN info = 'DBA OA1A DBAF'
WHEN SSID = 'DBLF' THEN info = 'DLF OA1A DBAF'
WHEN SSID = 'DVTB' THEN info = 'DTB OA1A DBAF'
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'
WHEN SSID = 'DEVG' THEN info = 'DEV OA1P DEVG'
OTHERWISE do
say "error: bad ssid = '"ssid"'"
exit 20
end
END
parse var info m.db2Member3 m.tadmCreator tadmSSID .
if m.wkTest then do
m.tadmCreator = A540769
say '?????? wktest run'
end
say ' ssid' ssid 'member' m.db2Member3'?',
'to' tadmSSID':'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
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
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_DEADLOCK..."
RETURN
/*----------------------------------------------------------------*/
/*-------------- MAX UNCOMUOW WERT VON TADM63A1 LESEN ------------*/
/*----------------------------------------------------------------*/
GET_MAX_WERT_UNCOMUOW:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_UNCOMUOW..."
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 :SQL_MAX_TST_U :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX UNCOMMITED UOW TIMESTAMP FOR" SSID "IS:" SQL_MAX_TST_U
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_UNCOMUOW..."
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 :SQL_MAX_TST_C :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX CHECKPOINT TIMESTAMP FOR" SSID "IS:" SQL_MAX_TST_C
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 :SQL_MAX_TST_E :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX LOCK ESCALATION TIMESTAMP FOR" SSID "IS:" SQL_MAX_TST_E
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 :SQL_MAX_TST_A :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX ABNORMAL EOT TIMESTAMP FOR" SSID "IS:" SQL_MAX_TST_A
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
do lx=1 to 12e12 while li <> ''
mid = isDsnMsg(m.li, msgI)
if mid == '' then do
li = readNx(rd)
iterate
end
if mid == 'DSNT375I' then
call anaTimeoutDeadlock rd, msgI, 'D'
else if mid == 'DSNT376I' then
call anaTimeoutDeadlock rd, msgI, 'T'
else if mid == 'DSNT501I' then
call anaResourceNotAvailable rd, msgI
l2 = readNxCur(rd)
if li == l2 then
li = readNx(rd)
else
li = l2
/* say lx li mid'>>>' m.li
*/ end
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
mid = word(line, 4)
if \ abbrev(mid, 'DSN') | wordIndex(line, 4) <> 29 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 5) = 'IAT6853' then
call anaCurDate line
return ''
end
parse var line m.info.dbMb m.info.date m.info.time .
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
m.info.head = left(line,27)
if '-'m.info.dbMb \== word(line, 5) then
call err 'dbMember mismatch: ' readNxPos(rd)
return mid
endProcedure isDsnMsg
/* analyse current date in iat6853 message
and check that it equals the header ---------------------------*/
anaCurDate: procedure expose m.
parse arg line
if substr(line, 40, 21) ,
<> ' THE CURRENT DATE IS ' then
call err 'bad IAT6853' readNxPos(rd)
d1 = subword(substr(line, 61), 2, 3)
say '???' left(line, 59) '>>>' d1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
d2 = word(d1, 1) ,
translate(left(word(d1, 2), 1)),
|| translate(substr(word(d1, 2), 2),
, m.mAlfLC, m.mAlfUC) ,
word(d1, 3)
d3 = date('s', d2)
if translate('1234-56-78', d3, '12345678') <> word(line, 2) then
call err 'date mismatch' word(line, 2) '<>' d3 'line': line
return
endProcedure anaCurDate
/*--- analye timeout, deadlock msg: DSNT375I, DSNT376I ---------------*/
anaTimeoutDeadlock: procedure expose m.
parse arg rd, info, pEvTy
li = readNxCur(rd)
if pEvTy == 'D' then
if m.info.tst <= m.lastDeadlock then
return
if pEvTy == 'T' then
if m.info.tst <= m.lastTimeout then
return
totx = newTimeout(info, pEvTy)
vs = 'V'
do forever /* jede Zeile der Message */
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 = strip(substr(m.li, cx+16))
cx = pos(' CONNECTION-ID=', m.li)
if cx > 0 then
m.toTx.vs.conn = 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) /* nächste Zeile */
if \ abbrev(m.li, m.info.head) then
return
if substr(m.li, 29, 8) <> '' then
if isDsnMsg(m.li, msgI) <> '' then
return
end /* jede Zeile der Message */
/*say 'v' m.toTx.v.dbMb m.toTx.v.plan m.toTx.v.corr m.toTx.v.conn
say 's' m.toTx.h.dbMb m.toTx.h.plan m.toTx.h.corr m.toTx.h.conn */
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
m.toTx.tst = m.info.tst
m.toTx.evTy = pEvTy
m.toTx.v.dbMb = m.info.dbMb
m.toTx.v.plan = ''
m.toTx.v.conn = ''
m.toTx.v.corr = ''
m.toTx.h.dbMb = ''
m.toTx.h.plan = ''
m.toTx.h.conn = ''
m.toTx.h.corr = ''
m.toTx.reason = ''
m.toTx.type = ''
m.toTx.name = ''
return toTx
endProcedure newTimeout
/*--- analye resourceNotAvailable msg DSNT501I -----------------------*/
anaResourceNotAvailable: procedure expose m.
parse arg rd, info
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
if substr(m.li, 29, 8) <> '' then
if isDsnMsg(m.li, msgI) <> '' then
leave
end /* loop line of dsnt501i */
/* search preceeding to/dead */
tt = max(1, m.to.0 - 20)
do tx=m.to.0 to tt by -1 ,
while m.to.tx.v.corr \== tCor | m.to.tx.v.conn \== tCon ,
| m.to.tx.name \== ''
end
if tx >= tt then
toTx = 'TO.'tx
else
return /* ??? new feature: store these also
evType depending on reason, but some have several */
m.toTx.type = tTyp
m.toTx.name = space(tNam, 1)
m.toTx.reason = tRea
if tTyp <> '' then
call resourceType toTx'.'type, toTx'.'name
return
endProcedure anaResourceNotAvailable
/*--- give the name of the resourcetype and dbid/obid ----------------*/
resourceType: procedure expose m.
parse arg tp, nm
cd = m.tp
if symbol('m.resourceType.cd') <> 'VAR' then do
trace ?r
say '<'cd'>' c2x(cd)
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
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
m.nm = getDbidObid(n.di, n.oi) names
end
return cd
endProcedure resourceType
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 dbid, obid
SQL_DBID = STRIP(dbid,L,0)
SQL_OBID = STRIP(obid,L,0)
if symbol('m.dbidObid.dbid.obid') <> 'VAR' then do
/* select from catalog */
/* from sysTables */
SQL_TB= "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
" WITH UR "
SQLTEXT = SQL_TB
ADDRESS DSNREXX "EXECSQL DECLARE C4 CURSOR FOR S4"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S4 FROM :SQL_TB"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C4"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C4 INTO :SQL_DBID_OBID :SQL_IND"
sqlFet = sqlCode
IF SQLCODE <> 0 & SQLCODE <> 100 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL CLOSE C4"
/*IF NOT FOUND GO AND CHECK THE SYSIBM.SYSTABLESPACE*/
IF SQLFet = 100 THEN DO /* from sysTablespace */
SQL_TS= "SELECT ",
" STRIP(DBNAME,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
" WITH UR "
SQLTEXT = SQL_TS
ADDRESS DSNREXX "EXECSQL DECLARE C5 CURSOR FOR S5"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S5 FROM :SQL_TS"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C5"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C5 INTO :SQL_DBID_OBID :SQL_IND"
sqlFet = sqlCode
IF SQLCODE <> 0 & SQLCODE <> 100 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL CLOSE C5"
END /* from sysTablespace */
/*IF NOT FOUND GO AND CHECK THE SYSIBM.INDEXES*/
IF sqlFet = 100 THEN DO /* from sysIndexes */
SQL_IX= "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
" WITH UR "
SQLTEXT = SQL_IX
ADDRESS DSNREXX "EXECSQL DECLARE C6 CURSOR FOR S6"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S6 FROM :SQL_IX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C6"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C6 INTO :SQL_DBID_OBID :SQL_IND"
if sqlCode <> 0 then
sql_dbid_obid = '???'
IF SQLCODE <> 0 & SQLCODE <> 100 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL CLOSE C6"
END /* from sysIndexes */
m.dbidObid.dbid.obid = sql_dbid_obid
SAY "??? " SQL_DBID_OBID,
"SELEKTIERT FÜR DBID" SQL_DBID ", OBID" SQL_OBID
end /* select from catalog */
return m.dbidObid.dbid.obid
endProcedure getDbidObid
/*----------------------------------------------------------------*/
/*-------------- DATASETS EINLESEN, DDNAME ZUORDNEN --------------*/
/*----------------------------------------------------------------*/
READ_DSN:
IF m.debug THEN SAY "ENTER PROCEDURE READ_DSN..." ,
TIME() "CPU" STRIP(SYSVAR(SYSCPU))
/* DDIN1 EINLESEN */
"EXECIO * DISKR DDIN1 (STEM DDIN1. FINIS"
IF m.debug THEN SAY "ENTER PROCEDURE READ" DDIN1.0 ,
TIME() "CPU" STRIP(SYSVAR(SYSCPU))
ANZ_DDIN1 = DDIN1.0 /* ANZAHL INPUT-LINIEN */
/* LESE DATASET-INFO ZU DDNAME */
DO CNT_LINE_DDIN1 = 1 TO DDIN1.0
PARSE VAR DDIN1.CNT_LINE_DDIN1 F_SSID.CNT_LINE_DDIN1,
F_DATE.CNT_LINE_DDIN1,
F_TIME.CNT_LINE_DDIN1,
F_DATA_1.CNT_LINE_DDIN1,
F_DATA_2.CNT_LINE_DDIN1,
F_DATA_3.CNT_LINE_DDIN1,
F_DATA_4.CNT_LINE_DDIN1,
F_DATA_5.CNT_LINE_DDIN1,
F_DATA_6.CNT_LINE_DDIN1,
F_DATA_7.CNT_LINE_DDIN1,
F_DATA_8.CNT_LINE_DDIN1,
F_DATA_9.CNT_LINE_DDIN1,
F_DATA_10.CNT_LINE_DDIN1,
F_DATA_11.CNT_LINE_DDIN1,
F_DATA_12.CNT_LINE_DDIN1
CHECK_MAX_TST.CNT_LINE_DDIN1 = F_DATE.CNT_LINE_DDIN1||,
'-'||,
SUBSTR(F_TIME.CNT_LINE_DDIN1,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE_DDIN1,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE_DDIN1,7,2)||,
'.000000'
F_DATA_1.CNT_LINE_DDIN1 = STRIP(F_DATA_1.CNT_LINE_DDIN1,B)
F_DATA_2.CNT_LINE_DDIN1 = STRIP(F_DATA_2.CNT_LINE_DDIN1,B)
F_DATA_3.CNT_LINE_DDIN1 = STRIP(F_DATA_3.CNT_LINE_DDIN1,B)
F_DATA_4.CNT_LINE_DDIN1 = STRIP(F_DATA_4.CNT_LINE_DDIN1,B)
F_DATA_5.CNT_LINE_DDIN1 = STRIP(F_DATA_5.CNT_LINE_DDIN1,B)
F_DATA_6.CNT_LINE_DDIN1 = STRIP(F_DATA_6.CNT_LINE_DDIN1,B)
F_DATA_7.CNT_LINE_DDIN1 = STRIP(F_DATA_7.CNT_LINE_DDIN1,B)
F_DATA_8.CNT_LINE_DDIN1 = STRIP(F_DATA_8.CNT_LINE_DDIN1,B)
F_DATA_9.CNT_LINE_DDIN1 = STRIP(F_DATA_9.CNT_LINE_DDIN1,B)
F_DATA_10.CNT_LINE_DDIN1 = STRIP(F_DATA_10.CNT_LINE_DDIN1,B)
F_DATA_11.CNT_LINE_DDIN1 = STRIP(F_DATA_11.CNT_LINE_DDIN1,B)
F_DATA_12.CNT_LINE_DDIN1 = STRIP(F_DATA_12.CNT_LINE_DDIN1,B)
END
IF m.debug THEN SAY "LEAVE PROCEDURE READ_DSN..." ,
TIME() "CPU" STRIP(SYSVAR(SYSCPU))
RETURN
/*----------------------------------------------------------------*/
/*-------------- TIMEOUTS AUS INPUT-DS LESEN ---------------------*/
/*----------------------------------------------------------------*/
READ_TIMEOUT:
IF m.debug THEN SAY "ENTER PROCEDURE READ_TIMEOUT..."
TIMEOUTS_READ = 0
VICTIM_PLAN_FOUND = 'N'
VICTIM_CORRID_FOUND = 'N'
VICTIM_CONN_FOUND = 'N'
SOURCE_PLAN_FOUND = 'N'
SOURCE_CORRID_FOUND = 'N'
SOURCE_CONN_FOUND = 'N'
NAME_READ = 'N'
TIMEOUT_OK = 'Y'
DO CNT_LINE = 1 TO ANZ_DDIN1
IF F_DATA_1.CNT_LINE = 'DSNT376I' &,
CHECK_MAX_TST.CNT_LINE > m.lastTimeout THEN DO
TIMEOUTS_READ = TIMEOUTS_READ + 1
EVENT_SSID.CNT_OUTPUT = F_SSID.CNT_LINE
EVENT_DATE.CNT_OUTPUT = F_DATE.CNT_LINE||,
'-'||,
SUBSTR(F_TIME.CNT_LINE,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,7,2)||,
'.000000'
EVENT_TYPE.CNT_OUTPUT = 'T'
DO FOREVER
IF SUBSTR(F_DATA_10.CNT_LINE,1,4) = 'PLAN' &,
VICTIM_PLAN_FOUND = 'Y' &,
SOURCE_PLAN_FOUND = 'N' THEN DO
EVENT_S_PLAN.CNT_OUTPUT = ,
SUBSTR(F_DATA_10.CNT_LINE,6)
SOURCE_PLAN_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,11) = 'CORRELATION' &,
VICTIM_CORRID_FOUND = 'Y' &,
SOURCE_CORRID_FOUND = 'N' THEN DO
EVENT_S_CORRID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,16)
SOURCE_CORRID_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,10) = 'CONNECTION' &,
VICTIM_CONN_FOUND = 'Y' &,
SOURCE_CONN_FOUND = 'N' THEN DO
EVENT_S_CONNID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,15)
SOURCE_CONN_FOUND = 'Y'
END
IF SUBSTR(F_DATA_3.CNT_LINE,1,4) = 'PLAN' &,
VICTIM_PLAN_FOUND = 'N' &,
SOURCE_PLAN_FOUND = 'N' THEN DO
EVENT_V_PLAN.CNT_OUTPUT = ,
SUBSTR(F_DATA_3.CNT_LINE,6)
VICTIM_PLAN_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,11) = 'CORRELATION' &,
VICTIM_CORRID_FOUND = 'N' &,
SOURCE_CORRID_FOUND = 'N' THEN DO
EVENT_V_CORRID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,16)
VICTIM_CORRID_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,10) = 'CONNECTION' & ,
VICTIM_CONN_FOUND = 'N' & ,
SOURCE_CONN_FOUND = 'N' THEN DO
EVENT_V_CONNID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,15)
VICTIM_CONN_FOUND = 'Y'
END
IF F_DATA_1.CNT_LINE = 'ON' &,
F_DATA_2.CNT_LINE = 'MEMBER' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
CNT_LINE = CNT_LINE + 1
IF F_DATA_1.CNT_LINE <> 'DSNT501I' &,
F_DATA_1.CNT_LINE <> 'DSNT376I' THEN DO
TIMEOUT_OK = 'Y'
EVENT_REASON.CNT_OUTPUT = ' '
EVENT_O_TYPE.CNT_OUTPUT = ' '
EVENT_O_NAME.CNT_OUTPUT = ' '
CNT_LINE = CNT_LINE - 1
END
IF F_DATA_1.CNT_LINE = 'DSNT501I' &,
TIMEOUT_OK = 'N' THEN DO
TIMEOUT_OK = 'Y'
EVENT_REASON.CNT_OUTPUT = ' '
EVENT_O_TYPE.CNT_OUTPUT = ' '
EVENT_O_NAME.CNT_OUTPUT = ' '
CNT_LINE = CNT_LINE - 1
END
IF F_DATA_1.CNT_LINE = 'DSNT376I' THEN DO
TIMEOUT_OK = 'N'
EVENT_REASON.CNT_OUTPUT = ' '
EVENT_O_TYPE.CNT_OUTPUT = ' '
EVENT_O_NAME.CNT_OUTPUT = ' '
CNT_LINE = CNT_LINE - 1
END
IF F_DATA_1.CNT_LINE = 'DSNT501I' &,
TIMEOUT_OK = 'Y' THEN DO
DO FOREVER
IF F_DATA_1.CNT_LINE = 'REASON' THEN DO
EVENT_REASON.CNT_OUTPUT = ,
F_DATA_2.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'TYPE' THEN DO
EVENT_O_TYPE.CNT_OUTPUT = ,
F_DATA_2.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'NAME' THEN DO
EVENT_O_NAME.CNT_OUTPUT = ,
F_DATA_2.CNT_LINE,
F_DATA_3.CNT_LINE,
F_DATA_4.CNT_LINE
NAME_READ = 'Y'
END
IF NAME_READ = 'Y' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
END
EVENT_SSID.CNT_OUTPUT = STRIP(EVENT_SSID.CNT_OUTPUT)
EVENT_DATE.CNT_OUTPUT = STRIP(EVENT_DATE.CNT_OUTPUT)
EVENT_TYPE.CNT_OUTPUT = STRIP(EVENT_TYPE.CNT_OUTPUT)
EVENT_V_PLAN.CNT_OUTPUT = STRIP(EVENT_V_PLAN.CNT_OUTPUT)
EVENT_V_CORRID.CNT_OUTPUT = STRIP(EVENT_V_CORRID.CNT_OUTPUT)
EVENT_V_CONNID.CNT_OUTPUT = STRIP(EVENT_V_CONNID.CNT_OUTPUT)
EVENT_S_PLAN.CNT_OUTPUT = STRIP(EVENT_S_PLAN.CNT_OUTPUT)
EVENT_S_CORRID.CNT_OUTPUT = STRIP(EVENT_S_CORRID.CNT_OUTPUT)
EVENT_S_CONNID.CNT_OUTPUT = STRIP(EVENT_S_CONNID.CNT_OUTPUT)
EVENT_REASON.CNT_OUTPUT = STRIP(EVENT_REASON.CNT_OUTPUT)
EVENT_O_TYPE.CNT_OUTPUT = STRIP(EVENT_O_TYPE.CNT_OUTPUT)
EVENT_O_NAME.CNT_OUTPUT = STRIP(EVENT_O_NAME.CNT_OUTPUT)
CNT_OUTPUT = CNT_OUTPUT + 1
VICTIM_PLAN_FOUND = 'N'
VICTIM_CORRID_FOUND = 'N'
VICTIM_CONN_FOUND = 'N'
SOURCE_PLAN_FOUND = 'N'
SOURCE_CORRID_FOUND = 'N'
SOURCE_CONN_FOUND = 'N'
NAME_READ = 'N'
END
END
SAY " "TIMEOUTS_READ" TIMEOUTS READ FROM MSTRLOG FILE"
IF m.debug THEN SAY "LEAVE PROCEDURE READ_TIMEOUT..."
RETURN
/*----------------------------------------------------------------*/
/*-------------- DEADLOCKS AUS INPUT-DS LESEN --------------------*/
/*----------------------------------------------------------------*/
READ_DEADLOCK:
IF m.debug THEN SAY "ENTER PROCEDURE READ_DEADLOCK..."
DEADLOCKS_READ = 0
VICTIM_PLAN_FOUND = 'N'
VICTIM_CORRID_FOUND = 'N'
VICTIM_CONN_FOUND = 'N'
SOURCE_PLAN_FOUND = 'N'
SOURCE_CORRID_FOUND = 'N'
SOURCE_CONN_FOUND = 'N'
NAME_READ = 'N'
DO CNT_LINE = 1 TO ANZ_DDIN1
IF F_DATA_1.CNT_LINE = 'DSNT375I' &,
CHECK_MAX_TST.CNT_LINE > m.lastDeadlock THEN DO
DEADLOCKS_READ = DEADLOCKS_READ + 1
EVENT_SSID.CNT_OUTPUT = F_SSID.CNT_LINE
EVENT_DATE.CNT_OUTPUT = F_DATE.CNT_LINE||,
'-'||,
SUBSTR(F_TIME.CNT_LINE,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,7,2)||,
'.000000'
EVENT_TYPE.CNT_OUTPUT = 'D'
DO FOREVER
IF SUBSTR(F_DATA_4.CNT_LINE,1,4) = 'PLAN' &,
VICTIM_PLAN_FOUND = 'Y' &,
SOURCE_PLAN_FOUND = 'N' THEN DO
EVENT_S_PLAN.CNT_OUTPUT = ,
SUBSTR(F_DATA_4.CNT_LINE,6)
SOURCE_PLAN_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,11) = 'CORRELATION' &,
VICTIM_CORRID_FOUND = 'Y' &,
SOURCE_CORRID_FOUND = 'N' THEN DO
EVENT_S_CORRID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,16)
SOURCE_CORRID_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,10) = 'CONNECTION' &,
VICTIM_CONN_FOUND = 'Y' &,
SOURCE_CONN_FOUND = 'N' THEN DO
EVENT_S_CONNID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,15)
SOURCE_CONN_FOUND = 'Y'
END
IF SUBSTR(F_DATA_3.CNT_LINE,1,4) = 'PLAN' &,
VICTIM_PLAN_FOUND = 'N' &,
SOURCE_PLAN_FOUND = 'N' THEN DO
EVENT_V_PLAN.CNT_OUTPUT = ,
SUBSTR(F_DATA_3.CNT_LINE,6)
VICTIM_PLAN_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,11) = 'CORRELATION' &,
VICTIM_CORRID_FOUND = 'N' &,
SOURCE_CORRID_FOUND = 'N' THEN DO
EVENT_V_CORRID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,16)
VICTIM_CORRID_FOUND = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,10) = 'CONNECTION' & ,
VICTIM_CONN_FOUND = 'N' & ,
SOURCE_CONN_FOUND = 'N' THEN DO
EVENT_V_CONNID.CNT_OUTPUT = ,
SUBSTR(F_DATA_1.CNT_LINE,15)
VICTIM_CONN_FOUND = 'Y'
END
IF F_DATA_1.CNT_LINE = 'ON' &,
F_DATA_2.CNT_LINE = 'MEMBER' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
CNT_LINE = CNT_LINE + 1
IF F_DATA_1.CNT_LINE <> 'DSNT501I' &,
F_DATA_1.CNT_LINE <> 'DSNT375I' THEN DO
TIMEOUT_OK = 'Y'
EVENT_REASON.CNT_OUTPUT = ' '
EVENT_O_TYPE.CNT_OUTPUT = ' '
EVENT_O_NAME.CNT_OUTPUT = ' '
CNT_LINE = CNT_LINE - 1
END
IF F_DATA_1.CNT_LINE = 'DSNT501I' &,
TIMEOUT_OK = 'N' THEN DO
TIMEOUT_OK = 'Y'
EVENT_REASON.CNT_OUTPUT = ' '
EVENT_O_TYPE.CNT_OUTPUT = ' '
EVENT_O_NAME.CNT_OUTPUT = ' '
CNT_LINE = CNT_LINE - 1
END
IF F_DATA_1.CNT_LINE = 'DSNT375I' THEN DO
TIMEOUT_OK = 'N'
EVENT_REASON.CNT_OUTPUT = ' '
EVENT_O_TYPE.CNT_OUTPUT = ' '
EVENT_O_NAME.CNT_OUTPUT = ' '
CNT_LINE = CNT_LINE - 1
END
IF F_DATA_1.CNT_LINE = 'DSNT501I' &,
TIMEOUT_OK = 'Y' THEN DO
DO FOREVER
IF F_DATA_1.CNT_LINE = 'REASON' THEN DO
EVENT_REASON.CNT_OUTPUT = ,
F_DATA_2.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'TYPE' THEN DO
EVENT_O_TYPE.CNT_OUTPUT = ,
F_DATA_2.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'NAME' THEN DO
EVENT_O_NAME.CNT_OUTPUT = ,
F_DATA_2.CNT_LINE,
F_DATA_3.CNT_LINE,
F_DATA_4.CNT_LINE
NAME_READ = 'Y'
END
IF NAME_READ = 'Y' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
END
EVENT_SSID.CNT_OUTPUT = STRIP(EVENT_SSID.CNT_OUTPUT)
EVENT_DATE.CNT_OUTPUT = STRIP(EVENT_DATE.CNT_OUTPUT)
EVENT_TYPE.CNT_OUTPUT = STRIP(EVENT_TYPE.CNT_OUTPUT)
EVENT_V_PLAN.CNT_OUTPUT = STRIP(EVENT_V_PLAN.CNT_OUTPUT)
EVENT_V_CORRID.CNT_OUTPUT = STRIP(EVENT_V_CORRID.CNT_OUTPUT)
EVENT_V_CONNID.CNT_OUTPUT = STRIP(EVENT_V_CONNID.CNT_OUTPUT)
EVENT_S_PLAN.CNT_OUTPUT = STRIP(EVENT_S_PLAN.CNT_OUTPUT)
EVENT_S_CORRID.CNT_OUTPUT = STRIP(EVENT_S_CORRID.CNT_OUTPUT)
EVENT_S_CONNID.CNT_OUTPUT = STRIP(EVENT_S_CONNID.CNT_OUTPUT)
EVENT_REASON.CNT_OUTPUT = STRIP(EVENT_REASON.CNT_OUTPUT)
EVENT_O_TYPE.CNT_OUTPUT = STRIP(EVENT_O_TYPE.CNT_OUTPUT)
EVENT_O_NAME.CNT_OUTPUT = STRIP(EVENT_O_NAME.CNT_OUTPUT)
CNT_OUTPUT = CNT_OUTPUT + 1
VICTIM_PLAN_FOUND = 'N'
VICTIM_CORRID_FOUND = 'N'
VICTIM_CONN_FOUND = 'N'
SOURCE_PLAN_FOUND = 'N'
SOURCE_CORRID_FOUND = 'N'
SOURCE_CONN_FOUND = 'N'
NAME_READ = 'N'
END
END
SAY " "DEADLOCKS_READ" DEADLOCKS READ FROM MSTRLOG FILE"
IF m.debug THEN SAY "LEAVE PROCEDURE READ_DEADLOCK..."
RETURN
/*----------------------------------------------------------------*/
/*---------- UNCOMMITED UOW AUS INPUT-DS LESEN -------------------*/
/*----------------------------------------------------------------*/
READ_UNCOMMITED_UOW:
IF m.debug THEN SAY "ENTER PROCEDURE READ_UNCOMMITED_UOW..."
UNCOMMITED_UOW_READ = 0
UOW_FINISHED = 'N'
DO CNT_LINE = 1 TO ANZ_DDIN1
IF F_DATA_1.CNT_LINE = 'DSNJ031I' &,
CHECK_MAX_TST.CNT_LINE > SQL_MAX_TST_U THEN DO
UNCOMMITED_UOW_READ = UNCOMMITED_UOW_READ + 1
EVENT_UOW_SSID.CNT_OUTPUT_UOW = F_SSID.CNT_LINE
EVENT_UOW_DATE.CNT_OUTPUT_UOW = F_DATE.CNT_LINE||,
'-'||,
SUBSTR(F_TIME.CNT_LINE,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,7,2)||,
'.000000'
EVENT_UOW_TYPE.CNT_OUTPUT_UOW = 'U'
DO FOREVER
IF F_DATA_1.CNT_LINE = 'HAS' &,
F_DATA_2.CNT_LINE = 'WRITTEN' THEN DO
EVENT_UOW_LOGREC.CNT_OUTPUT_UOW = ,
F_DATA_3.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'CORRELATION' THEN DO
EVENT_UOW_CORRID.CNT_OUTPUT_UOW = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'CONNECTION' THEN DO
EVENT_UOW_CONNID.CNT_OUTPUT_UOW = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'PLAN' THEN DO
EVENT_UOW_PLAN.CNT_OUTPUT_UOW = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'AUTHID' THEN DO
EVENT_UOW_AUTHID.CNT_OUTPUT_UOW = ,
F_DATA_3.CNT_LINE
UOW_FINISHED = 'Y'
END
IF UOW_FINISHED = 'Y' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
EVENT_UOW_SSID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_SSID.CNT_OUTPUT_UOW)
EVENT_UOW_DATE.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_DATE.CNT_OUTPUT_UOW)
EVENT_UOW_TYPE.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_TYPE.CNT_OUTPUT_UOW)
EVENT_UOW_LOGREC.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_LOGREC.CNT_OUTPUT_UOW)
EVENT_UOW_CORRID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_CORRID.CNT_OUTPUT_UOW)
EVENT_UOW_CONNID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_CONNID.CNT_OUTPUT_UOW)
EVENT_UOW_PLAN.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_PLAN.CNT_OUTPUT_UOW)
EVENT_UOW_AUTHID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_AUTHID.CNT_OUTPUT_UOW)
CNT_OUTPUT_UOW = CNT_OUTPUT_UOW + 1
UOW_FINISHED = 'N'
END
END
SAY " "UNCOMMITED_UOW_READ "UNCOMMITED UOW READ FROM MSTRLOG FILE"
IF m.debug THEN SAY "LEAVE PROCEDURE READ_UNCOMMITED_UOW..."
RETURN
/*----------------------------------------------------------------*/
/*------------- CHECKPOINTS AUS INPUT-DS LESEN -------------------*/
/*----------------------------------------------------------------*/
READ_CHECKPOINT:
IF m.debug THEN SAY "ENTER PROCEDURE READ_CHECKPOINT..."
CHECKPOINTS_READ = 0
UOW_FINISHED = 'N'
DO CNT_LINE = 1 TO ANZ_DDIN1
IF F_DATA_1.CNT_LINE = 'DSNR035I' &,
CHECK_MAX_TST.CNT_LINE > SQL_MAX_TST_C THEN DO
CHECKPOINTS_READ = CHECKPOINTS_READ + 1
EVENT_UOW_SSID.CNT_OUTPUT_UOW = F_SSID.CNT_LINE
EVENT_UOW_DATE.CNT_OUTPUT_UOW = F_DATE.CNT_LINE||,
'-'||,
SUBSTR(F_TIME.CNT_LINE,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,7,2)||,
'.000000'
EVENT_UOW_TYPE.CNT_OUTPUT_UOW = 'C'
DO FOREVER
IF F_DATA_1.CNT_LINE = 'AFTER' &,
F_DATA_3.CNT_LINE = 'CHECKPOINTS' THEN DO
EVENT_UOW_LOGREC.CNT_OUTPUT_UOW = ,
F_DATA_2.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'CORRELATION' THEN DO
EVENT_UOW_CORRID.CNT_OUTPUT_UOW = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'CONNECTION' THEN DO
EVENT_UOW_CONNID.CNT_OUTPUT_UOW = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'PLAN' THEN DO
EVENT_UOW_PLAN.CNT_OUTPUT_UOW = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'AUTHID' THEN DO
EVENT_UOW_AUTHID.CNT_OUTPUT_UOW = ,
F_DATA_3.CNT_LINE
UOW_FINISHED = 'Y'
END
IF UOW_FINISHED = 'Y' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
EVENT_UOW_SSID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_SSID.CNT_OUTPUT_UOW)
EVENT_UOW_DATE.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_DATE.CNT_OUTPUT_UOW)
EVENT_UOW_TYPE.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_TYPE.CNT_OUTPUT_UOW)
EVENT_UOW_LOGREC.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_LOGREC.CNT_OUTPUT_UOW)
EVENT_UOW_CORRID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_CORRID.CNT_OUTPUT_UOW)
EVENT_UOW_CONNID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_CONNID.CNT_OUTPUT_UOW)
EVENT_UOW_PLAN.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_PLAN.CNT_OUTPUT_UOW)
EVENT_UOW_AUTHID.CNT_OUTPUT_UOW = STRIP(EVENT_UOW_AUTHID.CNT_OUTPUT_UOW)
CNT_OUTPUT_UOW = CNT_OUTPUT_UOW + 1
UOW_FINISHED = 'N'
END
END
SAY " "CHECKPOINTS_READ "CHECKPOINTS READ FROM MSTRLOG FILE"
IF m.debug THEN SAY "LEAVE PROCEDURE READ_CHECKPOINT..."
RETURN
/*----------------------------------------------------------------*/
/*---------- LOCK ESCALATIONS AUS INPUT-DS LESEN -----------------*/
/*----------------------------------------------------------------*/
READ_LOCKESCALATION:
IF m.debug THEN SAY "ENTER PROCEDURE READ_LOCKESCALATION..."
LOCKESCALATION_READ = 0
LES_FINISHED = 'N'
DO CNT_LINE = 1 TO ANZ_DDIN1
IF F_DATA_1.CNT_LINE = 'DSNI031I' &,
CHECK_MAX_TST.CNT_LINE > SQL_MAX_TST_E THEN DO
LOCKESCALATION_READ = LOCKESCALATION_READ + 1
EVENT_LES_SSID.CNT_OUTPUT_LES = F_SSID.CNT_LINE
EVENT_LES_DATE.CNT_OUTPUT_LES = F_DATE.CNT_LINE||,
'-'||,
SUBSTR(F_TIME.CNT_LINE,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,7,2)||,
'.000000'
EVENT_LES_TYPE.CNT_OUTPUT_LES = 'E'
DO FOREVER
IF F_DATA_1.CNT_LINE = 'RESOURCE' THEN DO
EVENT_LES_RESOURCE.CNT_OUTPUT_LES = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'LOCK' THEN DO
EVENT_LES_LOCKSTATE.CNT_OUTPUT_LES = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'PLAN' THEN DO
EVENT_LES_PLAN.CNT_OUTPUT_LES = ,
F_DATA_7.CNT_LINE
END
IF F_DATA_4.CNT_LINE = 'PACKAGE' THEN DO
EVENT_LES_PACKAGE.CNT_OUTPUT_LES = ,
F_DATA_9.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'COLLECTION-ID' THEN DO
EVENT_LES_COLLID.CNT_OUTPUT_LES = ,
F_DATA_3.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'STATEMENT' THEN DO
EVENT_LES_STATEMENT.CNT_OUTPUT_LES = ,
F_DATA_4.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'CORRELATION-ID' THEN DO
EVENT_LES_CORRID.CNT_OUTPUT_LES = ,
F_DATA_3.CNT_LINE
END
IF F_DATA_1.CNT_LINE = 'CONNECTION-ID' THEN DO
EVENT_LES_CONNID.CNT_OUTPUT_LES = ,
F_DATA_3.CNT_LINE
LES_FINISHED = 'Y'
END
IF LES_FINISHED = 'Y' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
EVENT_LES_SSID.CNT_OUTPUT_LES = STRIP(EVENT_LES_SSID.CNT_OUTPUT_LES)
EVENT_LES_DATE.CNT_OUTPUT_LES = STRIP(EVENT_LES_DATE.CNT_OUTPUT_LES)
EVENT_LES_TYPE.CNT_OUTPUT_LES = STRIP(EVENT_LES_TYPE.CNT_OUTPUT_LES)
EVENT_LES_PLAN.CNT_OUTPUT_LES = STRIP(EVENT_LES_PLAN.CNT_OUTPUT_LES)
EVENT_LES_PACKAGE.CNT_OUTPUT_LES = ,
STRIP(EVENT_LES_PACKAGE.CNT_OUTPUT_LES)
EVENT_LES_COLLID.CNT_OUTPUT_LES = STRIP(EVENT_LES_COLLID.CNT_OUTPUT_LES)
EVENT_LES_CORRID.CNT_OUTPUT_LES = STRIP(EVENT_LES_CORRID.CNT_OUTPUT_LES)
EVENT_LES_CONNID.CNT_OUTPUT_LES = STRIP(EVENT_LES_CONNID.CNT_OUTPUT_LES)
EVENT_LES_RESOURCE.CNT_OUTPUT_LES = ,
STRIP(EVENT_LES_RESOURCE.CNT_OUTPUT_LES)
EVENT_LES_LOCKSTATE.CNT_OUTPUT_LES = ,
STRIP(EVENT_LES_LOCKSTATE.CNT_OUTPUT_LES)
EVENT_LES_STATEMENT.CNT_OUTPUT_LES = ,
STRIP(EVENT_LES_STATEMENT.CNT_OUTPUT_LES)
CNT_OUTPUT_LES = CNT_OUTPUT_LES + 1
LES_FINISHED = 'N'
END
END
SAY " "LOCKESCALATION_READ "LOCK ESCALATION READ FROM MSTRLOG FILE"
IF m.debug THEN SAY "LEAVE PROCEDURE READ_LOCKESCALATION..."
RETURN
/*----------------------------------------------------------------*/
/*------------- ABNORMAL EOT AUS INPUT-DS LESEN-------------------*/
/*----------------------------------------------------------------*/
READ_EOT:
IF m.debug THEN SAY "ENTER PROCEDURE READ_EOT..."
EOT_READ = 0
EOT_FINISHED = 'N'
DO CNT_LINE = 1 TO ANZ_DDIN1
IF F_DATA_1.CNT_LINE = 'DSN3201I' &,
CHECK_MAX_TST.CNT_LINE > SQL_MAX_TST_A THEN DO
EOT_READ = EOT_READ + 1
EVENT_EOT_SSID.CNT_OUTPUT_EOT = F_SSID.CNT_LINE
EVENT_EOT_DATE.CNT_OUTPUT_EOT = F_DATE.CNT_LINE||,
'-'||,
SUBSTR(F_TIME.CNT_LINE,1,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,4,2)||,
'.'||,
SUBSTR(F_TIME.CNT_LINE,7,2)||,
'.000000'
EVENT_EOT_TYPE.CNT_OUTPUT_EOT = 'A'
DO FOREVER
IF SUBSTR(F_DATA_8.CNT_LINE,1,5) = 'USER=' THEN DO
EVENT_EOT_USER.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_9.CNT_LINE,6)
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,10) = 'CONNECTION' &,
SUBSTR(F_DATA_2.CNT_LINE,1,11) = 'CORRELATION' &,
SUBSTR(F_DATA_3.CNT_LINE,1,7) = 'JOBNAME' THEN DO
EVENT_EOT_CONNID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_1.CNT_LINE,15)
EVENT_EOT_CORRID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_2.CNT_LINE,16)
EVENT_EOT_JOBNAME.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_3.CNT_LINE,9)
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,5) = 'USER=' &,
SUBSTR(F_DATA_2.CNT_LINE,1,10) = 'CONNECTION' &,
SUBSTR(F_DATA_3.CNT_LINE,1,11) = 'CORRELATION' THEN DO
EVENT_EOT_USER.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_1.CNT_LINE,6)
EVENT_EOT_CONNID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_2.CNT_LINE,15)
EVENT_EOT_CORRID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_3.CNT_LINE,16)
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,5) = 'USER=' &,
SUBSTR(F_DATA_2.CNT_LINE,1,10) = 'CONNECTION' &,
SUBSTR(F_DATA_3.CNT_LINE,1,11) = 'CORRELATION' &,
SUBSTR(F_DATA_4.CNT_LINE,1,7) = 'JOBNAME' THEN DO
EVENT_EOT_USER.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_1.CNT_LINE,6)
EVENT_EOT_CONNID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_2.CNT_LINE,15)
EVENT_EOT_CORRID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_3.CNT_LINE,16)
EVENT_EOT_JOBNAME.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_4.CNT_LINE,9)
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,7) = 'JOBNAME' &,
SUBSTR(F_DATA_2.CNT_LINE,1,4) = 'ASID' &,
SUBSTR(F_DATA_3.CNT_LINE,1,3) = 'TCB' THEN DO
EVENT_EOT_JOBNAME.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_1.CNT_LINE,9)
EVENT_EOT_ASID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_2.CNT_LINE,6)
EVENT_EOT_TCB.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_3.CNT_LINE,5)
EOT_FINISHED = 'Y'
END
IF SUBSTR(F_DATA_1.CNT_LINE,1,4) = 'ASID' &,
SUBSTR(F_DATA_2.CNT_LINE,1,3) = 'TCB' THEN DO
EVENT_EOT_ASID.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_1.CNT_LINE,6)
EVENT_EOT_TCB.CNT_OUTPUT_EOT = ,
SUBSTR(F_DATA_2.CNT_LINE,5)
EOT_FINISHED = 'Y'
END
IF EOT_FINISHED = 'Y' |,
CNT_LINE > ANZ_DDIN1 THEN LEAVE
ELSE CNT_LINE = CNT_LINE + 1
END
EVENT_EOT_SSID.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_SSID.CNT_OUTPUT_EOT)
EVENT_EOT_DATE.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_DATE.CNT_OUTPUT_EOT)
EVENT_EOT_TYPE.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_TYPE.CNT_OUTPUT_EOT)
EVENT_EOT_USER.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_USER.CNT_OUTPUT_EOT)
EVENT_EOT_CONNID.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_CONNID.CNT_OUTPUT_EOT)
EVENT_EOT_CORRID.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_CORRID.CNT_OUTPUT_EOT)
EVENT_EOT_JOBNAME.CNT_OUTPUT_EOT=STRIP(EVENT_EOT_JOBNAME.CNT_OUTPUT_EOT)
EVENT_EOT_ASID.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_ASID.CNT_OUTPUT_EOT)
EVENT_EOT_TCB.CNT_OUTPUT_EOT =STRIP(EVENT_EOT_TCB.CNT_OUTPUT_EOT)
CNT_OUTPUT_EOT = CNT_OUTPUT_EOT + 1
EOT_FINISHED = 'N'
END
END
SAY " "EOT_READ "ABNORMAL EOT READ FROM MSTRLOG FILE"
IF m.debug THEN SAY "LEAVE PROCEDURE READ_EOT..."
RETURN
/*----------------------------------------------------------------*/
/*--------------- INSERT IN DB2 TABELLE TADM60A1 -----------------*/
/*----------------------------------------------------------------*/
INSERT_TADM60A1: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM60A1..."
cIns = 0
cDead = 0
cTime = 0
say ' ' time() 'begin insert into tadm60a1'
call sqlPrepare 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
call sqlRxExecute 7,
, m.to.tx.tst, m.to.tx.v.dbMb, m.to.tx.evTy,
, m.to.tx.v.plan, left(m.to.tx.v.corr, 18), left(m.to.tx.v.conn, 18),
, m.to.tx.h.plan, left(m.to.tx.h.corr, 18), left(m.to.tx.h.conn, 18),
, 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
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:
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM63A1..."
OUTPUT_COUNT_UOW = 1
REC_INSERTED_UOW = 0
DO WHILE OUTPUT_COUNT_UOW < CNT_OUTPUT_UOW
REC_INSERTED_UOW = REC_INSERTED_UOW + 1
INSERT= "INSERT INTO "m.tadmCreator".TADM63A1 (" ,
"TIMESTAMP ," ,
"SSID ," ,
"EVENT_TYPE ," ,
"PLAN_NAME ," ,
"CORRID_ID ," ,
"CONN_ID ," ,
"AUTHID ," ,
"LOGREC )" ,
"VALUES ('"EVENT_UOW_DATE.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_SSID.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_TYPE.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_PLAN.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_CORRID.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_CONNID.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_AUTHID.OUTPUT_COUNT_UOW "'" ,
" ,'"EVENT_UOW_LOGREC.OUTPUT_COUNT_UOW "'" ,
" )"
SQLTEXT = INSERT
ADDRESS DSNREXX "EXECSQL DECLARE C8 CURSOR FOR S8"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S8 FROM :INSERT"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL EXECUTE S8"
IF SQLCODE <> 0 THEN CALL SQLCA
OUTPUT_COUNT_UOW = OUTPUT_COUNT_UOW + 1
END
SAY " "REC_INSERTED_UOW "RECORDS INSERTED INTO TADM63A1"
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM63A1..."
RETURN;
/*----------------------------------------------------------------*/
/*--------------- INSERT IN DB2 TABELLE TADM64A1 -----------------*/
/*----------------------------------------------------------------*/
INSERT_TADM64A1:
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM64A1..."
OUTPUT_COUNT_LES = 1
REC_INSERTED_LES = 0
DO WHILE OUTPUT_COUNT_LES < CNT_OUTPUT_LES
REC_INSERTED_LES = REC_INSERTED_LES + 1
INSERT= "INSERT INTO "m.tadmCreator".TADM64A1 (" ,
"TIMESTAMP ," ,
"SSID ," ,
"EVENT_TYPE ," ,
"PLAN_NAME ," ,
"PACKAGE_NAME ," ,
"COLLECTION_ID ," ,
"CORRID_ID ," ,
"CONN_ID ," ,
"RESOURCE ," ,
"LOCK_STATE ," ,
"STATEMENT )" ,
"VALUES ('"EVENT_LES_DATE.OUTPUT_COUNT_LES "'" ,
" ,'"EVENT_LES_SSID.OUTPUT_COUNT_LES "'" ,
" ,'"EVENT_LES_TYPE.OUTPUT_COUNT_LES "'" ,
" ,'"EVENT_LES_PLAN.OUTPUT_COUNT_LES "'" ,
"," quo18(EVENT_LES_PACKAGE.OUTPUT_COUNT_LES) ,
"," quo18(EVENT_LES_COLLID.OUTPUT_COUNT_LES) ,
"," quo18(EVENT_LES_CORRID.OUTPUT_COUNT_LES) ,
"," quo18(EVENT_LES_CONNID.OUTPUT_COUNT_LES) ,
" ,'"EVENT_LES_RESOURCE.OUTPUT_COUNT_LES "'" ,
" ,'"EVENT_LES_LOCKSTATE.OUTPUT_COUNT_LES "'" ,
" ,'"EVENT_LES_STATEMENT.OUTPUT_COUNT_LES "'" ,
" )"
SQLTEXT = INSERT
ADDRESS DSNREXX "EXECSQL DECLARE C11 CURSOR FOR S11"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S11 FROM :INSERT"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL EXECUTE S11"
IF SQLCODE <> 0 THEN CALL SQLCA
OUTPUT_COUNT_LES = OUTPUT_COUNT_LES + 1
END
SAY " "REC_INSERTED_LES "RECORDS INSERTED INTO TADM64A1"
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM64A1..."
RETURN;
/*----------------------------------------------------------------*/
/*--------------- INSERT IN DB2 TABELLE TADM65A1 -----------------*/
/*----------------------------------------------------------------*/
INSERT_TADM65A1:
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM65A1..."
OUTPUT_COUNT_EOT = 1
REC_INSERTED_EOT = 0
DO WHILE OUTPUT_COUNT_EOT < CNT_OUTPUT_EOT
REC_INSERTED_EOT = REC_INSERTED_EOT + 1
INSERT= "INSERT INTO "m.tadmCreator".TADM65A1 (" ,
"TIMESTAMP ," ,
"SSID ," ,
"EVENT_TYPE ," ,
"CORRID_ID ," ,
"JOBNAME ," ,
"CONN_ID ," ,
"AUTHID ," ,
"ASID ," ,
"TCB )" ,
"VALUES ('"EVENT_EOT_DATE.OUTPUT_COUNT_EOT "'" ,
" ,'"EVENT_EOT_SSID.OUTPUT_COUNT_EOT "'" ,
" ,'"EVENT_EOT_TYPE.OUTPUT_COUNT_EOT "'" ,
"," quo18(EVENT_EOT_CORRID.OUTPUT_COUNT_EOT) ,
"," quo18(EVENT_EOT_JOBNAME.OUTPUT_COUNT_EOT) ,
"," quo18(EVENT_EOT_CONNID.OUTPUT_COUNT_EOT) ,
" ,'"EVENT_EOT_USER.OUTPUT_COUNT_EOT "'" ,
" ,'"EVENT_EOT_ASID.OUTPUT_COUNT_EOT "'" ,
" ,'"EVENT_EOT_TCB.OUTPUT_COUNT_EOT "'" ,
" )"
SQLTEXT = INSERT
ADDRESS DSNREXX "EXECSQL DECLARE C13 CURSOR FOR S13"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S13 FROM :INSERT"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL EXECUTE S13"
IF SQLCODE <> 0 THEN CALL SQLCA
OUTPUT_COUNT_EOT = OUTPUT_COUNT_EOT + 1
END
SAY " "REC_INSERTED_EOT "RECORDS INSERTED INTO TADM65A1"
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM65A1..."
RETURN;
/*----------------------------------------------------------------*/
/*--- 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
/*-- quote text t with apostrophs (sql string)
truncate if longer then 18 characters ---------------------------*/
quo18: procedure expose m.
parse arg t
if length(t) <= 18 then
return quote(t)
else
return quote(left(t, 17)"*")
endProcedur quo18
/*----------------------------------------------------------------*/
/*--------------- ZUWEISUNG EINES SPRECHENDEN TYPES --------------*/
/*----------------------------------------------------------------*/
ZUWEISUNG_TYPE:
IF m.debug THEN SAY "ENTER PROCEDURE ZUWEISUNG_TYPE..."
DO ZUWEISUNG_COUNT = 1 TO CNT_OUTPUT
SELECT
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000100' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'DB'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000200' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000201' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX-SPACE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000202' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000210' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'PARTITION'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000220' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'DATASET'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000230' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TEMP FILE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000300' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'PAGE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000301' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX-MINIPAGE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000302' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS-PAGE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000303' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX-PAGE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000304' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS-RID'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000D01' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'DBID/OBID'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000800' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'PLAN'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00000801' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'PACKAGE'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002000' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS CS-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002001' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS RR-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002002' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS WRITE-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002003' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX CS-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002004' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX RR-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002005' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX WRITE-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002006' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS PART CS-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002007' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS PART RR-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002008' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'TS PART WRITE-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002009' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX PART CS-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002010' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX PART RR-CLAIM CLASS'
WHEN EVENT_O_TYPE.ZUWEISUNG_COUNT = '00002011' THEN
EVENT_O_TYPE.ZUWEISUNG_COUNT = 'IX PART WRITE-CLAIM CLASS'
OTHERWISE NOP
END
END
IF m.debug THEN SAY "LEAVE PROCEDURE ZUWEISUNG_TYPE..."
RETURN
/*----------------------------------------------------------------*/
/*-------------- DBID UND OBID SELEKTIEREN -----------------------*/
/*----------------------------------------------------------------*/
SELECT_DBID_OBID:
IF m.debug THEN SAY "ENTER PROCEDURE SELECT_DBID_OBID..."
/*CONNECT TO DB2 SUBSYSTEM*/
call connect_subsys ssid
SAY " DBID / OBID CONVERSION..."
DO DBIDOBID_COUNT = 1 TO CNT_OUTPUT
SQL_DBID_OBID = ''
PARSE VAR EVENT_O_NAME.DBIDOBID_COUNT 1 SQL_DBID 9 SQL_DOT 10 SQL_OBID D
SQL_DBID = STRIP(SQL_DBID,L,0)
SQL_OBID = STRIP(SQL_OBID,L,0)
IF m.debug THEN SAY "DBID =" SQL_DBID
IF m.debug THEN SAY "OBID =" SQL_OBID
IF EVENT_O_TYPE.DBIDOBID_COUNT = 'DBID/OBID' THEN DO
/*GO AND CHECK THE SYSIBM.SYSTABLE*/
SQL_TB= "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
" WITH UR "
SQLTEXT = SQL_TB
ADDRESS DSNREXX "EXECSQL DECLARE C4 CURSOR FOR S4"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S4 FROM :SQL_TB"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C4"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C4 INTO :SQL_DBID_OBID :SQL_IND"
IF SQLCODE <> 0 & SQLCODE <> 100 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL CLOSE C4"
/*IF NOT FOUND GO AND CHECK THE SYSIBM.SYSTABLESPACE*/
IF SQLCODE = 100 THEN DO
SQL_TS= "SELECT ",
" STRIP(DBNAME,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
" WITH UR "
SQLTEXT = SQL_TS
ADDRESS DSNREXX "EXECSQL DECLARE C5 CURSOR FOR S5"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S5 FROM :SQL_TS"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C5"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C5 INTO :SQL_DBID_OBID :SQL_IND"
IF SQLCODE <> 0 & SQLCODE <> 100 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL CLOSE C5"
END
/*IF NOT FOUND GO AND CHECK THE SYSIBM.INDEXES*/
IF SQLCODE = 100 THEN DO
SQL_IX= "SELECT ",
" STRIP(CREATOR,B)¨¨'.'¨¨STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
" WITH UR "
SQLTEXT = SQL_IX
ADDRESS DSNREXX "EXECSQL DECLARE C6 CURSOR FOR S6"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S6 FROM :SQL_IX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C6"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C6 INTO :SQL_DBID_OBID :SQL_IND"
IF SQLCODE <> 0 & SQLCODE <> 100 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL CLOSE C6"
END
SAY " " SQL_DBID_OBID,
"SELEKTIERT FÜR DBID" SQL_DBID ", OBID" SQL_OBID
EVENT_O_NAME.DBIDOBID_COUNT = SQL_DBID_OBID,
EVENT_O_NAME.DBIDOBID_COUNT
END
END
CALL DISCONNECT_SUBSYS
IF m.debug THEN SAY "LEAVE PROCEDURE SELECT_DBID_OBID..."
RETURN
/*----------------------------------------------------------------*/
/*--------------- ZUM DB2 SUBSYSTEM VERBINDEN --------------------*/
/*----------------------------------------------------------------*/
PREPARE_DSNREXX:
IF m.debug THEN SAY "ENTER PROCEDURE PREPARE_DSNREXX..."
ADDRESS TSO 'SUBCOM DSNREXX' /*HOST CMD ENV AVAILABLE*/
IF RC=1 THEN /*NO, LET'S MAKE ONE*/
S_RC = RXSUBCOM('ADD','DSNREXX','DSNREXX') /*ADD HOST CMD ENV*/
IF RC <> 0 & RC<> 1 THEN CALL SQLCA 'add DSNREXX'
IF m.debug THEN SAY "LEAVE PROCEDURE PREPARE_DSNREXX..."
RETURN
/*----------------------------------------------------------------*/
/*--------------- ZUM DB2 SUBSYSTEM VERBINDEN --------------------*/
/*----------------------------------------------------------------*/
CONNECT_SUBSYS:
PARSE arg conSSID
IF m.debug THEN SAY "ENTER PROCEDURE CONNECT_SUBSYS" conSSID
ADDRESS DSNREXX
"CONNECT" conSSID
IF SQLCODE <> 0 THEN CALL SQLCA 'connect' conSSID
SAY ""
SAY " CONNECTED TO" conSSID
SAY ""
IF m.debug THEN SAY "LEAVE PROCEDURE CONNECT_SUBSYS..."
RETURN
/*----------------------------------------------------------------*/
/*--------------- DISCONNECT DB2 SUBSYSTEM -----------------------*/
/*----------------------------------------------------------------*/
DISCONNECT_SUBSYS:
IF m.debug THEN SAY "ENTER PROCEDURE DISCONNECT_SUBSYS..."
ADDRESS DSNREXX
"DISCONNECT "
IF SQLCODE <> 0 THEN CALL SQLCA 'disconnect'
SAY ""
SAY " DISCONNECTED FROM DB2 SUBSYSTEM"
SAY ""
IF m.debug THEN SAY "LEAVE PROCEDURE DISCONNECT_SUBSYS..."
RETURN
/*----------------------------------------------------------------*/
/*--------- AUSGEBEN VON SQL-FEHLERBESCHREIBUNG SQLCA ------------*/
/*----------------------------------------------------------------*/
SQLCA:
IF m.debug THEN SAY "ENTER PROCEDURE SQLCA..."
parse ARG msg
ggSqlStmt = sqlText
call err msg sqlMsg()
say 'error ' msg
SAY 'SQLCODE =' SQLCODE 'rc=' rc
SAY 'SQLERRMC=' SQLERRMC
SAY 'SQLERRP =' SQLERRP
SAY 'SQLERRD =' SQLERRD.1',',
SQLERRD.2',',
SQLERRD.3',',
SQLERRD.4',',
SQLERRD.5',',
SQLERRD.6
SAY 'WQLWARN=' SQLWARN.0',',
SQLWARN.1',',
SQLWARN.2',',
SQLWARN.3',',
SQLWARN.4',',
SQLWARN.5',',
SQLWARN.6',',
SQLWARN.7',',
SQLWARN.8',',
SQLWARN.9',',
SQLWARN.10
SAY 'SQLSTATE=' SQLSTATE
SAY 'SQLTEXT =' SQLTEXT
IF m.debug THEN SAY "LEAVE PROCEDURE SQLCA..."
EXIT(8)
RETURN;
/* 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 = ''
m.sql.conSSID = ''
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, 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' | 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
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlRxExecute: 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
/*--- 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
m.sql.conSSID = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
return sqlHandleRcSqlCode()
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conSSID = ''
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
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 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 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 *****************************************************s
}¢--- A540769.WK.REXX.O13(EXDB2LOT) cre=2012-07-24 mod=2012-07-27-23.19.03 A540769 ---
/* rexx text exDb2Log */
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
if 1 then
f1 = dsnAlloc('dd(ddIn1) DSN.TST.logEx.dvtb.d0727')
if 0 then
f1 = dsnAlloc('dd(ddIn1) DSN.DBA.DBTF.MSTR.MSG.LOCKEXTR')
call exdb2log dvtb
say 'exDb2Log result' result
interpret subword(f1, 2)
exit
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.O13(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.O13(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.O13(EXIO) cre= mod= --------------------------------------
/* rexx ***************************************************************
***********************************************************************/
if 0 = listDsi(d1 'FILE') then do
dsn = "'"sysDsName"'"
say 'listDsi dsn' dsn
end
else do
say 'bad rc' rc 'in listDsi(d1 FILE)'
dsn = 'tmp.a1'
call adrTso 'alloc dd(d1) mod dsn('dsn')' ,
'space(1,10) tracks recfm(v,b) lrecl(1023) mgmtclas(S005Y000)'
end
call adrTso 'alloc dd(d2) old dsn('dsn')'
dt = date('s') time()
o.1 = dt 'append eins'
o.0 = 1
call writeNext 'd1', 'o.'
call writeDDEnd 'd1'
call readDD d1, r.
say 'read0' r.0 'records from' dsn
call sayStem r.
do i=1 to r.0
r.i = r.i ',' dt 'rewri'
end
call writeNext 'd2', 'r.'
call writeDDEnd 'd2'
call readDD d1, r.
say 'zwitens read0' r.0 'records from' dsn
call sayStem r.
call adrTso 'rename' dsn dsnApp(dsn '.rename')
say 'd1' listDsi('d1 file') sysReason sysMsgLvl2 sysDsName
say 'd2' listDsi('d2 file') sysReason sysMsgLvl2 sysDsName
say 'waiting begin' sysvar(sysenv)
if sysvar(sysenv) = 'FORE' then
call adrTso "call 'pvs.pvslodv2(wait)' 'I00000400'"
else
call adrTso "call 'pvs.pvslodv2(wait)' 'I00004000'"
say 'waiting end'
call adrTso 'free dd(d1 d2)'
exit
sayStem:
parse arg ggSt
do ggI=1 to value(ggSt'0')
say ggI':' value(ggSt'ggI')
end
return
err: parse arg ggMsg; call errA ggMsg; exit 12;
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
readBegin, readNext*, readEnd read dsn in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDD:
parse arg ggDD, ggSt
call adrTso 'execio * diskr' ggDD '(stem' ggSt' finis)'
return
endSubroutine readDD
readDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(readDsn) shr dsn('ggdsn')'
call readDD 'readDsn', ggSt
call adrTso 'free dd(readDsn)'
return
endSubroutine readDsn
readDDBegin: procedure
return /* end readDDBegin */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr dsn('dsn')'
return /* end readBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return 1
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
readEnd: procedure
parse arg dd
call readDDEnd dd
call adrTso 'free dd('dd')'
return /* end readEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(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.O13(EXLISTD) cre=2012-11-15 mod=2012-11-15-11.17.02 A540769 ---
parse arg ds
if ds = '' then ds = 'wk.load'
x = Outtrap('Mem.')
address Tso "LISTD" 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)
end
dsnMbrs: procedure expose m.
parse arg m, dsn
oldOut = Outtrap('M.'m'.')
call adrTso "LISTD" 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
}¢--- A540769.WK.REXX.O13(EXLMD) cre= mod= -------------------------------------
/* rexx ****************************************************************
***********************************************************************/
lev = "A540769.P"
gr = 'xt'
lev = "PVSO.RZ1.P0"
gr = 'xy'
if 0 then do
call adrTso 'alloc dd(oo) shr reuse dsn(wk.out(listcat))'
call adrTso 'listcat level('lev') ofile(oo)'
call adrTso 'free dd(oo) '
say 'after listcat lev'
exit
x = outtrap(ot.)
call adrTso 'listcat level('lev')'
x = outtrap(off)
say 'listcat' ot.0 'for' lev
exit
end
say showTime() 'start'
if 0 then do
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('gr')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' gr lev
end
if 1 then do
call adrTso 'alloc dd(ii) shr reuse dsn('gr'.datasets)'
c = 0
r = 0
do while (r = 0)
r = adrTsoRc('execio 1000 diskr ii (stem ii.)')
if rc <> 0 then
if rc <> 2 then
call err 'execio rc' rc
c = c + ii.0
do x=1 to ii.0
dsn = word(ii.x, 1)
end
end
call adrTso 'execio 0 diskr ii (finis)'
call adrTso 'free dd(ii)'
say showTime() c 'recs from' gr
end
exit
x = outtrap(ot.)
call adrTso 'listcat level('lev')'
x = outtrap(off)
say 'at end'
exit
na = ''
do cc=1 to -1 by 1
if adrIspRc('lmdlist listid(&lmdId) dataset(na)') <> 0 then do
if rc = 4 | rc = 8 then
leave
call err 'adrIsp lmdlist rc' rc
end
if cc // 100 = 0 then
say say showtime() 'name' cc na
end
call adrIsp 'lmdlist listid(&lmdId) option(free)'
call adrIsp 'lmdfree listid(&lmdId)'
say 'at end'
exit
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTso */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
err: procedure expose m.
parse arg txt
say 'fatal error' txt
if m.pipe.errDump = '1' then
call pipeDump
say 'exiting'
exit 8
showtime:
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
}¢--- A540769.WK.REXX.O13(EXPIPE) cre=2011-03-03 mod=2011-03-03-10.36.24 A540769 ---
/* rexx */
call adrTso "free dd(p1)", '*'
call adrTso "alloc dd(p1) dsnType(pipe) pathopts(OCREAT) lrecl(80)" ,
"path('/u/a540769/pipeEins')"
say 'after alloc'
call writeDDBegin p1
say 'after ddBeg'
o.1 = 'pipe msg 1'
call writeDD p1, o, 1
call writeDDEnd 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.O13(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.O13(EXRS) cre= mod= --------------------------------------
call rsTest
exit
err:
parse arg ggMsg
call errA ggMsg
exit 12
/* copy rs begin ****************************************************/
/**********************************************************************
RS = Rexx Shell
RsRun m, iTyp iOpt, oTyp oOpt
m: the this address (m.m. ...)
iTyp iOpt: input option for scanBegin (see there)
oTyp oOpt: output option 's'=say 'd'= dd oOpt
each input line has one of four types,
depending on the first nonspace character:
'*' or '' comment is ignored
';' Rexx line (a trailing comma works as continuation marker)
'>' an output line
'|' a RexxOuput line
each rexx and rexxOutput line is compiled (into rexx)
if an output line is encountered (or at EOF),
the previously compiled rexx is interpreted
then, the output line is written after variable substitution
the following substituions are supported
$name, ${name} ${quotedString}
no space between $ and name or $ and { is allowed
spaces are allowed after the { and before the }
the names are case sensitive
these substituions are expanded in all lines
and may be assigned in rexxLines
within a called rexx function rsGet and rsPut access these variables
warning: in rexxLines neither use semicolons
nor put $ in strings (except for ${'$'} etc.),
the results are unpredictable |
example: write a table of the squares and cubes from 1 to 10:
* title line
> | n n**2 n**3 | titel squares and cubes
; do i=1 to 10
* fill one line into a $- variable
; $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)
* output the line
| | $txt |
; end
> | n n**2 n**3 | trailer squares and cubes
**********************************************************************/
rsTest: procedure
m.trace = 0
call rsPut 'eins', 'valueEins'
m.s.1 = '; $eins = "einsValue1"'
m.s.2 = '; if $eins = ${eins} then'
m.s.3 = '; say wie geht es '
m.s.4 = '> aha soso $eins und ${ ''$'' }eins = ${ eins } '
m.s.5 = '; $x = a'
m.s.6 = '; do i=1 to 3'
m.s.7 = '; $x = , '
m.s.8 = '; $x || "-"i"-" , '
m.s.9 = '; || ${ x } '
m.s.10= ' | jetzt ist x $x'
m.s.11= '; end'
m.s.12= ' '
m.s.13= '; ${ q } = quote($x)'
m.s.14 = '> und jetzt ${"$x="} $x q=${ q } '
m.s.0 = 14
call rsRun c, 'b' s, '*'
say 'end rsTest eins'
m.t.1 = ' * title line '
m.t.2 = '> | n n**2 n**3 | titel squares and cubes '
m.t.3 = '; do i=1 to 10 '
m.t.4 = ' * fill one line into $variable '
m.t.5 = '; $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)'
m.t.6 = ' * output the variable '
m.t.7 = ' | | $txt |'
m.t.8 = '; end '
m.t.9 = '> | n n**2 n**3 | trailer squares and cubes '
m.t.0 = 9
call rsRun c, 'b' t, '*'
say 'end rsTest cube'
return
endProcedure rsTest
/*----------------------------------------------------------------------
get the value of a $-variable, fail if undefined
----------------------------------------------------------------------*/
rsGet: procedure expose m.
parse arg name, s
if symbol('m.var.name') = 'VAR' then
return m.var.name
else if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure rsGet
/*----------------------------------------------------------------------
put (store) the value of a $-variable
----------------------------------------------------------------------*/
rsPut: procedure expose m.
parse arg name, value
m.var.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure rsPut
/*----------------------------------------------------------------------
read input and write output
todo: convert to a pipe
input: iTyp and iOpt as specified by scanBegin
output: d ddName or '*' (for say)
----------------------------------------------------------------------*/
rsRun: procedure expose m.
parse arg m, iTyp iOpt, oTyp oDD
s = 'm'Rs
call inBegin s, iTyp, iOpt
m.m.out = oTyp
m.m.out.0 = 0
m.m.out.total = 0
m.m.out.dd = oDD
if oTyp == 'd' then
call writeDDBegin m.m.out.dd
call scanBegin s, s, 'n'
rx = 0
oldSt = ';'
rxLi = ''
do while scanNextLine(s)
if ^scanChar(s, 1) | m.s.tok == '*' then
iterate /* empty or comment line */
c1 = m.s.tok
if c1 == ';' then do
rxLi = rxLi strip(rsRexxCompile(m, s, rxLi == ''), t)
if right(rxLi, 1) == ',' then do
c1 = ','
rxLi = strip(left(rxLi, length(rxLi) - 1), 't')
end
else do
rx = rx + 1
m.m.rexx.rx = strip(rxLi, 't')
rxLi = ''
end
oldSt = c1
end
else if oldSt ^== ';' then
call scanErr s, 'continuation expected'
else if c1 == '|' then do
rx = rx + 1
m.m.rexx.rx = rsOutCompile(m, s)
end
else if c1 == '>' then do
if rx > 0 then do
m.m.rexx.0 = rx
call rsRexxRun m'.'rexx
rx = 0
end
call rsOutInter m, s
end
else
call scanErr s, 'badLine'
end
if rx > 0 then do
m.m.rexx.0 = rx
call rsRexxRun m'.'rexx
rx = 0
end
call inEnd s
if oTyp == 'd' then do
call writeNext m.m.out.dd, 'm.m.out.'
m.m.out.total = m.m.out.total + m.m.out.0
call writeDDend m.m.out.dd
end
say m.m.out.total 'lines written to' m.m.out m.m.out.dd
return
endProcedure rsRun
/*----------------------------------------------------------------------
compile one rexxLine ( ; line):
scan until endOfLine, substitue $ clauses
and return resulting rexxClause
lineBegin=0 says, we are on a continuation line
----------------------------------------------------------------------*/
rsRexxCompile: procedure expose m.
parse arg m, rs, lineBegin
rx = ''
do while rsScanDollar(rs)
if m.rs.type == 's' then
rx = rx || m.rs.before || quote(m.rs.val)
else if m.rs.type ^== 'n' then
call err 'rsOutInter bad m.rs.type' m.rs.type
else if lineBegin & rx = '' & m.rs.before = '' then do
rx = rx || m.rs.before || 'call rsPut' quote(m.rs.name) ','
if ^ scanChar(rs, 1) | m.rs.tok ^== '=' then
call scanErr rs, 'assignment operator = expected'
end
else
rx = rx || m.rs.before || 'rsGet('quote(m.rs.name)')'
end
call trc 'rsRexxComp:' rx || m.rs.before
return rx || m.rs.before
endProcedure rsRexxCompile
/*----------------------------------------------------------------------
compile one rexxOutputLine ( | line):
scan until endOfLine, substitue $ variables
and return resulting rexx prefixed by 'call rsOut'
----------------------------------------------------------------------*/
rsOutCompile: procedure expose m.
parse arg m, rs
rx = ''
do while rsScanDollar(rs)
if m.rs.type == 's' then
rx = rx '||' quote(m.rs.before || m.rs.val)
else if m.rs.type ^== 'n' then
call err 'rsOutInter bad m.rs.type' m.rs.type
else
rx = rx '||' quote(m.rs.before) ,
'|| rsGet('quote(m.rs.name)')'
end
if rx == '' then
rx = 'call rsOut' quote(m) ',' quote(m.rs.before)
else
rx = 'call rsOut' quote(m) ',' ,
substr(rx, 5) '||' quote(m.rs.before)
call trc 'rsOutCompile:' rx
return rx
endProcedure rsOutCompile
/*----------------------------------------------------------------------
interpret a compiled rexx
----------------------------------------------------------------------*/
rsRexxRun: procedure expose m.
parse arg ggM
ggSrc = ''
do x=1 to m.ggM.0
ggSrc = ggSrc m.ggM.x ';'
end
call trc 'rsRexxRun interpreting' ggSrc
interpret ggSrc
call trc 'interpreted'
return
endProcedure rsRexxComp
rsOutInter: procedure expose m.
/*----------------------------------------------------------------------
interpret one outputLine ( > line):
scan until endOfLine, substitue $ variables by its current vale
and output resulting string
----------------------------------------------------------------------*/
parse arg m, rs
msg = ''
do while rsScanDollar(rs)
if m.rs.type == 'n' then
msg = msg || m.rs.before || rsGet(m.rs.name)
else if m.rs.type == 's' then
msg = msg || m.rs.before || m.rs.val
else
call err 'rsOutInter bad m.rs.type' m.rs.type
end
call rsOut m, msg || m.rs.before
return
endProcedure rsOutInter
/*----------------------------------------------------------------------
output one line
----------------------------------------------------------------------*/
rsOut: procedure expose m.
parse arg m, msg
if m.m.out == '*' then do
say 'rsOut:' msg
m.m.out.total = m.m.out.total + 1
end
else if m.m.out == 'd' then do
x = m.m.out.0 + 1
m.m.out.x = msg
if x >= 100 then do
call write m.m.out.dd, 'm.m.out.'
m.m.out.total = m.m.out.total + m.m.out.0
m.m.out.0 = 0
end
end
else
call err 'rsOut bad m.'m'.out' m.m.out
return
endProcedure rsOut
/*----------------------------------------------------------------------
scan a Dollar-clause
scan until next $, put text before into m.rs.before
analyse $-clause set the variables m.rs.type as follows
'n' name of variable is in m.rs.name
's' value of string is in m.rs.val
position scanner at first character after clause
return 1 if clause scanned, 0 if no $ found (until endOfLine)
faile if invalid or incomplete clause
----------------------------------------------------------------------*/
rsScanDollar: procedure expose m.
parse arg rs
call scanUntil rs, '$'
m.rs.before = m.rs.tok
if ^ scanChar(rs, 1) then
return 0
if m.rs.tok ^== '$' then
call scanErr rs 'internal: should be $'
c1 = scanRight(rs, 1)
if c1 = ' ' then
call scanErrBack rs, 'illegal $ clause'
else if c1 == '{' then do
call scanChar rs, 1
if scanName(rs) then do
m.rs.name = m.rs.tok
m.rs.type = 'n'
end
else if scanString(rs, '''') then
m.rs.type = 's'
else if scanString(rs, '"') then
m.rs.type = 's'
else
call scanErr rs, 'bad ${...} clause'
if ^scanChar(rs, 1) | m.rs.tok ^== '}' then
call scanErr rs, 'ending } missing'
end
else if scanName(rs) then do
m.rs.name = m.rs.tok
m.rs.type = 'n'
end
else
call scanErr rs, 'bad $ clause'
return 1
endProcedure rsScanDollar
/* copy rs end ****************************************************/
/* copy scan begin ****************************************************/
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034,Und hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = {*('ers' || 'tn' || '''s')"
m.q.4 = " drei;+H{>a'}123{>sdf'R}aha} '' end "
m.q.0 = 4
call scanTestDo q, 0
call scanTestDo q, 1
return
endProcedure scanTest
scanTestDo: procedure expose m.
parse arg q, scCo
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
m.s.scanComment = scCo
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTestDo
scanBegin: procedure expose m.
parse arg m, s, pOpt, sc1, sc2
m.m.skipComment = pos('c', pOpt) > 0
m.m.skipNext = pos('n', pOpt) < 1
m.m.scanReader = s
m.m.cx = 999
m.m.curLi = m'.'cx
m.m.eof = 0
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
return
endProcedure scanEnd
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanSkip: procedure expose m.
parse arg m, nxt, cmm
m.m.tok = ''
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then do
m.m.bx = vx
m.m.cx = vx
if ^ cmm then
return 1
else if ^ scanComment(m) then
return 1
m.m.tok = ''
end
else if ^ nxt then
return 0
else if ^ scanNextLine(m) then do
m.m.eof = 1
return 0
end
end
endProcedure scanSkip
scanNextLine: procedure expose m.
parse arg m
s = m.m.scanReader
if inLine(s) then do
m.m.curLi = m.in.s.line
m.m.cx = 1
return 1
end
else do
m.m.eof = 1
return 0
end
endProcedure scanNextLine
scanChar: procedure expose m.
parse arg m, len
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
l = m.m.curLi
if length(m.l) >= m.m.bx + len then
m.m.tok = substr(m.l, m.m.bx, len)
else
m.m.tok = substr(m.l, m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
m.m.val = ''
if qu = '' then
qu = "'"
l = m.m.curLi
if substr(m.l, m.m.cx, 1) ^== qu then
return 0
qx = m.m.cx + 1
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
l = m.m.curLi
if alpha == '' then do
if pos(substr(m.l, m.m.bx, 1), '012345678') > 0 then
return 0
vx = verify(m.l,
, '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ' ,
, 'n', m.m.bx)
end
else do
vx = verify(m.l, alpha, 'n', m.m.bx)
end
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else if vx <= m.m.bx then
return 0
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
if ^ scanName(m, '0123456789') then
return 0
else if datatype(scanRight(m, 1), 'A') then
call scanErrBack m, 'illegal number end'
return 1
endProcedure scanNum
scanKeyValue: procedure expose m.
parse arg m
if ^scanName(m) then
return 0
m.m.key = translate(m.m.tok)
if ^scanChar(m, 1) | m.m.tok <> '=' then
call scanErr m, 'assignment operator (=) expected'
if scanName(m) then
m.m.val = translate(m.m.tok)
else if scanNum(m) then do
m.m.val = m.m.tok
end
else if scanString(m) then
nop
else
call scanErr m, "value (name or string '...') expected"
return 1
endProcedure scanKeyValue
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx':' substr(m.l, m.m.cx)
say inLineInfo(m.m.scanReader)
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* copy scan end ****************************************************/
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
inAll: procedure expose m.
parse arg m, pTyp, pOpt, out
call inBegin m, pTyp, pOpt
if out == '' then do
call inBlock m, '*'
if inBlock(m) | m ^== m.in.m.block then
call err 'not eof after inBlock *'
end
else do
rx = 0
do while inBlock(m)
bl = m.in.m.block
do ix=1 to m.bl.0
rx = rx + 1
m.out.rx = m.bl.ix
end
end
m.out.0 = rx
end
call inEnd m
return
endSubroutine inAll
inBegin: procedure expose m.
parse arg m, pTyp, pOpt
m.in.m.type = pTyp
m.in.m.rNo = 0
m.in.m.bNo = 0
m.in.m.0 = 0
m.in.m.eof = 0
m.in.m.block = m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = string
m.in.m.type = 'b'
end
else if pTyp == 'b' then do
m.in.m.block = pOpt
end
else if pTyp == 'd' then do
m.in.m.dd = pOpt
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.in.m.type = 'd'
m.in.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.in.m.dd = 'in'm
else
m.in.m.dd = m
inf = 'dd' m.in.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.in.m.dd') shr dsn('pOpt')'
end
else
call err 'inBegin bad type' pTyp
m.in.m.info = pTyp'-'m.in.m.type inf
return
endProcedure in
inLine: procedure expose m.
parse arg m
r = m.in.m.rNo + 1
if r > m.in.m.0 then do
if ^ inBlock(m) then
return 0
r = 1
end
m.in.m.line = m.in.m.block'.'r
m.in.m.rNo = r
return 1
endProcedure inLine
inBlock: procedure expose m.
parse arg m, cnt
if m.in.m.type == 'd' then do
m.in.m.bNo = m.in.m.bNo + m.in.m.0
m.in.m.eof = ^ readNext m.in.m.dd, m'.'m.in.m'.', cnt
return ^ m.in.m.eof
end
else if m.in.m.type == 'b' then do
if m.in.m.bNo > 0 then do
m.eof = 1
return 0
end
m.in.m.bNo = 1
b = m.in.m.block
m.in.m.0 = m.b.0
return 1
end
else
call err 'inBlock bad m.in.'m'.type' m.in.m.type
endProcedure inBlock
inLineInfo: procedure expose m.
parse arg m, lx
if lx = '' then
lx = m.in.m.rNo
cl = m.in.m.block'.'lx
return 'record' (lx + m.in.m.bNo) ,
'(m.'cl 'type' strip(m.in.m.info)'):' m.cl
endProcedure inLineInfo
inEnd: procedure expose m.
parse arg m
if m.in.m.type == 'd' then do
call readDDEnd m.in.m.dd
end
else if m.in.m.type == 'f' then do
call readDDEnd m.in.m.dd
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
/* copy mem end *****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDDBegin: procedure
return /* end readDDBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg ggTsoCmd
address tso ggTsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg ggTsoCmd
address tso ggTsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
adrIspRc:
parse arg ggIspCmd
address ispexec ggIspCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ggIspCmd
address ispexec ggIspCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ggIspCmd
return /* end adrIsp */
adrEdit:
parse arg ggEditCmd, ret
address isrEdit ggEditCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' ggEditCmd
return /* end adrEdit */
adrEditRc:
parse arg ggEditCmd
address isrEdit ggEditCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(EXSIGNAL) cre= mod= ----------------------------------
/* rexx *************************************************************** 00010000
signal value ... ist ein dynamisches goTo, alle do,if usw. 00020000
der aktuellen procedure werden verlassen, 00030000
aber nicht die procedure (erst beim nächsten return |) 00040000
interpret ist sehr schnell, 00050000
interpret call ... durch signal value zu simulieren 00060000
lohnt sich i.a. NICHT 00070000
**********************************************************************/ 00080000
p0Cnt = 0 00090000
p1Cnt = 0 00100000
p2Cnt = 0 00110000
p3Cnt = 0 00120000
tms = 10000 00130000
call showTime('start') 00140000
do i=1 to tms 00150000
p0Cnt = p0Cnt + 1 00160000
end 00170000
call showTime(tms 'do + ' v p0Cnt) 00180000
do i=1 to tms 00190000
call p1proc i 00200000
end 00210000
call showTime(tms 'call p1Proc' p1Cnt) 00220000
do i=1 to tms 00230000
call p2sub i 00240000
end 00250000
call showTime(tms 'call p2Sub' p2Cnt) 00260000
i=1 00270000
Lab3: 00280000
i = i + 1 00290000
p3Cnt = p3Cnt + 1 00300000
if i <= tms then 00310000
signal Lab3 00320000
call showTime(tms 'signal lab3' p3Cnt) 00330000
do i=1 to tms 00340000
interpret 'p0Cnt =' p0Cnt '+ 1' 00350000
end 00360000
call showTime(tms 'do interpret + ' v p0Cnt) 00370000
v = 'p1Proc' 00380000
do i=1 to tms 00390000
interpret 'call' v 'i' 00400000
end 00410000
call showTime(tms 'interpret call' v p1Cnt) 00420000
v = 'p2Sub' 00430000
do i=1 to tms 00440000
interpret 'call' v 'i' 00450000
end 00460000
call showTime(tms 'interpret call' v p2Cnt) 00470000
i=1 00480000
v='LAB32' 00490000
Lab32: 00500000
i = i + 1 00510000
p3Cnt = p3Cnt + 1 00520000
if i <= tms then 00530000
signal value v 00540000
00550000
call showTime(tms 'signal value lab32' p3Cnt) 00560000
call testSignal eins, 'tEins' 00570000
call testSignal 'Zwei', 'tZwei' 00580000
say 'signal testSignal' 00590000
signal testSignal 00600000
say 'after signal zwei' 00610000
exit 00620000
00630000
testSignal: 00640000
parse upper arg goal, text 00650000
say 'testSignal' goal',' text 00660000
parse upper arg goal, text 00670000
say 'testSignal2' goal',' text 00680000
signal value goal 00690000
eins: 00700000
say 'after eins:' 00710000
zwei: 00720000
say 'after zwei:' 00730000
drei: 00740000
say 'after drei:' 00750000
return 00760000
say 'after return of testSignal' 00770000
00780000
p1proc: procedure expose p1Cnt 00790000
parse arg a1 00800000
p1Cnt = p1Cnt + 1 00810000
return 00820000
00830000
p2sub: 00840000
parse arg a1 00850000
p2Cnt = p2Cnt + 1 00860000
return 00870000
00880000
showTime: 00890000
parse arg showmsg 00900000
say time() sysvar('syscpu') sysvar('syssrv') showmsg 00910000
return 0 00920000
}¢--- A540769.WK.REXX.O13(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.O13(EXSOURCE) cre=2011-04-15 mod=2011-04-15-14.18.50 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.O13(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.O13(EXTAB) cre= mod= -------------------------------------
/* rexx *************************************************************
*********************************************************************/
parse arg fun
say 'tabEins fun'
if fun = '' then do
call adrIsp 'tbcreate tb1 names(date time info) nowrite'
call fillRow 'Eins'
call adrIsp 'tbAdd tb1 save(ex1 ex2)'
call sayRow 'add'
call fillRow 'reset'
call sayRow 'reset'
call adrIsp 'tbGet tb1 savename(extvars)'
call sayRow 'get('extVars')'
call adrTso "call 'CMN.DIV.P0.A18A.#000004.LLB(WKISP)'",
"'rec und Weiter ?' asis"
call adrTso "call 'CMN.DIV.P0.A18A.#000004.LLB(WKISP)'",
"'zweiter versuch' asis"
call adrIsp 'tbend tb1'
end
else do
call sayRow 'entry'
call adrIsp 'tbAdd tb1 save(ex1 ex2)'
call adrIsp 'tbGet tb1 savename(extvars)'
call sayRow 'e get('extVars')'
end
exit
sayRow:
parse arg tit
say tit 'date' date 'time' time 'info' info
say ' ex1' ex1 'ex2' ex2 'ot1' ot1
return
fillRow:
parse arg rid
date = date(s)
time = time(l)
info = 'info'rid
ex1 = 'ex1='rid
ex2 = 'ex2='rid
ot1 = 'ot1='rid
return
/*********************************************************************/
rz = sysvar('SYSNODE')
dsnPref = 'OMS.DIV.P0.STAT.'rz'.ASC'
say 'start POV Monats Statistik Kollektor'
say ' Version 0.2 A540769.ISPF.REXX(POVMONKO)'
say ' in RZ' rz 'dsnPrefix' dsnPref
call allocateDsn date('S'), dsnPref
call adrTso "call *(ts5240) "
call freeRename (adrTsoRc = 0)
if rz ^= 'RZ1' then
call transferDsn /* transfer new datasets to rz1 */
return /* main */
/*********************************************************************
main code END
*********************************************************************/
allocateDsn:
/*********************************************************************
generate Datasetnames
allocate month input and output DD's for current and previous month
*********************************************************************/
parse arg dt, pref
ym = left(dt, 6)
sv = right(dt, 6)
say dt '=>' ym sv
do i=1 to 9 /* compute fileNames */
yymm.i = substr(ym, 3, 4)
dsn.i = pref'.Y'left(yymm.i, 2)'M'right(yymm.i, 2)
say i yymm.i dsn.i
if right(ym, 2) > 1 then
ym = left(ym, 4)translate(format(right(ym, 2) - 1, 2),
, '0' , ' ')
else
ym = (left(ym, 4) - 1)'12'
end
like = ''
do i=1 to 2 /* allocate mon in */
if sysDsn("'"dsn.i"'") = 'OK' then do
if like = '' then
like = "'"dsn.i"'"
call adrTso "alloc dd(MoIn"yymm.i") shr reuse",
"dsn('"dsn.i"')"
end
else
call adrTso "alloc dd(MoIn"yymm.i") reuse dummy"
end
do while like='' /* look for a like dataset */
if sysDsn("'"dsn.i"'") = 'OK' then
like = "'"dsn.i"'"
else if i > 5 then
call err 'no existing dataset found from ' dsn.1 'to' dsn.i
i = i + 1
end
do i=1 to 2 /* allocate mon out */
dsn = "'"dsn.i".NEW'"
if sysDsn(dsn) = 'OK' then
call adrTso "delete" dsn
call adrTso "alloc dd(MoOu"yymm.i") new catalog reuse",
" dsn("dsn") like("like") MGMTCLAS(S005N000)"
end
return; /* allocateDsn */
freeRename:
/*********************************************************************
free and rename the month Datasets depending on result
*********************************************************************/
parse arg ok
do i=1 to 2
call adrTso "free dd(MoIn"yymm.i")"
ff = listDsi('MoOu'yymm.i file)
if ff ^= 0 then
call err 'rc' ff 'from listDsi(MoOu'yymm.i 'file)',
'reason' sysReason
say 'listDsi(moOu'yymm.i') use' sysUsed 'alloc'sysAlloc sysUnits
if sysUsed = 0 then do
call adrTso "free dd(MoOu"yymm.i") delete"
end
else do
call adrTso "free dd(MoOu"yymm.i") catalog"
if ok then do
if sysDsn("'"dsn.i"'") = 'OK' then do
if sysDsn("'"dsn.i".SV"sv"'") = 'OK' then
call adrTso "delete '"dsn.i"'"
else
call adrTso "rename '"dsn.i"' '"dsn.i".SV"sv"'"
end
call adrTso "rename '"dsn.i".NEW' '"dsn.i"'"
transfer.i = 1
end
else do
if sysDsn("'"dsn.i".ER"sv"'") = 'OK' then
call adrTso "delete '"dsn.i".ER"sv"'"
call adrTso "rename '"dsn.i".NEW' '"dsn.i".ER"sv"'"
end
end
end
return /* freeRename */
transferDsn:
/*********************************************************************
transfer the newly created/modified month files to RZ1
*********************************************************************/
do i=1 to 2
say 'transfer.'i transfer.i
if transfer.i = 1 then
call connectDirect dsn.i, 'RZ1', dsn.i'.TRANSFER'
end
return /* end transfer */
connectDirect: procedure
/*******************************************************************
send the file frDsn from the current not
to the node toNode as toDsn
using connect direct
********************************************************************/
parse upper arg frDsn, toNode, toDsn
say 'sending' frDsn 'to' toNode toDsn 'with connect direct'
call adrTso "alloc shr dd(sysut1) reuse dsn('"frDsn"')"
call adrTso "alloc new delete dd(DDIN) dsn("tempPref()".ddin)" ,
"recfm(f,b) lrecl(80)"
t.1 ="DSN='"toDsn"'"
t.2 ="DEST='"toNode"'"
t.3 ="DSNCOPY='YES'"
call adrTso 'EXECIO 3 DISKW DDIN (STEM t. FINIS)'
if 0 then do
call adrTso 'EXECIO * DISKr DDIN (STEM r. FINIS)'
say 'read' r.0
do i=1 to r.0
say i r.i
end
end
call adrTso "call *(OS2900)"
/* call adrTso 'free dd(sysut1)' an unknown ghost free it already */
call adrTso 'free dd(ddin) delete'
say 'end connectDirect'
return /* end connectDirect */
tempPref: procedure
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
return d /* end tempPref */
adrTso:
parse arg tsoCmd
/* say 'adrTso' tsoCmd */
address tso tsoCmd
adrTsoRc = rc
say 'adrTso rc' adrTsoRc 'for' tsoCmd
return
adrIsp:
parse arg ispCmd
/* say 'adrTso' tsoCmd */
address ispExec ispCmd
adrIspRc = rc
say 'adrIsp rc' adrIspRc 'for' ispCmd
return
err:
parse arg errMsg
say 'fatal error:' errMsg
exit 12
}¢--- A540769.WK.REXX.O13(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.O13(EX1) cre=2009-12-05 mod=2011-04-15-14.20.21 A540769 ---
/* REXX */
CALL EXSOURCE
EXIT 23
}¢--- A540769.WK.REXX.O13(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.O13(F) cre=2012-04-02 mod=2013-05-27-11.57.49 A540769 ----
/* 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 *******************************************************/
}¢--- A540769.WK.REXX.O13(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.O13(FILETSO) cre=2009-09-03 mod=2013-09-23-11.30.43 A540769 ---
/* 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 *************************************************/
}¢--- A540769.WK.REXX.O13(FILINUX) cre=2009-09-03 mod=2011-01-12-11.51.46 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.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 *************************************************/
}¢--- A540769.WK.REXX.O13(FMT) cre=2012-04-02 mod=2012-04-02-17.18.22 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.O13(FMTF) cre=2012-04-02 mod=2012-09-17-15.24.40 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.O13(FTAB) cre=2012-12-14 mod=2013-05-27-11.58.06 A540769 ---
/* 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 ****************************************************/
}¢--- A540769.WK.REXX.O13(F2XNTRFC) cre=2010-12-03 mod=2010-12-03-11.51.43 A540769 ---
PROC 0 TRACE(TRACE) LANG(MIXD) +
SSID() SQLID() OPTION(BROWSE) +
MAXROW(2000) SQL() +
QUAL() NAME() LOCNAME() ENTRY(FULL) LIBDEF(Y)
/*---------------------------------------------------*/
/* COPYRIGHT (C) 1989 - 2001 COMPUWARE CORPORATION. */
/* ALL RIGHTS RESERVED. */
/* UNPUBLISHED - RIGHTS RESERVED */
/* UNDER THE COPYRIGHT LAWS OF THE UNITED STATES. */
/*---------------------------------------------------*/
IF &TRACE = TRACE THEN CONTROL LIST CONLIST SYMLIST
IF &SYSUID = &STR(X247267) THEN CONTROL MSG LIST SYMLIST CONLIST
IF &SQLID = THEN SET &SQLID = &SYSUID
IF &QUAL = THEN SET &QUAL = &SYSUID
IF &SSID = THEN GOTO ERR3
IF (&ENTRY NE SPUFI) && -
(&ENTRY NE FULL) && -
(&ENTRY NE TEMPLATE) THEN GOTO ERR5
IF &ENTRY = SPUFI THEN -
IF &STR(&SQL) = THEN GOTO ERR4
IF &ENTRY NE SPUFI THEN -
IF &QUAL = THEN GOTO ERR1
IF &ENTRY NE SPUFI THEN -
IF &NAME = THEN GOTO ERR2
IF (&OPTION NE EDIT) && -
(&OPTION NE BROWSE) THEN GOTO ERR6
IF &OPTION = EDIT THEN -
SET &FUNC = 2
ELSE -
SET &FUNC = 1
IF &ENTRY = SPUFI THEN -
SET &OPT = &FUNC..S
ELSE -
IF &ENTRY = TEMPLATE THEN -
SET &OPT = &FUNC..T
ELSE -
SET &OPT = &FUNC
/*----------------------------------------------------------------
/* VERIFY LENGTHS ARE ACCEPTABLE.
/*----------------------------------------------------------------
WRITE THEN LENGTH OF SSID = &LENGTH(&SSID)
IF &LENGTH(&SSID) > 4 THEN -
DO
SET &TOKEN = SSID
GOTO LNGERR
END
IF &LENGTH(&SQLID) > 8 THEN -
DO
SET &TOKEN = SQLID
GOTO LNGERR
END
IF &LENGTH(&OPT) > 8 THEN -
DO
SET &TOKEN = OPT
GOTO LNGERR
END
/* IF &LENGTH(&NAME) > 18 THEN - */ /*FD48ITB1D4-INT*/
IF &LENGTH(&NAME) > 128 THEN -
DO
SET &TOKEN = NAME
GOTO LNGERR
END
/* IF &LENGTH(&QUAL) > 8 THEN - */ /*FD48ITB1D4-INT*/
IF &LENGTH(&QUAL) > 128 THEN -
DO
SET &TOKEN = QUALIFIER
GOTO LNGERR
END
IF &LENGTH(&STR(&MAXROW)) > 5 THEN -
DO
SET &TOKEN = MAXROWS
GOTO LNGERR
END
/* IF &LENGTH(&STR(&SQL)) > 256 THEN - */ /*FD48ITB1D4-INT*/
IF &LENGTH(&STR(&SQL)) > 2048 THEN -
DO
SET &TOKEN = SQL STATEMENT
GOTO LNGERR
END
IF &STR(&MAXROW) NE ALL THEN -
IF &MAXROW <= 0 THEN GOTO MAXRWERR
IF &STR(&MAXROW) = ALL THEN -
SET &MAXROW = &STR(*)
/*---------------------------------------------------------------
/* GET REQUIRED LIBRARIES ALLOCATED TO RUN PRODUCT.
/*---------------------------------------------------------------
IF &LIBDEF = Y THEN -
ISPEXEC SELECT CMD(F2LIBRZ# DB2(Y) TRACE(&TRACE))
/*----------------------------------------------------------------*/
/* GET PLAN BASED ON SSID PT134860 */
/*----------------------------------------------------------------*/
ISPEXEC SELECT CMD(F2GETPLN SSID(&SSID) TRACE(&TRACE)) +
NEWAPPL(FD49) PASSLIB
/*---------------------------------------------------------------
/* CALL FILEAID/DB2 EXTERNAL ENTRY MODULE TO PERFORM FUNCTION.
/*---------------------------------------------------------------
SET &F2SSID = SSID(&SSID)
SET &F2SQLID = SQLID(&SQLID)
SET &F2OPT = OPT(&OPT)
SET &F2MAXROWS = MAXROWS(&STR(&MAXROW))
SET &F2LOCNAME = LOCNAME(&LOCNAME)
IF &ENTRY = SPUFI THEN -
DO
SET &F2SQL = &STR(SQL(&SQL))
SET &F2NAME =
SET &F2QUAL =
END
ELSE -
DO
SET &F2SQL =
SET &F2NAME = NAME(&NAME)
SET &F2QUAL = QUAL(&QUAL)
END
/* CHANGED NEWAPPL FROM F2DE TO FD48 FD48ITB1-09*/
ISPEXEC SELECT CMD(F2XTRN01 +
&F2SSID &F2OPT &F2SQLID +
&F2QUAL &F2NAME &F2MAXROWS +
&F2SQL &F2LOCNAME +
) +
NEWAPPL(FD49) NOCHECK PASSLIB MODE(FSCR)
SET &RC = &LASTCC
/*---------------------------------------------------------------
/* FREE LIBDEFS DONE IN PREVIOUS STEP.
/*---------------------------------------------------------------
IF &LIBDEF = Y THEN -
ISPEXEC SELECT CMD(F2LIBRZ# FREE(FREE) TRACE(&TRACE))
IF &RC = 0 THEN GOTO RETURN
GOTO EXECERR
/*----------------------------------------------------------------
/* SET APPROPRIATE MESSAGE.
/*----------------------------------------------------------------
LNGERR:-
SET &MSG = THE LENGTH ENTER FOR "&TOKEN" IS TOO LONG.
SET &RC = 8
GOTO DISPMSG
ERR1:-
SET &MSG = A QUALIFIER MUST BE SPECIFIED FOR THE "&ENTRY" OPTION.
SET &RC = 8
GOTO DISPMSG
ERR2:-
SET &MSG = AN OBJECT NAME MUST BE SPECIFIED FOR THE "&ENTRY" OPTION.
SET &RC = 8
GOTO DISPMSG
ERR3:-
SET &RC = 8
SET &MSG = NO DB2 SUBSYSTEM ID WAS SPECIFIED.
GOTO DISPMSG
ERR4:-
SET &RC = 8
SET &MSG = NO SQL SELECT STATMENT WAS SPECIFIED FOR THE SPUFI OPTION.
GOTO DISPMSG
ERR5:-
SET &RC = 8
SET &MSG = "&ENTRY" IS NOT A VALID ENTRY TYPE.
GOTO DISPMSG
ERR6:-
SET &RC = 8
SET &MSG = "&OPTION" IS NOT A VALID FUNCTION TYPE.
GOTO DISPMSG
EXECERR:-
SET &RC = 8
SET &MSG = FAILED TO EXECUTE FILEAID DB2 "&OPTION" FUNCTION.
GOTO DISPMSG
MAXRWERR:-
SET &RC = 8
SET &MSG = MAXROWS MUST BE EQUAL TO "ALL" OR GREATER THAN 0
GOTO DISPMSG
/*---------------------------------------------------------------
/* WRITE ERROR MESSAGE TO SCREEN.
/*---------------------------------------------------------------
DISPMSG: -
WRITE
WRITE &MSG
WRITE
/*---------------------------------------------------------------
/* RETURN TO CALLER.
/*---------------------------------------------------------------
RETURN: -
EXIT CODE (&RC)
}¢--- A540769.WK.REXX.O13(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.O13(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.O13(GEOM) cre= mod= --------------------------------------
/* REXX *************************************************************
this editmacro moves points by different geometric maps
default
-f<xy> from point 0, 0
-g<xy> if set select only points in select all points
rectangle (-f, -g)
-r<a> rotate by a * 90 degrees 0
-d<a> rotate Direction values by a -r
-s<f> stretch by a factor f 1
-s<xy> stretch in x/y direction 1 1
-t<xy> to point -f
.<fr> from label .zf
.<to> to label .zl
<a> angle an integer
<f> a float, e.g 13 or 45.67
<xy> coordinatesgates eg 0,34.6
**********************************************************************/
call adrEdit('macro (args)')
say 'macro args' args
if args = '' then
args = '-f121.0,289.5 -t100,100 .a .b -r2'
call analyseArgs args
rst = rotStrTraArgs(optR optS optF optT)
say 'rst' rst '-f =>' rotStrTra(rst optF)
call adrEdit '(lnF) = linenum' labF
call adrEdit '(lnT) = linenum' labT
say 'labels' labF lnF labT lnT
selPos = 0
do lx=lnF to lnT
call adrEdit '(li) = line' lx
new = editPosition(lx, li)
if optD <> 0 & new <> '' then do
new = editDirection(lx, new)
end
if new <> '' then
call adrEdit "line" lx "= (new)"
end
exit
/* *****************************************
FIELD POSIT 100.0 100.0 Font A2828I direction BACK 11 ;
FIELD POSIT 81.0 100.0 Font A2828I direCTI DOWN 8 ;
FIELD POSIT 154.5 289.5 Font A1817I START 20 LENGTH 11 ;
**********************************************************/
/* *****************************************
FIELD POSIT 121.0 289.5 Font A2828I direction across 11 ;
FIELD POSIT 140.0 289.5 Font A2828I direCTI up 8 ;
FIELD POSIT 154.5 289.5 Font A1817I START 20 LENGTH 11 ;
FIELD POSIT 170.8 289.5 Font A1817I START 31 LENGTH 4 ;
SN: Seitennummer
FIELD POSIT 179.5 289.5 Font A1817I START 35 LENGTH 8 ;
FIELD POSIT 192.3 289.5 Font A1817I START 43 LENGTH 2 ;
**********************************************************/
call testGeom
editPosition: procedure expose optG RST
parse arg lx, li
up = translate(li)
px = pos('POSI', up)
if px < 1 then
return ''
xx = wordIndex(substr(li, px), 2) + px - 1
yx = wordIndex(substr(li, px), 3) + px - 1
rx = wordIndex(substr(li, px), 4) + px - 1
if rx < 1 then
rx = length(li) + 1
if xx <= px | yx <= xx then do
say 'missing words skipping line' lx li
return ''
end
x = word(substr(li, xx), 1)
y = word(substr(li, yx), 1)
if datatype(x) <> 'NUM' | datatype(y) <> 'NUM' then do
say 'not numeric skipping line' lx li
return ''
end
if optG <> '' then do
if word(optG, 1) > x | x > word(optG, 3) ,
| word(optG, 2) > y | y > word(optG, 4) then
return ''
end
n2 = rotStrTra(RST x y)
xS = pos(' ', li, px) + 1
rS = rx - (rx <= length(li))
return left(li, xS-1),
|| reformat(n2, substr(li, xS, rS-xS)),
|| substr(li, rS)
endProcedure editPosition
reformat: procedure
parse arg nums, like
res = ''
do wx=1 to words(nums)
w = word(nums, wx)
dx = pos('.', w)
if dx > 0 & length(w) - dx > 2 then
res = res format(w,,2)
else
res = res w
end
if length(res) > 0 then
res = substr(res, 2)
if length(res) >= length(like) then
return res
do wx=1 to words(nums)
rw = wordIndex(res, wx)
rx = verify(res, '. ', 'm', rw)
if rx < rw then
rx = length(res)
lw = wordIndex(like, wx)
lx = verify(like, '. ', 'm', lw)
if lx < lw then
lx = length(like)
if rx < lx then do;
if lx-rx >= length(like) - length(res) then
return left(res, rw-1) ,
|| left('',length(like) - length(res)),
|| substr(res,rw)
res = left(res, rw-1)left('',lx-rx)substr(res,rw)
if length(res) >= length(like) then
return res
end
end
return left(res, length(like))
endProcedure reformat
editDirection: procedure expose optD
parse arg lx, li
dirs = '0=ACROSS 1=DOWN 2=BACK 3=UP '
dx = pos('DIRE', translate(li))
if dx < 1 then
return ''
vx = wordIndex(substr(li, dx), 2) + dx - 1
w = translate(word(substr(li, vx), 1))
if w = '' then do
say 'direction missing' lx li
return ''
end
cx = pos('='w, dirs)
if cx < 2 then do
say 'direction illegal' w 'line' lx li
return ''
end
nx = angleNorm(optD + substr(dirs, cx-1, 1))
cx = pos(nx'=', dirs)
nn = word(substr(dirs, cx+2), 1)
qx = length(nn) - length(w)
if qx <= 0 then do
new = left(li, vx-1)nn||left('',-qx)substr(li,vx+length(w))
end
else do
rx = verify(substr(li, vx+length(w)), ' ');
if rx <= 0 then
rx = 1 + length(li)
else if rx - 2 > qx then
rx = vx + length(w) + qx
else
rx = vx + length(w) + rx - 2
new = left(li, vx-1)nn||strip(substr(li,rx), 't')
end
return new
end editDirection
analyseArgs: procedure expose optD optF optG optR optS optT labF labT
parse arg args
parse value '0 *' with optR optD optF optG optT labF labT
optS = 1 1
do wx=1 by 1
w = word(args, wx)
if w = '' then
leave
wL = left(w, 2)
wR = substr(w, 3)
select
when wL = '-d' then optD = wR
when wL = '-f' then optF = translate(wR, ' ', ',')
when wL = '-g' then optG = translate(wR, ' ', ',')
when wL = '-r' then optR = wR
when wL = '-s' then do
optS = translate(wR, ' ', ',')
if words(optS) = 1 then
optS = optS optS
end
when wL = '-t' then optT = translate(wR, ' ', ',')
when left(wL, 1) = '.' then do
if labF = '' then labF = w
else if labT = '' then labT = w
else call err 'more than two labels' w
end
when wL = '-?' | left(wL, 1) = '?' then do
call help
exit
end
otherwise call err 'bad Option' w
end /* select */
end /* do each word */
if optF = '' then optF = 0 0
if optT = '' then optT = optF
if labF = '' then labF = '.zf'
if labT = '' then labT = '.zl'
if optG <> '' then do
if word(optF, 1) <= word(optG, 1) then do
tl = word(optF, 1)
br = word(optG, 1)
end
else do
tl = word(optG, 1)
br = word(optF, 1)
end
if word(optF, 2) <= word(optG, 2) then
optG = tl word(optF, 2) br word(optG, 2)
else
optG = tl word(optG, 2) br word(optF, 2)
end
if optD = '*' then
optD = optR
else if optD = '' then
optD = 0
say 'analyseArgs -f='optF '-g='optG '-r='optR '-d='optD,
'-s='optS '-t='optT,
'from' labF 'to' labT
return
endProcedure analyseArgs
testGeom: procedure
say 'mod(112, 10)' mod(112, 10)
say 'mod(-112, 10)' mod(-112, 10)
say testRotate(0 4 5)
say testRotate(1 4 5)
say testRotate(1 4 '-5')
say testRotate(2 4 '-5')
say testRotate(3 4 '-5')
say testRotate(-297 4 '-5')
/* say testRotate(297.1 4 '-5') */
call testRST 0 1 1 1 2 7 9
call testRST 3 1 1 1 2 7 9
call testRST 2 2 3 1 2 7 9
return
end gestGeom
testRotate: procedure
parse arg aa
return 'rotate('aa') => 'rotate(aa)
endProcedure testRotate
rotate: procedure
parse arg a x y
select
when a=0 then return x y
when a=1 then return -y x
when a=2 then return -x (-y)
when a=3 then return y (-x)
otherwise return rotate(angleNorm(a) x y)
end
endProcedure rotate
testRST: procedure
parse arg r sx sy f g t u
aa = rotStrTraArgs(r sx sy f g t u)
say 'rotStrTraArgs('r sx sy f g t u ') =>' aa
say 'from RST('f g') =>' rotStrTra(aa f g)
say ' RST(-7 0 +7, -3) =>' left(rotStrTra(aa (-7) (-3)), 12) ,
left(rotStrTra(aa ( 0) (-3)), 12) ,
left(rotStrTra(aa (+7) (-3)), 12)
say ' RST(-7 0 +7, 0) =>' left(rotStrTra(aa (-7) ( 0)), 12) ,
left(rotStrTra(aa ( 0) ( 0)), 12) ,
left(rotStrTra(aa (+7) ( 0)), 12)
say ' RST(-7 0 +7, +3) =>' left(rotStrTra(aa (-7) (+3)), 12) ,
left(rotStrTra(aa ( 0) (+3)), 12) ,
left(rotStrTra(aa (+7) (+3)), 12)
return
end testRST
rotStrTra: procedure
parse arg r sx sy t u x y
return trans(stretch(sx sy rotate(r x y)) t u)
endProcedure trans
rotStrTraArgs: procedure
parse arg r sx sy f g t u
/* rotate and stretch origin (f g) */
z = stretch(sx sy rotate(r f g))
/* move it to (t u) */
return r sx sy trans(t u rotate(2 z))
endProcedure rotStrTraArgs
trans: procedure
parse arg a b x y
return (a+x) (b+y)
endProcedure trans
stretch: procedure
parse arg fx fy x y
return (fx*x) (fy*y)
endProcedure stretch
angleNorm: procedure
parse arg a
n = mod(a, 4)
if length(n) <> 1 | verify(n, '0123') > 0 then
call err 'bad angle' a
return n
endProcedure angleNorm
mod: procedure
parse arg a, b
if a >= 0 then
return a // b
else
return b + a // b
endProcedure mod
/************** member copy adr **************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnGetLLQ: get the llq from a dsn
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
***********************************************************************/
say dsnApp("a.b c(d e) f' ))) h")
say dsnApp("'a.b c(d e) f' ))) h")
call help
call errHelp(test errHelp)
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return dsn"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnGetLLQ: procedure
parse arg dsn
rx = pos('(', dsn) - 1
if rx < 0 then
rx = length(dsn)
lx = lastPos('.', dsn, rx)
return strip(substr(dsn, lx+1, rx-lx), 'b', "'")
endProcedure dsnGetLLQ
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg lvGrp, lvSt
return readNext(lvGrp, lvSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
end lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
call sequence: readBegin, readNext*, readEnd
1. arg (dd) dd name, wird alloziert in begin und free in end
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr reuse dsn('dsn')'
return /* end readBegin */
readNext:
parse arg lv_DD, lv_St
if adrTsoRc('execio 100 diskr' lv_DD '(stem' lv_St')') = 0 then
return 1
else if rc = 2 then
return (value(lv_St'0') > 0)
else
call err 'execio 100 diskr' lv_DD 'rc' rc
return /* end readNext */
readEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
call adrTso 'free dd('dd')'
return /* end readEnd */
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
variable Expansion: replace variable by their value
***********************************************************************/
varExpandTest: procedure
m.v.eins ='valEins'
m.v.zwei ='valZwei'
m.l.1='zeile eins geht unverändert'
m.l.2='$EINS auf zeile ${ZWEI} und \$EINS'
m.l.3='...$EINS?auf zeile ${ZWEI}und $EINS'
m.l.4='...$EINS,uf zeile ${ZWEI}und $EINS$$'
m.l.5='${EINS}$ZWEI$EINS${ZWEI}'
m.l.0=5
call varExpand l, r, v
do y=1 to m.r.0
say 'old' y m.l.y
say 'new' y m.r.y
end
return
endProcedure varExpandTest
varExpand: procedure expose m.
parse arg old, new, var
varChars = ,
'0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
do lx=1 to m.old.0
cx = 1
res = ''
do forever
dx = pos('$', m.old.lx, cx)
if dx < cx then do
m.new.lx = res || strip(substr(m.old.lx, cx), 't')
leave
end
res = res || substr(m.old.lx, cx, dx - cx)
if dx >= length(m.old.lx) then
call err '$ at end line m.'old'.'lx'='m.old.lx
if substr(m.old.lx, dx+1, 1) = '$' then do
res = res || '$'
cx = dx + 2
iterate
end
if substr(m.old.lx, dx+1, 1) = '{' then do
cx = pos('}', m.old.lx, dx+1)
if cx <= dx then
call err 'ending } missing line m.'old'.'lx'='m.old.lx
na = substr(m.old.lx, dx+2, cx-dx-2)
cx = cx + 1
end
else do
cx = verify(m.old.lx, varChars, 'N', dx+1);
if cx <= dx then
cx = length(m.old.lx) + 1
na = substr(m.old.lx, dx+1, cx-dx-1)
end
if symbol('m.v.na') = 'VAR' then
res = res || m.var.na
else
call err 'var' na 'not defined line m.'old'.'lx'='m.old.lx
end
m.new.0 = m.old.0
end
return /* var expand */
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggStmt, ggNo
if ggNo <> '1' then
ggStmt = 'execSql' ggStmt
address dsnRexx ggStmt
if rc = 0 then
nop /* say "sql ok:" ggStmt */
else if rc > 0 then
say "sql warn rc" rc sqlmsg()':' ggStmt
else
call err "sql rc" rc sqlmsg()':' ggStmt
return
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 0 then do
sRC = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
say 'subcom' sRc
end
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
if sqlCode = 0 then
return 'ok (sqlCode=0)'
else
return 'sqlCode='sqlCode,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
err:
parse arg txt
parse source s1 s2 s3 .
say 'fatal error in' s3':' txt
exit 12
errHelp: procedure
parse arg errMsg
say 'fatal error:' errMsg
call help
call err errMsg
endProcedure errHelp
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return
endProcedure help
showtime:
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
}¢--- A540769.WK.REXX.O13(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.O13(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.O13(II) cre= mod= ----------------------------------------
/* rexx ***************************************************************
**********************************************************************/
say 'ii begin'
call pipeIni
call pipePush 'abc'
l = pipeBegin()
pp = m.pi.pipe
m.a.1 = 'a eins'
m.a.2 = 'a zwei'
m.a.0 = 2
call writeLn pp, 'first'
call write pp, a
call piWC l
l = pipeBar()
call wrSay l, "wrSay line", "wrSay block"
trace ?R
l = pipeEnd()
m.pi.pi = pp
call piOutLn 'first after say'
call piOut a
call wrClose pp
say 'ii end'
exit
call wrIni
m.a.1 = 'a eins'
m.a.2 = 'a zwei'
m.a.0 = 2
m.pi.pi = wrNew()
l = pipeBegin()
call piOutLn 'first'
call piOut a
call piSet l
call piWC l
call wrSay m.pi.out.l, "wrSay line", "wrSay block"
call piOutLn 'first after say'
call piOut a
call wrClose l
call wrClose m.pi.out.l
say 'ii end'
exit
s = wrNew()
w = wrNew()
call writeLn w, 'first'
m.a.1 = 'a eins'
m.a.2 = 'a zwei'
m.a.0 = 2
call write w, a
/* call wrSay s, "wrSay line", "wrSay block" */
call wrFile s, "-dsnwk.text(testEins)"
call wrWC w, s
call writeLn w, 'first after say'
call write w, a
call wrClose w
call wrClose s
say 'ii end'
exit
/**********************************************************************
pi = pipe interface and simple pipes
***********************************************************************/
pipeIni: procedure expose m.
call wrIni
m.pi.pipe.0 = 0
call pipePush
return
endProcedure pipeIni
piSet: procedure expose m.
parse arg m, m.pi.out.m
if m.pi.out.m == '' then
m.pi.out.m = wrNew()
return m.pi.out.m
endProcedure piSet
piOut: procedure expose m.
parse arg stem
oldP = m.pi.pi
m.pi.pi = m.pi.out.oldP
call write m.pi.pi, stem
m.pi.pi = oldP
return
endProcedure piOut
piOutLn: procedure expose m.
parse arg line
oldP = m.pi.pi
m.pi.pi = m.pi.out.oldP
call writeLn m.pi.pi, line
m.pi.pi = oldP
return
endProcedure piOutLn
piWC: procedure expose m.
parse arg m
m.wr.wc.m.chars = 0
m.wr.wc.m.lines = 0
call wrSet m,
, "do xx=1 to m.stem.0; " ,
" m.wr.wc.m.lines = m.wr.wc.m.lines + 1;",
" m.wr.wc.m.chars = m.wr.wc.m.chars + length(m.stem.xx);" ,
" call piOutLn 'piWC'" m "': ' m.stem.xx;" ,
" end;",
, "call piOutLn 'piWC' m 'counted'",
" m.wr.wc.m.lines 'lines and'",
" m.wr.wc.m.chars 'characters'"
return
endProcedure piWC
pipePush: procedure expose m.
parse arg pp
if pp == "" then
pp = 0
m.pi.pipe = pp
px = m.pi.pipe.0 + 1
m.pi.pipe.0 = px
m.pi.pipe.px = pp
return
endProcedure pipePush
pipePop: procedure expose m.
m.pi.pipe = p
px = m.pi.pipe.0 - 1
m.pi.pipe.0 = px
m.pi.pipe = m.pi.pipe.px
return
endProcedure pipePop
pipeActive: procedure expose m.
parse arg mustBeActive, mustHaveChild
if m.pi.pipe == 0 then do
if mustBeActive then
call err 'pipe not active'
else
return 0
end
else do
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
if cx == 0 then do
if mustHaveChild then
call err 'pipe is empty'
else
return 0
end
if m.pi.pi ^== m.pi.piChild.pp.cx then
call err 'pipe mismatched currentProcess' m.pi.pi
return m.pi.pi
end
endProcedure pipeActive
pipeBegin: procedure expose m.
nn = wrNew()
call pipePush nn
m.pi.piChild.nn.0 = 0
m.pi.piHist.nn.0 = m.pi.pi
return pipeChildBegin()
endProcedure pipeBegin
pipeBar: procedure expose m.
call pipeChildEnd
return pipeChildBegin()
endProcedure pipeBar
pipeChildEnd: procedure expose m.
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
if m.pi.pi ^== m.pi.piChild.pp.cx then
call err 'proc not last child'
m.pi.pi = m.pi.pipe
return
endProcedure pipeChildEnd
pipeChildBegin: procedure expose m.
if m.pi.pi ^== m.pi.pipe then
call err 'proc not current pipe'
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
ch = m.pi.piChild.pp.cx
if cx ^== 0 then
ch = m.pi.out.ch
else
ch = wrNew()
call piSet ch
cx = cx + 1
m.pi.piChild.pp.0 = cx
m.pi.piChild.pp.cx = ch
m.pi.pi = ch
return ch
endProcedure pipeChildBegin
pipeEnd: procedure expose m.
call pipeChildEnd
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
ch = m.pi.piChild.pp.cx
call piSet pp, m.pi.piChild.pp.cx
call pipePop
m.pi.pi = pp
call piWriClo "call pipeWrite m, stem", "call pipeClose m"
m.pi.pi = m.pi.piHist.pp.0
return pp
endProcedure pipeEnd
piWriClo: procedure expose m.
parse arg wri, clo
call wrSet m.pi.pi, wri, clo
if pipeActive(0, 0) == 0 then
call wrClose m.pi.pi
return
endProcedure piWriClo
pipeWrite: procedure expose m.
parse arg m, stem
oldP = m.pi.pi
m.pi.pi = m.pi.piChild.m.1
call write m.pi.pi, stem
m.pi.pi = oldP
return
endProcedure pipeWrite
pipeClose: procedure expose m.
parse arg m
oldP = m.pi.pi
do cx = 1 to m.pi.piChild.m.0
m.pi.pi = m.pi.piChild.m.cx
call wrClose m.pi.pi
end
m.pi.pi = oldP
return
endProcedure pipeClose
/**********************************************************************
proc = process
***********************************************************************/
procIni: procedure expose m.
m.proc.proc = 0
m.proc.proc.0 = 0
m.proc.out = 0
m.proc.ini = 1
return
endProcedure procNew
procNew: procedure expose m.
parse arg nn, oo
if nn == '' then
nn = prNew()
if oo == '' then
oo = prNew()
m.proc.out.nn = oo
return nn
endProcedure procNew
procPush: procedure expose m.
parse arg pp
ix = m.proc.proc.0 + 1
m.proc.proc.0 = ix
m.proc.proc.ix = pp
m.proc.proc = pp
m.proc.out = m.proc.out.pp
return
endProcedure procPush
procPop: procedure expose m.
ix = m.proc.proc.0 -1
m.proc.proc.0 = ix
pp = m.proc.proc.ix
m.proc.proc = pp
m.proc.out = m.proc.out.pp
return
endProcedure procPop
procOut: procedure expose m.
parse arg stem
call write m.proc.out, stem
return
endProcedure procOut
procOutLn: procedure expose m.
parse arg stem
call writeLn m.proc.out, stem
return
endProcedure procOutLn
procInfo: procedure expose m.
parse arg arg, oo
do cx = m.proc.proc.0 by -1 to 1
ch = m.proc.proc.cx
if ch ^== 0 & m.proc.info.ch ^== '' then
call wrInfoInter ch, arg, oo
end
return
endProcedure procInfo
/**********************************************************************
wr = writer interface and simple writers
***********************************************************************/
wrWriClo: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, m.wr.info.m, m.wr.buf.m.max
if m.wr.buf.m.max == '' then
m.wr.buf.m.max = 100
return
endProcedure wrWriClo
wrNew: procedure expose m.
nn = m.wr.new + 1
m.wr.new = nn
m.wr.buf.nn.0 = 0
call wrSet nn, "" , "call err 'wr" nn "close not defined'", 9999
return nn
endProcedure wrNew
wrIni: procedure expose m.
m.wr.new = 0
m.wr.ini = 1
return
endProcedure wrNew
writeLn: procedure expose m.
parse arg m, line
xx = m.wr.buf.m.0 + 1
m.wr.buf.m.0 = xx
m.wr.buf.m.xx = line
if xx >= m.wr.buf.m.max then
call write m
return
endProcedure writeLn
write: procedure expose m.
parse arg m, stem
if m.wr.write.m == '' then do
if stem == 'WR.BUF.'m then
call err 'wrStemWrite overflow m.wr.buf.'m'.0 =' ox
ox = m.wr.buf.m.0
do ix=1 to m.stem.0
ox = ox + 1
m.wr.buf.m.ox = m.stem.ix
end
m.wr.buf.m.0 = ox
return
end
call procPush m
if m.wr.buf.m.0 ^== 0 then do
call writeInter m, 'WR.BUF.'m
m.wr.buf.m.0 = 0
end
if stem ^== '' then
call writeInter m, stem
call procPop
return
endProcedure write
wrClose: procedure expose m.
parse arg m
call write m
call procPush m
interpret m.wr.close.m
call procPop
return
endProcedure wrClose
writeInter: procedure expose m.
parse arg m, stem
interpret m.wr.write.m
return
endProcedure writeInter
wrInfoInter: procedure expose m.
parse arg m, info, out
interpret m.proc.info.ch
return
endProcedure wrInfoInter
wrSay: procedure expose m.
parse arg m, pref, head
call wrSet m, "call w1Say stem," quote(pref)"," quote(head),
, "say 'close'" m quote(head), 1
return
endProcedure wrSay
w1Say: procedure expose m.
parse arg stem, pref, head
if head ^== '' then
say head 'm.'stem'.0='m.stem.0
if pref == '' then do
do xx=1 to m.stem.0
say m.stem.xx
end
end
else do
do xx=1 to m.stem.0
say pref xx':' m.stem.xx
end
end
return
endProcedure w1Say
wrFile: procedure expose m.
parse arg m, args
dsn = ''
disp = 'shr'
do wx=1 to words(args)
w = word(args, wx)
if abbrev(w, '-dd') then do
dd = subword(w, 4)
call writeDDBegin dd
call wrSet m, "call writeNext" dd", m.stem."),
, "call writeDDEnd" dd
return
end
else if abbrev(w, '-disp') then
disp = substr(w, 6)
else if abbrev(w, '-dsn') then
dsn = substr(w, 5)
else if abbrev(w, '-t') then do
if length(t) > 2 then
dsn = dsnTemp(substr(w, 3))
else
dsn = dsnTemp('T'm)
end
else
leave
end
dd = 'wr'm
call adrTso "alloc dd("dd")" disp ,
"dsn("dsn")" subword(args, wx)
call writeDDBegin dd
call wrSet m, "call writeNext" dd", m.stem.",
, "call writeDDEnd" dd "; call adrTso 'free dd("dd")'"
return
endProcedure wrFile
wrWC: procedure expose m.
parse arg m, args
m.wr.wc.m.chars = 0
m.wr.wc.m.lines = 0
call wrSet m,
, "do xx=1 to m.stem.0; " ,
" m.wr.wc.m.lines = m.wr.wc.m.lines + 1;",
" m.wr.wc.m.chars = m.wr.wc.m.chars + length(m.stem.xx);" ,
" call writeLn" args ", 'wrWC'" m "': ' m.stem.xx;" ,
" end;",
, "call writeLn" args ", wrWC m 'counted'",
" m.wr.wc.m.lines 'lines and'",
" m.wr.wc.m.chars 'characters'"
return
endProcedure wrSay
ppWrite: procedure expose m.
parse arg stem
oldProc = m.pp.proc
m.pp.proc = m.pp.out.oldProc
call iiWrite m.pp.proc, stem
m.pp.proc = oldProc
return
endProcedure ppWrite
ppClose: procedure expose m.
parse arg m
oldProc = m.pp.proc
m.pp.proc = m.pp.out.oldProc
call iiClose m.pp.proc
m.pp.proc = oldProc
return
endProcedure ppClose
ppNew: procedure expose m.
nn = iiNew()
m.pp.paP.n =
ppBegin: procedure expose m.
iiWrite: procedure expose m.
parse arg m, stem
interpret m.ii.write.m
return
endProcedure iiWrite
iiClose: procedure expose m.
parse arg m
interpret m.ii.close.m
return
endProcedure iiClose
iiOpenOut: procedure expose m.
parse arg m, typ, opt, opt2
if typ == 'i' then do
m.ii.write.m = opt
m.ii.close.m = opt2
end
else if typ == '*' then do
m.ii.write.m = ,
'do x=1 to m.stem.0; say "'m'.*.out" m.stem.x; end'
m.ii.close.m = 'say "'m'.*.out close"'
end
else
call err 'bad typ' typ 'in iiOpenOut'
return
endProcedure iiOpenOut
iiOpenNew: procedure expose m.
parse arg k, typ, opt, opt2
nn = iiNew()
if k == 'o' then
call iiOpenOut nn, typ, opt, opt2
else
call err 'bad iiOpenNew kind' k
return nn
endProcedure iiOpenNew
iiNew: procedure expose m.
m.ii.0 = m.ii.0 + 1
return m.ii.0
endProcedure iiNew
iiIni: procedure expose m.
parse arg force
if m.ii.ini == 1 & force ^== 1 then
return
m.ii.ini = 1
m.ii.0 = 0
return
endProcedure iiIni
call prTest
exit
err: parse arg ggMsg; call errA ggMsg; exit 12;
/* copy pr begin ****************************************************/
prTest: procedure
m.trace = 0
call prIni
do i=1 to 5
call prPut 'v'i, 'v'i'-from-1'
end
call prInvoke prNew(), 'call prTest1 2'
return
endProcedure prTest
prTest1: procedure expose m.
parse arg n
say n 'begin' prTestVV()
do i=n to 5
call prPut 'v'i, 'v'i'-from-'n
end
say n 'put ' prTestVV()
if n <= 5 then
call prInvoke prNew(), 'call prTest1' (n+1)
say n 'end ' prTestVV()
return
endProcedure prTest1
prTestVV: procedure expose m.
parse arg n
r = ''
do i=1 to 5
r = r 'v'i'='prGet('v'i)
end
return strip(r)
endProcedure prTestVV
prIni: procedure expose m.
parse arg force
if m.pr.ini == 1 & force ^== 1 then
return
call memIni force
m.pr.proc = -1
p0 = prNew()
call outBegin p0, '*'
m.pr.out.p0 = p0
m.pr.proc = p0
m.pr.proc0 = p0
m.pr.hist.0 = 1
m.pr.hist.1 = p0
m.pr.ini = 1
return
endProcedure prIni
/*----------------------------------------------------------------------
return a new child process of the active process
----------------------------------------------------------------------*/
prNew: procedure expose m.
this = memNew()
m.pr.parent.this = m.pr.proc
m.pr.out.this = ''
m.pr.out.0 = 0
m.pr.out.max = 999999
return this
endProcedure prNew
/*----------------------------------------------------------------------
push process p to the history stack and make it the active process
----------------------------------------------------------------------*/
prPush: procedure expose m.
parse arg p
top = m.pr.hist.0
if m.pr.hist.top ^== m.pr.proc then
call err 'prPush: hist top proc mismatch'
top = m.pr.hist.0 + 1
m.pr.hist.0 = top
m.pr.hist.top = p
m.pr.proc = p
return top
endProcedure prPush
/*----------------------------------------------------------------------
pop the active process from history stack
activate the previous process
if arg tx not empty, ensure it equals the old active process
----------------------------------------------------------------------*/
prPop: procedure expose m.
parse arg tx
top = m.pr.hist.0
if m.pr.hist.top ^== m.pr.proc then
call err 'prPop: hist top proc mismatch'
if tx ^== '' then
if top ^== tx then
call err 'prPop: hist top is' top '<> expected' tx
if top <= 1 then
call err 'prPop: empty history'
top = top - 1
m.pr.hist.0 = top
m.pr.proc = m.pr.hist.top
return
endProcedure prPop
/*----------------------------------------------------------------------
push process ggPR, interpret rexx ggRexx and pop the process
----------------------------------------------------------------------*/
prInvoke: procedure expose m.
parse arg ggPr, ggRexx
ggOldProcTopHistVariable = prPush(ggPr)
interpret ggRexx
call prPop ggOldProcTopHistVariable
return
endProcedure prInvoke
prOut: procedure expose m.
parse arg line
this = m.pr.proc
x = m.pr.out.this.0 + 1
m.pr.out.this.0 = x
m.pr.out.this.x = line
if x > m.pr.out.this.max then do
memWriteWrite m.pr.out.this, pr'.'out'.'this
m.pr.out.this.0 = 0
end
return
endProcedure prOut
/*----------------------------------------------------------------------
get the value of a $-variable, fail if undefined
----------------------------------------------------------------------*/
prGet: procedure expose m.
parse arg name, s
p = m.pr.proc
do while p >= 0
if symbol('m.pr.p.name') = 'VAR' then
return m.pr.p.name
p = m.pr.parent.p
end
if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure prGet
/*----------------------------------------------------------------------
put (store) the value of a $-variable
----------------------------------------------------------------------*/
prPut: procedure expose m.
parse arg name, value
p = m.pr.proc
m.pr.p.name = value
call trc 'assign('p')' name '= <'value'>'
return
endProcedure prPut
prWriteBegin: procedure expose m.
parse arg m, pTyp pOpt
m.pr.write.m.type = pTyp
m.pr.write.m.max = 0
m.pr.write.m.bNo = 0
m.pr.write.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.pr.write.m.max = 999999999
end
else if pTyp == 'd' then do
m.pr.write.m.dd = pOpt
m.pr.write.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.pr.write.m.type = 'd'
m.pr.write.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.pr.write.m.dd = 'wri'm
else
m.pr.write.m.dd = m
m.pr.write.m.max = 100
inf = 'dd' m.pr.write.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.pr.write.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.pr.write.m.0 = 1
m.pr.write.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.pr.write.m.info = pTyp'-'m.pr.write.m.type inf
return
endProcedure outBegin
prWriteLine: procedure expose m.
parse arg m, data
r = m.pr.write.m.0 + 1
m.pr.write.m.0 = r
m.pr.write.m.r = strip(data, 't')
if m.pr.write.m.max <= r then do
call outBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
return
endProcedure outLine
prWriteBlock: procedure expose m.
parse arg m, data
if m.pr.write.m.0 ^== 0 then do
call outBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
if data ^== '' then do
call outBlockOne m, data
return
endProcedure prWriteBlock
prWriteBlockOne: procedure expose m.
parse arg m, data
m.pr.write.m.bNo = m.pr.write.m.bNo + m.data.0
if m.pr.write.m.type == 'd' then do
call writeNext m.pr.write.m.dd, 'M.'data'.'
end
else if m.pr.write.m.type = 'i' then do
interpret m.pr.write.m.rexx
end
else if m.pr.write.m.type == 'b' then do
if data == 'PR.WRITE.'m then
call err 'recursive block write' m
q = m.pr.write.m.0
do r = 1 to m.data.0
q = q + 1
m.pr.write.m.q = m.data.r
end
m.pr.write.m.0 = q
end
else if m.pr.write.m.type == '*' then do
do r = 1 to m.data.0
say 'prWrite:' m.data.r
end
end
else
call err 'blockOne bad m.pr.write.'m'.type' m.pr.write.m.type
return
endProcedure outBlock
prWriteEnd: procedure expose m.
parse arg m
if m.pr.write.m.0 ^== 0 & m.pr.write.m.type ^== 'b' then do
call writeBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
if m.pr.write.m.type == 'd' then do
call writeDDEnd m.pr.write.m.dd
if left(m.pr.write.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
else if m.pr.write.m.type == 'i' then do
if m.pr.write.rexxClose ^== '' then
interpret m.pr.write.rexxClose
end
return
endProcedure prWriteEnd
outInfo: procedure expose m.
parse arg m
if m.pr.write.m.type = 'b' then
m.pr.write.m.bNo = m.pr.write.m.0
return m.pr.write.m.bNo 'records written to',
m 'type' m.pr.write.m.info
/* copy pr end ****************************************************/
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
memIni: procedure expose m.
parse arg force
if m.mem.ini == 1 & force ^== 1 then
return
m.mem.0 = 0
m.mem.ini = 1
return
endProcedure memIni
memNew: procedure expose m.
m.mem.0 = m.mem.0 + 1
return m.mem.0
endProcedure memNew
inAll: procedure expose m.
parse arg m, inTO, out
call inBegin m, inTO
if out == '' then do
call inBlock m, '*'
if inBlock(m) | m ^== m.in.m.block then
call err 'not eof after inBlock *'
end
else do
rx = 0
do while inBlock(m)
bl = m.in.m.block
do ix=1 to m.bl.0
rx = rx + 1
m.out.rx = m.bl.ix
end
end
m.out.0 = rx
end
call inEnd m
return
endSubroutine inAll
inBegin: procedure expose m.
parse arg m, pTyp pOpt
m.in.m.type = pTyp
m.in.m.rNo = 0
m.in.m.bNo = 0
m.in.m.0 = 0
m.in.m.eof = 0
m.in.m.block = in'.'m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = in'.'m'.'string
m.in.m.type = 'b'
end
else if pTyp == 'b' then do
m.in.m.block = pOpt
end
else if pTyp == 'd' then do
m.in.m.dd = pOpt
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.in.m.type = 'd'
m.in.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.in.m.dd = 'in'm
else
m.in.m.dd = m
inf = 'dd' m.in.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.in.m.dd') shr dsn('pOpt')'
end
else
call err 'inBegin bad type' pTyp
m.in.m.info = pTyp'-'m.in.m.type inf
return
endProcedure inBegin
inLine: procedure expose m.
parse arg m
r = m.in.m.rNo + 1
if r > m.in.m.0 then do
if ^ inBlock(m) then
return 0
r = 1
end
m.in.m.line = m.in.m.block'.'r
m.in.m.rNo = r
return 1
endProcedure inLine
inBlock: procedure expose m.
parse arg m, cnt
if m.in.m.type == 'd' then do
m.in.m.bNo = m.in.m.bNo + m.in.m.0
m.in.m.eof = ^ readNext(m.in.m.dd, 'm.in.'m'.', cnt)
return ^ m.in.m.eof
end
else if m.in.m.type == 'b' then do
if m.in.m.bNo > 0 then do
m.eof = 1
return 0
end
m.in.m.bNo = 1
b = m.in.m.block
m.in.m.0 = m.b.0
return 1
end
else
call err 'inBlock bad m.in.'m'.type' m.in.m.type
endProcedure inBlock
inLineInfo: procedure expose m.
parse arg m, lx
if lx = '' then
lx = m.in.m.rNo
cl = m.in.m.block'.'lx
xx = m.in.m.rNo
if m.in.m.type == 'd' then
xx = xx + m.in.m.bNo
return 'record' xx '(m.'cl 'type' strip(m.in.m.info)'):' m.cl
endProcedure inLineInfo
inEnd: procedure expose m.
parse arg m
if m.in.m.type == 'd' then do
call readDDEnd m.in.m.dd
if left(m.in.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
outBegin: procedure expose m.
parse arg m, pTyp pOpt
m.out.m.type = pTyp
m.out.m.max = 0
m.out.m.bNo = 0
m.out.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.out.m.max = 999999999
end
else if pTyp == 'd' then do
m.out.m.dd = pOpt
m.out.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.out.m.type = 'd'
m.out.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.out.m.dd = 'out'm
else
m.out.m.dd = m
m.out.m.max = 100
inf = 'dd' m.out.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.out.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.out.m.0 = 1
m.out.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.out.m.info = pTyp'-'m.out.m.type inf
return
endProcedure outBegin
outLine: procedure expose m.
parse arg m, data
if m.out.m.0 < m.out.m.max then do
r = m.out.m.0 + 1
m.out.m.0 = r
m.out.m.r = strip(data, 't')
end
else if m.out.m.type = '*' then do
m.out.m.bNo = m.out.m.bNo + 1
say 'out:' data
end
else if m.out.m.type = 's' then do
m.out.m.bNo = m.out.m.bNo + 1
m.out.m.1 = m.out.m.1 strip(data)
end
else do
call outBlock m
m.out.m.0 = 1
m.out.m.1 = data
end
return
endProcedure outLine
outBlock: procedure expose m.
parse arg m, pp
if pp == '' then
oo = out'.'m
else
oo = pp
if m.out.m.type = '*' then do
do r = 1 to m.oo.0
say 'out:' m.oo.r
end
end
else if m.out.m.type = 's' then do
do r = 1 to m.oo.0
m.out.m.1 = m.out.m.1 strip(m.oo.r)
end
end
else if m.out.m.type = 'b' then do
if pp ^== '' then do
q = m.out.m.0
do r = 1 to m.oo.0
q = q + 1
m.out.m.q = m.oo.r
end
m.out.m.0 = q
end
end
else if m.out.m.type == 'd' then do
m.out.m.bNo = m.out.m.bNo + m.oo.0
call writeNext m.out.m.dd, 'M.'oo'.'
if pp == '' then
m.out.m.0 = 0
end
return
return 1
endProcedure outBlock
outEnd: procedure expose m.
parse arg m
if m.out.m.type == 'd' then do
call outBlock m
call writeDDEnd m.out.m.dd
if left(m.out.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure outEnd
outInfo: procedure expose m.
parse arg m
if m.out.m.type = 'b' then
m.out.m.bNo = m.out.m.0
return m.out.m.bNo 'records written to' m 'type' m.out.m.info
endProcedure outInfo
/* copy mem end *****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDDBegin: procedure
return /* end readDDBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg ggTsoCmd
address tso ggTsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg ggTsoCmd
address tso ggTsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
adrIspRc:
parse arg ggIspCmd
address ispexec ggIspCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ggIspCmd
address ispexec ggIspCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ggIspCmd
return /* end adrIsp */
adrEdit:
parse arg ggEditCmd, ret
address isrEdit ggEditCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' ggEditCmd
return /* end adrEdit */
adrEditRc:
parse arg ggEditCmd
address isrEdit ggEditCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(INC) cre=2013-04-17 mod=2013-04-17-11.30.11 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
**********************************************************************/
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 "(myMb) = member"
m.mbr = myMb
call adrEdit "cursor = .zf"
fnd = 'copy'
begMbr = ''
do forever
if adrEdit("find '"fnd"'", 0 4) ^= 0 then
leave
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' lNr li
end
end
say 'end macro inc'
exit
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 do
call adrEdit "cursor = " (tx+1) 1
loc = "before .zcsr"
end
else do
loc = "after .zl"
end
call adrEdit "delete" fx tx
if adrEdit("copy" mbr loc, '*') <> 0 then
call err "***** could not copy" mbr loc
if ^ (laX > tx) then
call adrEdit "cursor = .zl 72 "
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 == 'SCANSB' then
call mbrTransform fr, to, mbr, 'SB', 'scanSB', 'scan'
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 = repAl2(li, translate(li), translate(oldMbr), newMbr)
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
/* 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.O13(INTER) cre= mod= -------------------------------------
/* rexx */
do forever
say 'enter rexx or -'
parse pull inp
say 'pull "'inp'"'
if strip(inp) = '-' then
return
interpret inp
end
}¢--- A540769.WK.REXX.O13(J) cre=2013-01-23 mod=2013-05-27-11.46.32 A540769 ----
/* 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 *********************************************************/
}¢--- A540769.WK.REXX.O13(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.O13(JOBID) cre= mod= -------------------------------------
/* rexx ****************************************************************
write
jobName jobId
time date
and ddIn
to ddOut
***********************************************************************/
/* control block chaining see mvs / data areas */
TCB = PTR(540)
say 'tcb eye' stg(tcb+256, 4)
JSCB = PTR(TCB+180)
SSIB = PTR(JSCB+316)
JOBid = STG(SSIB+12,8)
x.1 = ' '
x.2 = ' '
x.3 = 'jobName ' mvsVar('symDef', 'jobName') 'jobId' jobId
x.4 = ' time ' time() 'date' date('e')
x.5 = ' '
x.6 = ' '
address tso "EXECIO 6 DISKW ddOut (STEM x. )"
if rc <> 0 then
call err 'writing to ddOUt rc' rc
address tso "EXECIO * DISKR ddIn (STEM x. finis)"
if rc <> 0 then
call err 'reading to ddIn rc' rc
address tso "EXECIO" x.0 "DISKW ddOut (STEM x. )"
if rc <> 0 then
call err 'writing to ddOUt rc' rc
exit 0
PTR: RETURN C2D(STORAGE(D2X(ARG(1)),4))
STG: RETURN STORAGE(D2X(ARG(1)),ARG(2))
err:
parse arg msg
say '*** error' msg
exit 8
}¢--- A540769.WK.REXX.O13(JV0) cre= mod= ---------------------------------------
/* rexx ****************************************************************
pvsRwgrV: Verrechnung Jes Output
synopsis: pvsRwgrV ¢-T! ¢-H! ¢-?! env
synopsis: pvsRwgrV ¢-T! ¢-H! ¢-?! env
-T trace
-H, -? this help
env Umgebung TEST (auf RZ1) oder PROD (auf RZ2)
Funktion:
schreibe alle nicht verrechneten JesOut Records
vor dem aktuellen Datum aus dem JesOut Logfile
auf das File DD VERR für DWS
append ans Log einen Logeintrag (fun=verr),
der besagt, bis wohin jetzt verrechet wurde
Anfangs Monat werden die Einträge der VorMonate in ein
Monatsfile geschoben
Files
DD LOG: logfile, wird gelesen und ein Logeintrag wird append
Achtung: muss mit disp=mod alloziert sein,
damit append funktioniert
richtige sms und dcb Parameter mitgeben,
(für alloc, wenn nicht vorhanden)
DD VERR: das output File
DD SYSPRT: Meldungen und Trace
Inhalt dd VERR: Ein Record pro output File
(damit Stapel richtig aus Seiten berechnet werden können)
Record Layout (total länge 53 Byte)
pos len typ Inhalt
1 8 gguuXXXX gg=Gebietspointer
uu=UmsetzungsCode
XXXX=Filler (zurzeit = 'XXXX')
9 8 yyyymmdd LieferDatum
17 6 HHMMSS LieferZeit
23 8 char Monitor = JESPROD oder JESTEST
31 1 char Express (zurzeit immer space)
32 4 bin Anzahl Seiten (binär)
36 4 char Printer immer '2240'
40 8 yyyymmdd PrintDatum
48 6 HHMMSS PrintZeit
************************************************************************
History
24.06.2005 W. Keller, neu
***********************************************************************/
parse arg args
say 'pvsRwgrV begin' args
/* analyse arguments */
m.trace = 0
env = ''
do wx=1 to words(args)
w = translate(word(args, wx))
if w='?' | w ='-?' | w= '-H' then
return help()
else if w = '-T' then
m.trace = 1
else if env == '' then
env = w
else
call err 'env bereits gesetzt:' w 'in args' args
end
dat = date('s')
tim = time('n')
say 'pvsRwgrV begin env' env 'run' dat tim 'trace' m.trace
if env ^== '' then /* normal work */
call logWork log, verr, dat, tim, env
else if sysvar(sysenv) ^== 'FORE' then
call errHelp 'env not specified'
else do /* test: allocate files */
env = 'TEST'
call adrTso "alloc dd(log) mod dsn(lst.log)"
call adrTso "alloc shr dd(verr) dsn(wk.out(jv))"
call logWork log, verr, dat, tim, env
call adrTso 'free dd(log verr)'
end
say 'pvsRwgrV end' env dat tim
exit
logWork: procedure expose m.
parse arg ddLog, ddOut, ruDa, ruTi, argEnv
/*----------------------------------------------------------------------
schreibe alle nicht verrechneten Records
vor dem Datum ruDa
append ein fun=verr Record ans log, der nachweist,
bis wohin wir verrechnet haben
Parameter
ddLog: dd des Logfile, muss disp=mod alloziert sein,
damit append funktioniert
ddOut: dd für das output Verrechnungs file
ruDa, ruTi: run = liefer Datum und Zeit
argEnv: Zile Umgebung (TEST oder PROD)
----------------------------------------------------------------------*/
mon = 'JES'argEnv
ruDaTi = ruDa || left(ruTi,2) || substr(ruTi,4,2) || right(ruTi,2)
/* search last logged entry */
sRes = logSearch(ddLog)
parse var sRes sDa sTi vNr aNr eNr .
say 'search da ti' sDa sTi
say 'search first' 1 m.log.1
say 'search verr ' vNr m.log.vNr
say 'search aufse' aNr m.log.aNr
say 'search end ' eNr m.log.eNr
/* position log */
call readDDBegin ddLog /* at beginning */
rNr = 0
laDaTi = subWord(laLo, 1, 2)
if sRes ^== '' then do
if aNr > 0 then do
call adrTso 'execio' (aNr-1) 'diskr' ddLog '(skip stem ri.)'
if ^ readNext(ddLog, ri., 1) then
call err 'rePositioning' (aNr-1) 'on dd' ddLog 'failed'
if ri.1 ^== m.log.aNr then
call err 'restart err rec' aNr ri.1 '^==' m.log.aNr
rNr = rNr + aNr
end
end
call writeDDBegin ddOut
ro = 0
before = 1
roPages = 0
roJobs = 0
laSkip = 'kein verrechneter Record gefunden'
laVerr = ''
/* read the file */
do while before & readNext(ddLog, ri.)
do r=1 to ri.0
rNr = rNr + 1
if subWord(ri.r ,1, 2) <<= laDaTi then do
laSkip = rNr left(ri.r, 120)
iterate /* already logged, skip */
end
if word(ri.r, 1) >>= ruDa then do
before = 0 /* already at ruDa: finish */
leave
end
tim = word(ri.r, 2)
/* prepare output record */
da = right(ruDaTi, 22) ,
|| left(mon, 9),
|| d2c(0, 4),
|| '2240',
|| left(word(ri.r, 1), 8),
|| left(tim, 2) || substr(tim, 4, 2) || right(tim, 2)
/* analyse log entry */
call scanBegin s, 's', substr(ri.r, wordIndex(ri.r, 3))
fun = 'JESOUT'
pages = 0
do while scanKeyValue(s)
select;
when m.s.key = 'FUN' then
fun = m.s.val
when m.s.key = 'VERRECHNUNG' then
da = overlay(m.s.val, da, 1, 8, 'X')
when m.s.key = 'PAGES' then
pages = m.s.val
otherwise nop
end
end
if ^ m.s.eof then
call scanErr s, 'key=value expected'
call scanEnd s, 's', ri.r
/* write verrechnung */
if fun == 'JESOUT' then do
if laSkip ^== '' then do
say 'letzter übersprungener rec' laSkip
say 'erster verrechneter rec' rNr left(ri.r,120)
laSkip = ''
end
da = overlay(d2c(pages, 4), da, 32, 4)
roPages = roPages + pages
call trc length(da)':' da
ro = ro + 1
ro.ro = da
laVerr = rNr ri.r
end
else
call trc 'ignoring fu' fu ri.r
end
roJobs = roJobs + ro
ro.0 = ro
call writeNext ddOut, ro.
ro = 0
if ^ before then
leave
end /* finish */
call readDDEnd ddLog
call writeDDEnd ddOut
if laVerr == '' then do
say 'no output written'
end
else do
say 'letzter verrechneter rec' laVerr
say 'written' roPages 'pages from' roJobs 'jobs' ,
'after' laDaTi 'before' ruDa
/* append log Eintrag,
bis wohin verrechnet */
roLa.0 = 1
roLa.1 = ruDa ruTi 'fun=VERR to=' || quote(subWord(laVerr,2,2))
m.log.log = roLa.1
say 'log append' roLa.1
call writeDDBegin ddLog
call writeNext ddLog, roLa.
call writeDDEnd ddLog
say 'mo first ' left(m.log.1, 50)
say 'mo laVerr' left(laVerr, 50)
if left(word(m.log.1, 1), 6) < left(word(laVerr, 2), 6) then
call logMonth ddLog, left(word(laVerr, 2), 6)
end
return
endProcedure logWork
logSearchTest: procedure expose m. d.
parse arg ddIn
/*----------------------------------------------------------------------
test logSearch several times
with different read chunks
----------------------------------------------------------------------*/
ro = logSearch(ddIn, '*')
say 'ro' ro
do i=0 to 50
o.i = d.i
end
do cnt=1 by 1 to 20
drop d.
rn = logSearch(ddIn, cnt)
if rn ^== ro then
call err 'check cnt' cnt 'rn' rn '^== ro' ro
do i=0 to 50
if d.i ^== o.i then
call err 'check cnt' cnt 'd.'i d.i '^== o.'i o.i
end
call readDDBegin ddIN
rr = word(rn, 3)
if rr > 0 then do
call adrTso 'execio' (rr-1) 'diskr' ddIn '(skip stem q.)'
call readNext ddIn, q., 1
if q.1 ^== substr(rn, wordIndex(rn, 4)) then
call err 'restart err rec' rr q.1 '^==' rn
end
call readDDEnd ddIN
end
return ro
endProcedure logSearchTest
logSearch: procedure expose d. m.
/*----------------------------------------------------------------------
search last verrechnungs log entry and find previous day in file
returns '' if no entry found
date time recNr rec: last logged date and time
recNr of a record before this
rec = contents of rec recNr
----------------------------------------------------------------------*/
parse arg ddIn, cnt
verNr = 0
d=0
dayMx = 33
lDaTi = ''
call readDDBegin ddIn
rNr = 0
/* read file */
do while readNext(ddIn, ri., cnt)
riMax = ri.0
if rNr = 0 then do
if riMax > 0 then
m.log.1 = ri.1
end
do r=1 to riMax
rNr = rNr + 1
cDaTi = subWord(ri.r, 1, 2)
if cDaTi < lDaTi then
call err 'rec' rNr 'dateTime' cDaTi ' < previous' lDaTi
if word(cDaTi, 1) ^== word(lDaTi, 1) then do
/* date changed */
d = (d // dayMx) + 1 /* store previous record */
rp = r-1
if rp > 0 then
d.d = (rNr-1) ri.rp
else
d.d= (rNr-1) recLast
call trc 'day change d.'d left(d.d, 60)
end
lDaTi = cDaTi
w3 = translate(word(ri.r, 3))
if w3 == 'FUN=VERR' then do /* keep this record */
verNr = rNr
verRec = ri.r
call trc 'Verrechnung' verNr rNr
end
end
recLast = ri.riMax
end
d.0 = rNr recLast
m.log.rNr = recLast
call readDDEnd ddIn
if verNr < 1 then do
say 'kein VerrechnungsRec in' rNr 'records'
return ''
end
/* analyse verRec */
m.log.verNr = verRec
call scanBegin sv, 's', substr(verRec, wordIndex(verRec, 3))
do while scanKeyValue(sv)
select
when m.sv.key = 'FUN' then
if m.sv.val ^== 'VERR' then
call scanErrBack sv, 'FUN ^== VERR'
when m.sv.key = 'TO' then
verTo = m.sv.val
otherwise call scanErr sv, 'bad key' m.sv.key
end
end
if ^m.sv.eof then
call scanErr sv, 'key=value expected'
call scanEnd sv
verTo = subword(verTo, 1, 2)
say 'letzte Verrechnung um' verTo ', Rec' verNr':' verRec
f = 0
do d=1 to dayMx
if symbol('d.d') ^== 'VAR' then nop
else if subWord(d.d, 2, 2) >> verTo then nop
else if f = 0 then
f = d
else if subWord(d.d, 2, 2) >> subWord(d.f, 2, 2) then
f = d
end
call trc 'Aufsetz Rec' f':' left(d.f, 60)
if f < 1 then
call err 'last verrechnet not found for' verNr':' verRec
aNr = word(d.f, 1)
m.log.aNr = substr(d.f, wordIndex(d.f, 2))
say 'Aufsetz Rec' aNr left(m.log.aNr, 60)
return verTo verNr aNr rNr
endProcedure logSearch
logMonth: procedure expose m.
parse arg ddLog, curMon
say 'logMonth' ddLog curMon
if 0 ^== listDsi(ddLog 'file') then
call err 'listDsi('ddLog 'file)' sysmsglvl2
logName = sysDsName
say ddLog 'allocated to' logName
lMo = ''
lFi = ''
cIn = 0
call readDDBegin log
do while readNext(log, ri., 3)
rMax = ri.0
cIn = cIn + rMax
r = 0
do while r < rMax
r = r + 1
cMo = left(word(ri.r, 1), 6)
if cMo == lMo then
iterate
cFi = cMo
lMo = cMo
if cFi >>= curMon then
cFi = 'save'
if cFi == lFi then
iterate
if lFi ^== '' then do
ri.0 = r-1
cOut = cOut + ri.0
call writeNext ddMon, ri.
call writeDDEnd ddMon
call adrTso 'free dd(ddMon)'
say cOut 'records written to' logName".M"lFI
t = 0
do r=r to rMax
t = t+1
ri.t = ri.r
end
rMax = t
end
lFi = cFi
cOut = 0
call adrTso 'alloc dd(ddMon) new catalog',
"dsn('"logName".M"cFI"') like('"logName"')",
'mgmtclas(S005Y000)'
call writeDDBegin ddMon
end
if lFi ^== '' then do
ri.0 = rMax
cOut = cOut + rMax
call writeNext ddMon, ri.
end
end
if lFi ^== 'save' then
call err 'last month lFi =' lFi '^== save'
call writeDDEnd ddMon
call readDDEnd ddLog
say cOut 'records written to' logName".M"lFI
say cIn 'records read from' ddLog logName
cIn = 0
call readDDBegin ddMon
call adrTso "alloc dd(logOld) old dsn('"logName"')"
call writeDDBegin logOld
do while readNext(ddMon, ri.)
cIn = cIn + ri.0
call writeNext logOld, ri.
end
call readDDEnd ddMon
call writeDDEnd logOld
say cIn 'records read from' logName".M"lFI
say cIn 'records written to' logName
call adrTso 'free dd(logOld)'
call adrTso 'free dd(ddMon) delete'
return
endProcedure logMonth
trc: procedure expose m.
parse arg msg
if m.trace = 1 then
say 'trc: ' msg
return
endProcedure trc
err:
parse arg ggMsg
call errA ggMsg
exit 12;
/* copy scan begin ****************************************************/
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034uUnd hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = ('ers' || 'tn' || '''s')"
m.q.4 = " drei;+HHhier123sdfER?? '''' "
m.q.0 = 4
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTest
scanBegin: procedure expose m.
parse arg m, pTyp, pOpt
m.m.typ = pTyp
if pTyp = 'm' then do
m.m.lines = pOpt
end
else if pTyp = 's' then do
m.m.lines = m
m.m.0 = 1
m.m.1 = pOpt
end
else if pTyp = 'dd' then do
m.m.lines = m
m.m.0 = 0
m.m.dd = pOpt
call readDDBegin m.m.dd
end
else
call err 'bad scanBegin typ' pTyp
m.m.lx = 1
m.m.baseLx = 0
m.m.bx = 1
m.m.cx = 1
m.m.curLi = m.m.lines'.1'
m.m.eof = 0
if pTyp = 'dd' then
call scanNextLine m
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
if m.m.typ = 'dd' then
call readDDEnd m.m.dd
return
endProcedure scanEnd
scanNextLine: procedure expose m.
parse arg m
l = m.m.lines
m.m.lx = m.m.lx + 1
if m.m.lx > m.l.0 then do
if m.m.typ <> 'dd' then do
m.m.eof = 1
return 0
end
m.m.baseLx = m.m.baseLx + m.m.0
if ^ readNext(m.m.dd, 'm.'m'.') then do
m.m.eof = 1
return 0
end
m.m.lx = 1
end
m.m.curLi = l'.'m.m.lx
m.m.cx = 1
m.m.bx = 1
return 1
endProcedure scanNextLine
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanChar: procedure expose m.
parse arg m, len
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then
leave
if ^ scanNextLine(m) then do
m.m.tok = ''
return 0
end
end
if length(m.l) >= vx + len then
m.m.tok = substr(m.l, vx, len)
else
m.m.tok = substr(m.l, vx)
m.m.bx = vx
m.m.cx = vx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
m.m.tok = ''
m.m.val = ''
if qu = '' then
qu = "'"
if ^ scanChar(m, 1) then
return 0
qx = m.m.cx
m.m.cx = m.m.bx
if m.m.tok <> qu then
return 0
l = m.m.curLi
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
m.m.tok = ''
if ^ scanChar(m, 1) then
return 0
m.m.cx = m.m.bx
if alpha = '' then do
alpha ,
= '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ'
if pos(m.m.tok, alpha) <= 10 then
return 0
end
l = m.m.curLi
vx = verify(m.l, alpha, 'n', m.m.bx)
if vx = m.m.bx then
return 0
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
if ^ scanName(m, '0123456789') then
return 0
else if datatype(scanRight(m, 1), 'A') then
call scanErrBack m, 'illegal number'
return 1
endProcedure scanNum
scanKeyValue: procedure expose m.
parse arg m
if ^scanName(m) then
return 0
m.m.key = translate(m.m.tok)
if ^scanChar(m, 1) | m.m.tok <> '=' then
call scanErr m, 'assignment operator (=) expected'
if scanName(m) then
m.m.val = translate(m.m.tok)
else if scanNum(m) then do
m.m.val = m.m.tok
end
else if scanString(m) then
nop
else
call scanErr m, "value (name or string '...') expected"
return 1
endProcedure scanKeyValue
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx substr(m.l, m.m.cx)
whe = 'typ' m.m.typ
if m.m.typ = 'dd' then
whe = whe m.m.dd (m.m.baseLx + m.m.lx)
say whe 'line' l m.l
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* copy scan end ****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
readBegin, readNext*, readEnd read dsn in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(readDsn) shr dsn('ggdsn')'
call adrTso 'execio * diskr readDsn (stem' ggSt' finis)'
call adrTso 'free dd(readDsn)'
return
endSubroutine readDsn
readDDBegin: procedure
return /* end readDDBegin */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr dsn('dsn')'
return /* end readBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
readEnd: procedure
parse arg dd
call readDDEnd dd
call adrTso 'free dd('dd')'
return /* end readEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(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.O13(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.O13(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.O13(LOOP) cre=2006-04-04 mod=2006-04-04-09.41.09 F540769 ---
DO I = 1 TO 200 00010000
SAY 'LINE' I 00020000
END 00030000
}¢--- A540769.WK.REXX.O13(M) cre=2013-01-23 mod=2013-09-23-12.00.04 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>.** 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 *********************************************************/
}¢--- A540769.WK.REXX.O13(MAP) cre=2009-09-01 mod=2011-01-12-12.00.29 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 = 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 *******************************************************/
}¢--- A540769.WK.REXX.O13(MAPEXP) cre=2009-09-03 mod=2013-05-27-13.27.42 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.O13(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.O13(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.O13(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.O13(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.O13(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.O13(MARECCFG) cre=2011-04-08 mod=2011-04-08-09.15.53 A540769 ---
/* rexx */
return 'A540769.WK.REXX'
}¢--- A540769.WK.REXX.O13(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.O13(MARECJOB) cre=2009-09-03 mod=2011-04-21-21.10.09 A540769 ---
/* rexx ****************************************************************
maRecJob massRecovery Job Generation
* history **************************************************************
13.04.11 Umstellung auf marec 20, split in cim und marec phase
*/ /*** end of help ****************************************************
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
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 dbConn g, envGet(dbSub)
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 sqlDisconnect
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
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/
//YMARCPTB JOB (CP00,KE50),
// 'marec CreLoa',MSGCLASS=T,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
$j*MAIN CLASS=LOG,SYSTEM=$sys
$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=T,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 'YMRDELE1', $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 'YMRDELE2'
$#=
$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
say prts '-->' li 'pas' pas
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.O13(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.O13(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.O13(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.O13(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.O13(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 ********************************************************/
}¢--- A540769.WK.REXX.O13(MATCH) cre=2009-09-03 mod=2009-10-07-22.01.02 A540769 ---
/* 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 *****************************************************/
}¢--- A540769.WK.REXX.O13(MEM) cre= mod= ---------------------------------------
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
inAll: procedure expose m.
parse arg m, pTyp, pOpt, out
call inBegin m, pTyp, pOpt
if out == '' then do
call inBlock m, '*'
if inBlock(m) | m ^== m.in.m.block then
call err 'not eof after inBlock *'
end
else do
rx = 0
do while inBlock(m)
bl = m.in.m.block
do ix=1 to m.bl.0
rx = rx + 1
m.out.rx = m.bl.ix
end
end
m.out.0 = rx
end
call inEnd m
return
endSubroutine inAll
inBegin: procedure expose m.
parse arg m, pTyp, pOpt
m.in.m.type = pTyp
m.in.m.rNo = 0
m.in.m.bNo = 0
m.in.m.0 = 0
m.in.m.eof = 0
m.in.m.block = m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = string
m.in.m.type = 'b'
end
else if pTyp == 'b' then do
m.in.m.block = pOpt
end
else if pTyp == 'd' then do
m.in.m.dd = pOpt
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.in.m.type = 'd'
m.in.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.in.m.dd = 'in'm
else
m.in.m.dd = m
inf = 'dd' m.in.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.in.m.dd') shr dsn('pOpt')'
end
else
call err 'inBegin bad type' pTyp
m.in.m.info = pTyp'-'m.in.m.type inf
return
endProcedure in
inLine: procedure expose m.
parse arg m
r = m.in.m.rNo + 1
if r > m.in.m.0 then do
if ^ inBlock(m) then
return 0
r = 1
end
m.in.m.line = m.in.m.block'.'r
m.in.m.rNo = r
return 1
endProcedure inLine
inBlock: procedure expose m.
parse arg m, cnt
if m.in.m.type == 'd' then do
m.in.m.bNo = m.in.m.bNo + m.in.m.0
m.in.m.eof = ^ readNext m.in.m.dd, m'.'m.in.m'.', cnt
return ^ m.in.m.eof
end
else if m.in.m.type == 'b' then do
if m.in.m.bNo > 0 then do
m.eof = 1
return 0
end
m.in.m.bNo = 1
b = m.in.m.block
m.in.m.0 = m.b.0
return 1
end
else
call err 'inBlock bad m.in.'m'.type' m.in.m.type
endProcedure inBlock
inLineInfo: procedure expose m.
parse arg m, lx
if lx = '' then
lx = m.in.m.rNo
cl = m.in.m.block'.'lx
return 'record' (lx + m.in.m.bNo) ,
'(m.'cl 'type' strip(m.in.m.info)'):' m.cl
endProcedure inLineInfo
inEnd: procedure expose m.
parse arg m
if m.in.m.type == 'd' then do
call readDDEnd m.in.m.dd
end
else if m.in.m.type == 'f' then do
call readDDEnd m.in.m.dd
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
/* copy mem end *****************************************************/
}¢--- A540769.WK.REXX.O13(MON#DISP) cre=2011-04-13 mod=2011-04-13-22.40.59 A540769 ---
/* REXX */ 00010000
00020000
/* ----------------------------------------------------------------- */ 00030000
/* 00040000
Name : MON#DISP 00050000
Autor : Heinz Bühler, 12.10.2009 00060000
Funktion : - DISPLAY DATABASE Command für alle Partitionen 00070000
- entweder von allen Jobs, oder von einem Job 00080000
- diese Prozedur braucht eine DB2 Verbindung 00090000
00100000
Aufruf : kein direkter Aufruf, nur im Zusammenhang mit MAREC 00110000
Aufruf aus dem MON Member der Kontroll-Library mit 00120000
Option -d ¢ jobnummer ! 00130000
MAREC -s --> MARECMON --> MON#DISP 00140000
00150000
Change Activity : 00160000
V1R0 : 11.11.2009/HBD 00170000
- Ursprungsversion 00180000
00190000
*/ 00200000
/* ----------------------------------------------------------------- */ 00210000
00220000
address tso; 00230000
pgmvers = 'V1R0' 00240000
/* */ 00250000
/* übergebenen Variablen-String ausführen */ 00260000
parse arg ar.arg 00270000
interpret ar.arg 00280000
00290000
debug=1; 00300000
debug=0; 00310000
if ar.dbug then debug=1 00320000
00330000
if debug then say ">> MON#DISP "pgmvers 00340000
if debug then say ".. LIB : "lib 00350000
if debug then say ".. JOBLIB : "joblib 00360000
if debug then say ".. MONLIB : "monlib 00370000
if debug then say ".. ARGS : "args 00380000
if debug then say ".. DBSUB : "dbsub 00390000
if debug then say ".. SHOWMBR: "showmbr 00400000
if debug then say ".. ar.arg : "ar.arg 00410000
if debug then say ".. ar.help: "ar.help 00420000
if debug then say ".. ar.dbug: "ar.dbug 00430000
00440000
/* wurde eine Jobnummer mit übergeben? */ 00450000
v.jobnum='N/A' 00460000
parse upper var ar.args v1 '-D' v2 . 00470000
if debug then say '.. v1='v1' v2='v2 00480000
if datatype(v2)='NUM' then v.jobnum=v2 00490000
if debug then say '.. v.jobnum='v.jobnum 00500000
00510000
v.mvsid = mvsvar(sysname) /* S11 ... */ 00520000
v.rzid = sysvar(sysnode) /* RZ1 ... */ 00530000
v.pid = sysvar(sysuid) /* User ID */ 00540000
v.ssid = dbsub; /* DB2 SSID */ 00550000
v.fl_testmode='0'; /* flag für Testmodus (DBOF im RZ1) */ 00560000
msg_status = MSG(OFF) /* turn off msg prompt **/ 00570000
address tso "FREE F(OUTDN) " 00580000
msg_status = MSG(ON ) /* turn on msg prompt **/ 00590000
00600000
/* DB2 REXX Support anbinden */ 00610000
call init_dsnrexx ; 00620000
00630000
/* Connect zu DB2, falls DBOF im RZ1 wird zu DBAF connectet */ 00640000
if v.rzid='RZ1' & v.ssid='DBOF' then v.fl_testmode='1' 00650000
if v.fl_testmode='1' then v.ssid='DBAF' 00660000
/* call caf_connect v.ssid; */ 00670000
00680000
00690000
/* Member RECST aus der Joblib einlesen (Recovery Startzeitpunkt) */ 00700000
drop inp. 00710000
call read_input joblib'(RECST)' 00720000
00730000
/* DISPLAY DATABASE commands aufbereiten und ausführen */ 00740000
call prepare_db2_commands; 00750000
call issue_db2_commands; 00760000
00770000
00780000
/* Tablespace Status Report erstellen */ 00790000
call prepare_disdb_report 00800000
00810000
00820000
/* aufbereiteten Report in die Monlib schreiben (Member: ##REPORT) */ 00830000
00840002
call write_member monlib'('showmbr')' 00850000
/* aufbereiteten Report in die Monlib schreiben (Member: D#hhmmss) */ 00860000
mname = substr(time(normal),1,2) || substr(time(normal),4,2) 00870000
mname = mname || substr(time(normal),7,2) 00880000
call write_member monlib'(D#' || mname || ')' 00890000
00900000
/* Anzeige wird normalerweise durch MAREC gemacht */ 00910000
/* call show_member monlib'(##REPORT)' */ 00920000
00930000
00940000
/* DB2 Verbindung beenden */ 00950000
call caf_disconnect; 00960000
/* DB2 REXX Support entfernen */ 00970000
call exit_dsnrexx ; 00980000
00990000
if debug then say ">> MON#DISP "pgmvers" END" 01000000
return; 01010000
01020000
/*===================================================================*/ 01030000
01040000
01050000
01060000
01070000
/*-------------------------------------------------------------*/ 01080000
/* Prepare Summary Report; in stem outp. */ 01090000
/*-------------------------------------------------------------*/ 01100000
prepare_disdb_report: /*$proc$*/ 01110000
procedure expose v. debug inp. outp. dsnout. joblib 01120000
if debug then say 'proc: prepare_disdb_report' 01130000
01140000
i=1;o=1; 01150000
drop outp. 01160000
outp.o = ' '; o=o+1; 01170000
t = 'MASS RECOVERY TABLESPACE STATUS REPORT'; 01180000
if datatype(v.jobnum)='NUM' then do 01190000
t = t || ' for Job Nr. 'v.jobnum 01200000
end 01210000
t = t || ', ' || date(Normal)'; 'time(Normal) ; 01220000
outp.o = t ; o=o+1; 01230000
t = '--------------------------------------'; 01240000
outp.o = t ; o=o+1; 01250000
outp.o = ' '; o=o+1; 01260000
t = "Joblib='"joblib"'"; 01270000
outp.o = t ; o=o+1; 01280000
outp.o = ' '; o=o+1; 01290000
t = 'Tablespace Typ Status '; 01300000
outp.o = t ; o=o+1; 01310000
t = '--------------------------------------------------------------';01320000
outp.o = t ; o=o+1; 01330000
outp.o = ' '; o=o+1; 01340000
01350000
do i = 1 to dsnout.0 01360000
parse var dsnout.i v1 v2 v3 v4 v5 v6 v7 01370000
/* 01380000
say i': 'dsnout.i 01390000
say 'v1='v1 01400000
say 'v2='v2 01410000
say 'v3='v3 01420000
say 'v4='v4 01430000
say 'v5='v5 01440000
*/ 01450000
if v1 ='DSNT362I' then do 01460000
ddb=strip(v5) 01470000
jwrite=0 01480000
end 01490000
else do 01500000
if v1 = '--------' then do 01510000
jwrite=1 01520000
end 01530000
else do 01540000
if v1 = '*******' then do 01550000
jwrite=0 01560000
end 01570000
else do 01580000
if jwrite = 1 then do 01590000
if strip(v1)='DSNT302I' then do 01600000
x = ddb || ':' 01610000
x = x || copies(' ',32-length(x)) 01620000
x = x || "Invalid TS name (Testmode)" 01630000
outp.o = x; o=o+1 01640000
jwrite=0 01650000
end 01660000
else do 01670000
x = ddb || '.' || strip(v1) 01680000
rv = datatype(v3) 01690000
if rv = 'NUM' then do /* d.h. partition */ 01700000
x = x || '.' || strip(v3) 01710000
x = x || copies(' ',32-length(x)) 01720000
x = x || strip(v2) || ' ' 01730000
x = x || strip(v4) 01740000
end 01750000
else do 01760000
x = x || copies(' ',32-length(x)) 01770000
x = x || strip(v2) || ' ' 01780000
x = x || v3 01790000
end 01800000
outp.o = x; o=o+1 01810000
end 01820000
end 01830000
end 01840000
end 01850000
end 01860000
end /* do */ 01870000
01880000
outp.o = ' '; o=o+1; 01890000
outp.0 = o-1 01900000
01910000
if debug then say 'end proc: prepare_disdb_report ' 01920000
return 01930000
01940000
01950000
01960000
01970000
/*-------------------------------------------------------------*/ 01980000
/* DISPLAY DATABASE Commands aufbereiten */ 01990000
/*-------------------------------------------------------------*/ 02000000
prepare_db2_commands: /*$proc$*/ 02010000
procedure expose v. debug inp. inp2. joblib dsncmd. 02020000
if debug then say 'proc: prepare_db2_commands ' 02030000
02040000
if debug then say "v.fl_testmode="v.fl_testmode 02050000
if debug then say "v.jobnum="v.jobnum 02060000
02070000
/* 02080000
Command-Format: 02090000
02100000
dsncmd.1 = "-DIS DB(FI04A1A) SPACE(A005A) LIMIT(*)"; 02110000
dsncmd.2 = "-DIS DB(FI04A1A) SPACE(A010A) PART(1) LIMIT(*)"; 02120000
dsncmd.3 = "-DIS DB(FI04A1A) SPACE(A010A) PART(7) LIMIT(*)"; 02130000
dsncmd.4 = "-DIS DB(RV01A1A) SPACE(A400A) LIMIT(*)"; 02140000
dsncmd.5 = "-DIS DB(RV01A1A) SPACE(IRV100A2) LIMIT(*)"; 02150000
02160000
*/ 02170000
02180000
j=1; drop inp2.; 02190000
do i = 1 to inp.0 02200000
parse upper var inp.i jmark ' ' jnum ' ' . 02210000
if jmark='*JOB' then do 02220000
tjn=v.jobnum 02230000
jobnr = strip(jnum) 02240000
if length(tjn)<length(jobnr) then tjn='0'tjn 02250000
if length(tjn)<length(jobnr) then tjn='0'tjn 02260000
if length(tjn)<length(jobnr) then tjn='0'tjn 02270000
if length(tjn)<length(jobnr) then tjn='0'tjn 02280000
if debug then say "jobnr="jobnr', tjn='tjn 02290000
end 02300000
else do 02310000
/* falls eine Jobnummer zur Auswahl übergeben wurde */ 02320000
if datatype(v.jobnum)='NUM' then do 02330000
if tjn=jobnr then do 02340000
inp2.j=inp.i 02350000
j=j+1 02360000
end 02370000
end 02380000
/* falls keine Jobnummer zur Auswahl übergeben wurde */ 02390000
else do 02400000
inp2.j=inp.i 02410000
j=j+1 02420000
end 02430000
end 02440000
end 02450000
inp2.0=j-1 02460000
02470000
/* array inp.2 sortieren */ 02480000
call sort_inp2; 02490000
02500000
do i = 1 to inp2.0 02510000
parse upper var inp2.i jdb ' ' jtsp ' ' jpart ' ' jwhat ' ' jts 02520000
if debug then do 02530000
if jdb = 'DA234579' then say inp2.i 02540000
end 02550000
if v.fl_testmode='1' then do 02560000
if substr(jdb,7,1) = 'P' then do 02570000
jdb = substr(jdb,1,6) || 'A' || substr(jdb,8,1) 02580000
end 02590000
end 02600000
x = "-DIS DATABASE("jdb") SPACE("jtsp") " 02610000
if jpart <> 0 then x = x || "PART("jpart") " 02620000
x = x || "LIMIT(*)" 02630000
dsncmd.i = x; 02640000
if debug then say i": "dsncmd.i 02650000
end 02660000
dsncmd.0=i-1 02670000
if debug then say "Anzahl Commands "dsncmd.0 02680000
02690000
if debug then say 'end proc: prepare_db2_commands '; 02700000
return; 02710000
02720000
02730000
02740000
/*-------------------------------------------------------------*/ 02750000
/* Call DSN to execute DB2 commands */ 02760000
/*-------------------------------------------------------------*/ 02770000
issue_db2_commands: /*$proc$*/ 02780000
procedure expose v. debug dbsub dsncmd. dsnout. 02790000
if debug then say 'proc: issue_db2_commands ' 02800000
02810000
address tso; 02820000
"newstack" 02830000
02840000
x=msg(on); 02850000
do i = 1 to dsncmd.0 02860000
queue dsncmd.i 02870000
if debug then say '.. 'i': 'dsncmd.i 02880000
end 02890000
queue "END" 02900000
x=outtrap('dsnout.') 02910000
02920000
address tso "DSN SYSTEM("v.ssid")" 02930000
db2_rc=rc 02940000
if db2_rc <> 0 then say 'DSN processor RC='db2_rc 02950000
02960000
x=outtrap("OFF") 02970000
x=msg(on ); 02980000
"delstack" 02990000
03000000
if debug then say 'end proc: issue_db2_commands' 03010000
return; 03020000
03030000
03040000
03050000
03060000
/*-------------------------------------------------------------*/ 03070000
/* Array inp2. sortieren */ 03080000
/*-------------------------------------------------------------*/ 03090000
sort_inp2: procedure expose debug inp2. /*$proc$*/ 03100000
if debug then say 'proc: sort_inp2' 03110000
03120000
sorted=0; 03130000
do while sorted=0 03140000
i1=1 03150000
i2=2 03160000
sorted=1 03170000
do while i1<inp2.0 03180000
if inp2.i2 < inp2.i1 then do 03190000
x=inp2.i1 03200000
inp2.i1 = inp2.i2 03210000
inp2.i2=x 03220000
sorted=0 03230000
end 03240000
i1=i1+1 03250000
i2=i2+1 03260000
end 03270000
end 03280000
03290000
if debug then say 'end proc: sort_inp2' 03300000
return; 03310000
03320000
03330000
/*-------------------------------------------------------------*/ 03340000
/* Read Input Member in Batch Mode */ 03350000
/*-------------------------------------------------------------*/ 03360000
read_input: procedure expose debug inp. /*$proc$*/ 03370000
if debug then say 'proc: read_input' 03380000
03390000
parse upper arg dsn 03400000
03410000
address tso; 03420000
if debug then say ".. Input Dataset='"dsn"'" ; 03430000
03440000
check_dsn = Sysdsn(''''dsn'''') 03450000
If check_dsn ^= 'OK' Then do 03460000
if debug then say dsn '.. does not exist in ' || rzid || '.' 03470000
end 03480000
else do 03490000
if debug then say ".. allocating input '"dsn"' ..." ; 03500000
"ALLOC F(INPDN) DA('"dsn"') SHR " 03510000
03520000
if debug then say ".. reading "dsn"'" ; 03530000
'EXECIO * DISKR inpdn (STEM INP. FINIS' 03540000
if debug then say ".. read "inp.0" Records from '"dsn"'" 03550000
"FREE F(INPDN) " 03560000
end 03570000
03580000
if debug then say 'end proc: read_input' 03590000
return; 03600000
03610000
03620000
/*-------------------------------------------------------------*/ 03630000
/* Write Member to MON Library */ 03640000
/*-------------------------------------------------------------*/ 03650000
write_member: /*$proc$*/ 03660000
procedure expose debug outp. /*$proc$*/ 03670000
if debug then say 'proc: write_member' 03680000
03690000
parse upper arg dsn 03700000
03710000
address tso; 03720000
if debug then say ".. Output Dataset='"dsn"'" ; 03730000
03740000
if debug then say ".. allocating output ..." ; 03750000
"ALLOC F(OUTDN) DA('"dsn"') SHR " 03760000
03770000
if debug then say ".. writing "dsn"'" ; 03780000
'EXECIO * DISKW OUTDN (STEM OUTP. FINIS' 03790000
if debug then say ".. "outp.0" Records written to '"dsn"'" 03800000
"FREE F(OUTDN) " 03810000
03820000
if debug then say 'end proc: write_member' 03830000
return; 03840000
03850000
03860000
03870000
/*-------------------------------------------------------------*/ 03880000
/* Show Member in ISPF VIEW */ 03890000
/*-------------------------------------------------------------*/ 03900000
show_member: procedure expose debug outp. /*$proc$*/ 03910000
if debug then say 'proc: show_member' 03920000
03930000
address tso; 03940000
parse upper arg dsn 03950000
03960000
if debug then say ".. allocating dataset='"dsn"'" ; 03970000
"ALLOC F(OUTDN) DA('"dsn"') SHR " 03980000
03990000
/* aufrufen des ISPF EDIT Service */ 04000000
address ISPEXEC ; 04010000
"EDIT DATASET('"dsn"')" ; 04020000
04030000
"FREE F(OUTDN) " 04040000
04050000
if debug then say 'end proc: show_member' 04060000
return; 04070000
04080000
04090000
04100000
04110000
04120000
/* pad with spaces (left Side of xstring) and shorten to */ 04130000
/* 6 Bytes, adding Dimension marker */ 04140000
/* i.e. 123.5 123.5K 123.5M 3.5G adjusted right */ 04150000
npadm: 04160000
arg xstring 04170000
if datatype(xstring) <> 'NUM' then return 'error, not numeric'; 04180000
04190000
vv_temp_num = format(xstring,12,3) 04200000
vv_dim=' '; 04210000
if vv_temp_num > 1024 then do 04220000
vv_temp_num = vv_temp_num / 1024 04230000
vv_dim='K'; 04240000
end 04250000
if vv_temp_num > 1024 then do 04260000
vv_temp_num = vv_temp_num / 1024 04270000
vv_dim='M'; 04280000
end 04290000
if vv_temp_num > 1024 then do 04300000
vv_temp_num = vv_temp_num / 1024 04310000
vv_dim='G'; 04320000
end 04330000
if vv_temp_num > 1024 then do 04340000
vv_temp_num = vv_temp_num / 1024 04350000
vv_dim='T'; 04360000
end 04370000
04380000
xstring = format(vv_temp_num,4,1) || vv_dim 04390000
if length(xstring) < 7 then do 04400000
xstring = copies(' ',(7-length(xstring))) || xstring 04410000
end 04420000
return xstring; 04430000
04440000
04450000
/* pad with spaces (left Side of xstring) */ 04460000
npad: 04470000
arg xstring, xlen 04480000
if length(xstring) > xlen then do 04490000
xstring = right(xstring,xlen) 04500000
end 04510000
if length(xstring) < xlen then do 04520000
xstring = copies(' ',(xlen-length(xstring))) || xstring 04530000
end 04540000
return xstring; 04550000
04560000
04570000
/* pad with spaces (right Side of xstring) */ 04580000
xpad: 04590000
arg xstring, xlen 04600000
if length(xstring) > xlen then do 04610000
xstring = left(xstring,xlen) 04620000
end 04630000
if length(xstring) < xlen then do 04640000
xstring = xstring || copies(' ',(xlen-length(xstring))) 04650000
end 04660000
return xstring; 04670000
04680000
04690000
/*-------------------------------------------------------------------*/ 04700000
/* Differenz in Tagen zwischen Argument und heutigem Datum */ 04710000
/*-------------------------------------------------------------------*/ 04720000
calc_date_diff: 04730000
if debug then say 'proc: calc_date_diff' 04740000
04750000
parse arg backup_date 04760000
04770000
/* Prepare the SQL Statement, assign a Statement Name */ 04780000
/* backup_date Format: '2009-11-01' */ 04790000
04800000
sq1="select current date-DATE('"backup_date"')", 04810000
"from sysibm.sysdummy1" 04820000
ADDRESS DSNREXX 04830000
'EXECSQL DECLARE C1 CURSOR FOR S1' 04840000
if sqlcode <> 0 then call rep_sqlca "DECLARE C1" 04850000
'EXECSQL PREPARE S1 INTO :OUTSQLDA FROM :SQ1' 04860000
if sqlcode <> 0 then call rep_sqlca "PREPARE S1" 04870000
'EXECSQL OPEN C1' 04880000
if sqlcode <> 0 then call rep_sqlca "OPEN C1" 04890000
'EXECSQL FETCH C1 INTO :date_diff' 04900000
if (sqlcode <> 0 & sqlcode <> 100) then , 04910000
call rep_sqlca "FETCH C1" 04920000
'EXECSQL CLOSE C1' 04930000
if sqlcode <> 0 then call rep_sqlca "CLOSE C1" 04940000
ADDRESS tso 04950000
if debug then say '.. date_diff: 'date_diff 04960000
04970000
return date_diff; 04980000
04990000
05000000
/*-------------------------------------------------------------------*/ 05010000
/* DB2 COMMIT */ 05020000
/*-------------------------------------------------------------------*/ 05030000
db2_commit: 05040000
if debug then say 'proc: db2_commit' 05050000
ADDRESS DSNREXX "EXECSQL COMMIT" 05060000
if sqlcode <> 0 then call rep_sqlca "COMMIT" 05070000
return; 05080000
05090000
05100000
05110000
/*-------------------------------------------------------------------*/ 05120000
/* CAF CONNECT zu DB2 */ 05130000
/*-------------------------------------------------------------------*/ 05140000
caf_connect: 05150000
if debug then say 'proc: caf_connect' 05160000
05170000
parse upper arg connssid 05180000
05190000
if debug then say ' CONNSSID: 'connssid 05200000
/* SQL Connect to the desired DB2 Subsystem or Sharing Group */ 05210000
ADDRESS DSNREXX "CONNECT "connssid 05220000
if sqlcode <> 0 then do 05230000
say ' ' 05240000
say '.. cannot connect to DB2 system 'connssid 05250000
say ' ' 05260000
call rep_sqlca "CONNECT" 05270000
return_flag = 'Y'; 05280000
return; 05290000
end 05300000
05310000
return; 05320000
05330000
05340000
/* ----------------------------------------------------------------- */ 05350000
/* Disconnect from DB2 */ 05360000
/* ----------------------------------------------------------------- */ 05370000
caf_disconnect: 05380000
if debug then say 'proc: caf_disconnect' 05390000
/* SQL DISCONNECT */ 05400000
ADDRESS DSNREXX "DISCONNECT" 05410000
if sqlcode <> 0 then call rep_sqlca 'DISCONNECT' 05420000
return; 05430000
05440000
05450000
05460000
05470000
/*-------------------------------------------------------------------*/ 05480000
/* DB2 REXX Extensions initialisieren (DSNREXX) */ 05490000
/*-------------------------------------------------------------------*/ 05500000
init_dsnrexx: 05510000
if debug then say 'proc: init_dsnrexx' 05520000
if debug then say ' CONNSSID: 'connssid 05530000
05540000
/* check if DSNREXX functions are available */ 05550000
ADDRESS TSO 'SUBCOM DSNREXX'; 05560000
05570000
/* if not, then add DSNREXX functions to command table */ 05580000
IF RC=1 THEN S_RC = RXSUBCOM('ADD','DSNREXX','DSNREXX') 05590000
return; 05600000
05610000
05620000
05630000
/*-------------------------------------------------------------------*/ 05640000
/* DB2 REXX Extensions terminieren (DSNREXX) */ 05650000
/*-------------------------------------------------------------------*/ 05660000
exit_dsnrexx: 05670000
if debug then say 'proc: exit_dsnrexx' 05680000
05690000
/* Remove the DSNREXX Functionality from command table */ 05700000
S_RC = RXSUBCOM('DELETE','DSNREXX','DSNREXX') 05710000
return; 05720000
05730000
05740000
05750000
/* ----------------------------------------------------------------- */ 05760000
/* Report SQLCA routine */ 05770000
/* - argument: func, is a text string that shold be used to identify */ 05780000
/* the location or function within the program */ 05790000
/* - return value: none */ 05800000
/* ----------------------------------------------------------------- */ 05810000
rep_sqlca: 05820000
arg func 05830000
say '-----------------------------------' 05840000
say 'Funktion= 'func 05850000
say 'SQLCODE = 'sqlcode 05860000
say 'SQLERRM = 'sqlerrmc 05870000
say 'SQLERRP = 'sqlerrp 05880000
say 'SQLERRD = 'sqlerrd.1',' || sqlerrd.2',', 05890000
|| sqlerrd.3',' || sqlerrd.4',', 05900000
|| sqlerrd.5',' || sqlerrd.6',' 05910000
say 'SQLWARN = 'sqlwarn.0',' || sqlwarn.1',', 05920000
|| sqlwarn.2',' || sqlwarn.3',', 05930000
|| sqlwarn.4',' || sqlwarn.5',', 05940000
|| sqlwarn.6',' || sqlwarn.7',', 05950000
|| sqlwarn.8',' || sqlwarn.9',', 05960000
|| sqlwarn.10 05970000
say 'SQLSTATE= 'sqlstate 05980000
exit; 05990000
return; 06000000
06010000
}¢--- A540769.WK.REXX.O13(MOUT) cre=2012-03-07 mod=2012-03-07-12.26.26 A540769 ---
/* copy out begin ******************************************************
out interface with say and stems
***********************************************************************/
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
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
old = m.out.dst
m.out.dst = d
return old
endProcedure outPush
/* 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.O13(NAK) cre=2010-01-20 mod=2010-02-09-13.47.28 A540769 ---
/* rexx ****************************************************************
nak what fun list
fun
a allocate libraries
u create unloadLimit0 and info alt neu
i create rebind and free
l create unload load
c copy alt und transform neu lctl, listdef etc.
k copy alt lctl, listdef etc.
r check packages and create remaining rebinds
.2 list: s = show flags, = = ignore packages as bad as befo
d check unload Datasets
drop
***********************************************************************/
parse upper arg what fun list
/* fix for partial db: select ts and tb */
m.wb = 1
m.wbTs = "'A142A'," ,
"'A163A'," ,
"'A165A'," ,
"'A166A'," ,
"'A169A'," ,
"'A170A'," ,
"'A172A'," ,
"'A173A'," ,
"'A703A'," ,
"'A704A'," ,
"'A705A'," ,
"'A706A'," ,
"'A707A'," ,
"'A708A'," ,
"'A992A'," ,
"'A999A'"
m.wbTb = "'TWB142A1',",
"'TWB163A1',",
"'TWB165A1',",
"'TWB166A1',",
"'TWB169A1',",
"'TWB170A1',",
"'TWB172A1',",
"'TWB173A1',",
"'TWB703A1',",
"'TWB704A1',",
"'TWB705A1',",
"'TWB706A1',",
"'TWB707A1',",
"'TWB708A1',",
"'TWB992',",
"'TWB999A1'"
if what = '' then
parse upper value 'tst u' with what fun
call mIni
m.warn.0 = 0
if userid() = 'A540769' then
m.skels = 'A540769.wk.skels'
else
m.skels = 'ORG.U0009.B0106.KIUT23.SKELS'
m.limit = 1E11
if fun = 'DROP' then do
if substr(what, 5, 1) ^== '.' then
call err "what = 'dbSu.pref' expected not" what 'for drop'
m.dbSys = left(what, 4)
what = substr(what, 6)
m.dPre = 'DSN.DROP.'m.dbSys
call envPut 'MGMTCLAS', 'A008Y000'
m.tas3 = left(what, 2)right(what, 1)
end
else do
m.tas3 = left(what, 2)right(what, 1)
m.task = 'NAK'what
if sysvar('SYSNODE') = 'RZ1' then do
m.dbSys = 'DBAF'
newCreator = 'TSTNAKNE'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'A540769.TMPNAK.'m.task
m.dPre = 'DSN.'m.task
end
else if 1 then do /* rz2 proc */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'A008Y005'
m.dPre = 'DSN.'m.task
end
else do /* transfer rz2 --> rz1 */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'SHR21.DIV.P021.'m.task
end
end
nGen = m.dPre'.JCL'
if fun = 'A' then do
if list = '' then
list = '*'
cx = pos('*', list)
if cx > 0 then
list = left(list, cx-1) 'JCL LIST CALT.LCTL CNEU.LCTL' ,
'CALT.LISTDEF CNEU.LISTDEF' substr(list, cx+1)
call allocList m.dPre, list
exit
end
call adrSqlConnect m.dbSys
if fun = 'R' then do
call restartRebind list, nGen"(info)", nGen"(rebinRst)"
exit
end
if fun = 'D' then do
call checkUnloadDS nGen"(info)", m.dPre'.UNL'
exit
end
if fun = 'DROP' then do
call infoDb nGen'('what'DB)'
call infoAlt 'STDKR'
call createJb
call showAlt nGen'('what'info)'
call showSyscopy nGen'('what'SyCo)'
call alias nGen'('what'al)'
call rebind nGen'('what'rebi)', 'REBIND', 'T'
call rebind nGen'('what'free)', 'FREE', ''
call dropAlt nGen'('what'Drop)', 1
call utilList 'PDR', nGen'('what'UPDR)', 1
exit
end
if fun = 'TT' then do
call infoDb nGen'(DB)'
call transformTest
exit
end
else if fun = 'TE' then do
call testExp
exit
end
else if fun = '' | verify(fun, 'IULCKQS') > 0 then
call err 'bad fun "'fun'"'
m.igno.0 = 0
call infoDb nGen'(DB)'
if 0 then
call mShow mGetType('StemDB'), db
aOpt = 'ST'
if verify(fun, 'IU', 'm') > 0 then
aOpt = aOpt'DKR'
else if verify(fun, 'LC', 'm') > 0 then
aOpt = aOpt'D'
call infoAlt aOpt
if verify(fun, 'CUL', 'm') > 0 then do
call infoNeu nGen'(ddlNeu)'
if 0 then
call mShow mGetType('StemNN'), nn
call mapAltNeu newCreator, (verify(fun, 'U', 'm') > 0)
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
call mShow mGetType('StemNN'), nn
if 0 then
call mShow mGetType('StemJob'), jb
if 1 then
call mShow mGetType('Stem'), igno
end
else do
call createJb
if 0 then
call mShow mGetType('StemJob'), jb
end
if verify(fun, 'IU', 'm') > 0 then do
call showAlt nGen'(info)'
call showSyscopy nGen'(infoSyCo)'
call alias nGen'(alia)'
call utilList 'PDR', nGen'(utilPDR)', 1
call utilList 'COP', nGen'(copyAlt)', 1
call dropAlt nGen'(dbDropAl)'
call count nGen'(CNALT)', 1, m.limit
end
if pos('I', fun) > 0 then do
call rebind nGen'(rebind)', 'REBIND', 'T'
call rebind nGen'(freePkg)', 'FREE', ''
end
if pos('U', fun) > 0 then do
call showNeu nGen'(infoMap)'
call unload 'ULI', nGen'(unloLim0)'
call check 'CHK', nGen'(check)'
call rebind nGen'(rebind)', 'REBIND', 'TOQ'
call utilList 'COP', nGen'(copyNeu)', 0
call count nGen'(cnNeu)', 0, m.limit
end
if pos('L', fun) > 0 then do
call unload 'UNL', nGen'(unload)'
call unload 'UNL', nGen'(unloaSAV)', 'SAV'
call loadLines m.dPre'.ULI'
call load 'LOA', nGen'(load)'
end
sMbrs = 'LCTL LISTDEF PCL DBSP BOLIAL BOLIBS BOLICI',
'BOLICR BOLIPH BOLIPI BOLIRZ BOLIUE BOLIVI BOLIW7 BOLIW8'
if pos('Q', fun) > 0 then do
call ctlTransQQ
end
else if pos('C', fun) > 0 then do
call ctlSearch 'C', nGen'(infoCTL)', m.dPre'.LIST', sMbrs, m.dPre
end
if pos('K', fun) > 0 then do
call ctlSearch 'K', nGen'(infoCTL)', m.dPre'.LIST', sMbrs, m.dPre
end
if pos('S', fun) > 0 then do
call count nGen'(CNALT)', 1, m.limit
end
call adrSqlDisConnect m.dbSys
call warnWrite m.dPre'.JCL'
exit
infoAlt: procedure expose m.
parse arg opt
if pos('S', opt) > 0 then do
call infoTS
if 0 then
call mShow mGetType('StemTS'), ts
if 0 then
do x=1 to m.ts.0
say m.ts.x.db'.'m.ts.x.ts m.ts.x.bp m.ts.x.used
end
end
if pos('T', opt) > 0 then do
call mapReset crNa
call infoTB
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
do x=1 to m.tb.0
n = m.tb.x.tsNd
say m.tb.x.cr'.'m.tb.x.tb m.tb.x.db'.'m.tb.x.ts n '->' m.n
end
end
if pos('D', opt) > 0 then do
call infoDep
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
do x=1 to m.dep.0
say m.dep.x.ty m.dep.x.cr'.'m.dep.x.na,
m.dep.x.bTy m.dep.x.bCr'.'m.dep.x.bNa
end
end
if 0 then
call mShow mGetType('Stem'), igno
if pos('K', opt) > 0 then do
call infoPackage
if 0 then
call mShow mGetType('StemPK'), pk
end
if pos('R', opt) > 0 then do
call infoRI
if 0 then
call mShow mGetType('StemRI'), ri
end
return
endProcedure infoAlt
infoDB: procedure expose m.
parse arg inp
call mapReset ii, 'K'
call readDsn inp, c.
dbII = 'in ('
dbNN = 'in ('
con = ''
call mapReset(db.a2n)
call mapReset(db.n2a)
call mTypeNew 'StemDB', mTypeNew(db, '', 'ALT NEU')
m.db.0 = 0
do c=1 to c.0
dbAlt = word(c.c, 1)
dbNeu = word(c.c, 2)
if left(dbAlt, 1) <> '-' then do
dd = mAdd(db, dbAlt'->'dbNeu)
m.dd.alt = dbAlt
m.dd.neu = dbNeu
call mapPut db.a2n, dbAlt, dbNeu
call mapPut db.n2a, dbNeu, dbAlt
dbII = dbII || con || "'"dbAlt"'"
dbNN = dbNN || con || "'"dbNeu"'"
con = ', '
end
else do
call mapAdd ii, translate(dbNeu), dbNeu
end
end
m.dbIn = dbII')'
m.dbInNeu = dbNN')'
say m.db.0 'alte DB' m.dbIn', neue' m.dbInNeu
call mShow mGetType('Stem'), mapKeys(ii)
return
endProcedure infoDB
isIgnored: procedure expose m.
parse upper arg ty, qu, na
if pos(ty, 'VTA') > 0 then do
if mapHasKey(ii, 'C.'qu) then
return 1
end
if mapHasKey(ii, ty'.'qu'.'na) then
return 1
return 0
endProcedure isIgnored
infoTS: procedure expose m.
root = 'TS'
flds = DB TS NTB PARTS BP USED
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTS', mTypeNew(ts, '', flds 'TBSQ')
call mapReset root
end
sqlFlds = sqlFields(flds)
if m.wb then
pp = "and name in ("m.wbTs")"
else
pp = ""
sql = "select dbName, name, nTables, partitions," ,
"bPool, float(nActive)*pgSize*1024" ,
"from sysibm.systablespace",
"where dbname" m.dbIn pp ,
"order by 1, 2 "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
tbSQ = ''
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored('S', db, ts) then do
call mAdd igno, 'alt S' db'.'ts
iterate
end
used = format(used,2,3,2,0)
nd = mPutVars(mAdd(root, db'.'ts), flds 'TBSQ')
call mapAdd root, db'.'ts, nd
end
call adrSql 'close c1'
say m.root.0 'tablespaces'
return
endProcedure infoTS
infoTB: procedure expose m.
root = tb
flds = cr tb db ts
xFlds = tsNd newNd
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTB', mTypeNew(tb, '', flds xflds)
call mapReset root
end
newNd = ''
sqlFlds = sqlFields(flds)
sql = "select creator, name, dbName, tsName",
"from sysibm.systables",
"where dbname" m.dbIn "and type = 'T'"
if m.wb then
sql = sql "and name in ("m.wbTb")"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored('T', cr, tb) then do
call mAdd igno, 'alt T' cr'.'tb 'in' db'.'ts
iterate
end
tsNd = mapGet('TS', db'.'ts)
nd = mPutVars(mAdd(root, cr'.'tb), flds xFlds)
m.tsNd.tbSq = m.tsNd.tbSq nd
if mapHasKey(root, tb) then
call err '??? duplicate table' cr'.'tb
else
call mapAdd root, tb, nd
call mapAdd crNa, cr'.'tb, nd
end
call adrSql 'close c1'
say m.root.0 'tables'
return
endProcedure infoTb
stripVars:
parse arg ggList
do ggX=1 to words(ggList)
ggW = word(ggList, ggX)
x=value(ggW, strip(value(ggW)))
end
return
endSubroutine stripVars
infoDep: procedure expose m.
flds = ty cr na bTy bCr bNa
if mDefIfNot(dep'.'0, 0) then
call mTypeNew 'StemDep', mTypeNew('Dep', '', flds 'NEWND ACT')
sqlFlds = sqlFields(flds)
newNd = ''
act = ''
if m.wb then
call envPut 'DBIN', m.dbin "and name in ("m.wbTb")"
else
call envPut 'DBIN', m.dbin
sql = skel2sql('nakDep')
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored(ty, cr, na) then do
call mAdd igno, 'alt dep' ty cr'.'na 'from' bTy bCr'.'bNa
end
else if mapHasKey(crNa, cr'.'na) then do
qTy = 'TY'
qBTy = 'BTY'
qbCr = 'BCR'
qbNa = 'BNA'
oo = mapGet(crNa, cr'.'na)
if left(oo, 3) = 'TB.' then do
if ty = 'T' & bTy = '.' & bNa = m.oo.db then
nop /* say 'old table in dep' cr'.'na */
else
call err 'dep with name of old table' ty cr'.'na
end
else if ty ^== m.oo.qTy then
call err 'new dep' m.oo.qTy cr'.'na 'mismatches old' ,
m.oo.qTy m.oo
else if (ty == 'A'| ty == 'Y') ,
& ^ (bTy == m.oo.qBty & bCr == m.oo.qBcr ,
& bNa == m.oo.qBNa) then
call err 'dep with duplicate different al/sy' cr'.'na ,
'b' bTy bCr'.'bNa ,
'oo' m.oo.qBty m.oo.qBcr'.'m.oo.qBNa
else if 0 then
say 'skipping duplicate' cr'.'na
end
else do
nd = mPutVars(mAdd(dep, cr'.'na), flds 'NEWND' 'ACT')
call mapAdd crNa, cr'.'na, nd
end
end
call adrSql 'close c1'
say m.dep.0 'dependencies'
return
endProcedure infoDep
infoNeu: procedure expose m.
parse arg ddlNeu
flds = cr na ty for oldNd oldAl
if mDefIfNot(nn.0, 0) then do
call mapReset(nn)
call mTypeNew 'StemNN', mTypeNew('NN', '', flds)
end
oldNd = ''
oldAl = ''
r = jDsn(ddlNeu)
call jOpen r, 'r'
call scanReader scanSqlIni(s), r
lastX = 0
do forever
if lastX = m.scan.s.lineX then
if ^ scanNl(s, 1) then
leave
lastX = m.scan.s.lineX
if pos('CREATE', translate(m.scan.s.src)) < 1 then
iterate
fnd = 0
linePos = scanLinePos(s)
do while lastX = m.scan.s.lineX & ^fnd
if scanSql(scanSkip(s)) = '' then
leave
fnd = m.sqlType = 'i' & m.val == 'CREATE'
end
if ^ fnd then do
say 'no create, ignoring' linePos
iterate
end
if scanSqlId(scanSkip(s)) == '' then do
say 'no sqlId, ignoring line' lastx strip(m.scan.s.src)
iterate
end
subTy = ''
if wordPos(m.val, 'UNIQUE LARGE LOB') > 0 then do
subTy = m.val
plus = ''
if subTy = 'UNIQUE' then
plus = 'WHERE NOT NULL'
do wx=1 by 1
if scanSqlId(scanSkip(s)) == '' then
call scanErr s, 'no sqlId after create' subTy
else if m.val = word(plus, wx) then
subTy = subTy m.val
else if wx=1 | wx > words(plus) then
leave
else
call scanErr s, 'stopped in middle of' plus
end
end
ty = m.val
m.scan.s.sqlBrackets = 0
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'no qualId after create' subTy ty
na = m.val
na1 = m.val.1
na2 = m.val.2
for = '-'
if ty = 'ALIAS' then do
if scanSqlId(scanSkip(s)) ^== 'FOR' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'A'
end
else if ty = 'INDEX' then do
if scanSqlId(scanSkip(s)) ^== 'ON' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'X'
end
else if ty = 'TABLE' then do
do while ^ (m.scan.s.sqlBrackets = 0 & m.sqlType = 'i' ,
& m.val == 'IN')
if scanSql(scanSkip(s)) = '' | m.tok == ';' then
call scanErr s, 'in database expected'
end
if scanSqlQuId(scanSkip(s)) == '' | m.val = 'DATABASE' then
call scanErr s, 'ts name expected after create' ty na
for = m.val
ty = 'T'
end
else if ty = 'TABLESPACE' then do
if scanSqlId(scanSkip(s)) ^== 'IN' then
call scanErr s, 'IN expected after create' ty
if scanSqlDeId(scanSkip(s)) == '' then
call scanErr s, 'db name expected after create' ty
na = m.val'.'na
ty = 'S'
end
else if ty = 'VIEW' then do
ty = 'V'
for = ''
end
if 0 then
say 'create' subTy ty 'name' na 'for' for
if for == '-' then do
end
else if isIgnored(ty, na1, na2) then do
call mAdd igno, 'neu ' ty na 'for' for
end
else do
nd = mPut(mAdd(nn, na), flds, na1, na2, ty, for)
call mapAdd nn, na, nd
end
end
call jClose r
return
endProcedure infoNeu
infoRI: procedure expose m.
flds = cr tb db ts bCr bTb bDb bTS rNa
if mDefIfNot(ri.0, 0) then
call mTypeNew 'StemRI', mTypeNew('RI', '', flds)
sql = "select r.creator, r.tbName, td.dbName, td.tsName" ,
", refTbcreator, refTbName, tr.dbName, tr.tsName, relName",
"from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr",
"where r.creator = td.creator and r.tbName = td.name",
"and r.refTbcreator = tr.creator and r.reftbName = tr.name"
sql = sql "and td.dbname" m.dbIn ,
'union' sql "and tr.dbname" m.dbIn
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
nd = mPutVars(mAdd(ri, cr'.'tb'.'rNa), flds)
end
call adrSql 'close c1'
say m.ri.0 'references'
return
endProcedure infoRI
infoPackage: procedure expose m.
flds = timeStamp pcTimestamp type,
validate isolation valid operative owner qualifier
fldStr = collid Name version flds
flds = collid Name version conToken flds
if mDefIfNot(pk.0, 0) then do
call mTypeNew 'StemPK', mTypeNew('PK', '', flds 'ACT')
call mapReset pkMap
end
call envPut 'DBIN', m.dbIn
sql = skel2sql('nakPckg')
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cVa = 0
cOp = 0
act = ''
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars fldStr
nd = mPutVars(mAdd('PK', collid'.'name), flds 'ACT')
call mapAdd pkMap, collid'.'name'.'conToken, nd
if valid = 'Y' then
cVa = cVa + 1
if operative = 'Y' then
cOp = cOp + 1
end
call adrSql 'close c1'
say (c-1) 'packages,' cVa 'valid,' cOp 'operative'
return
endProcedure infoPackage
showSyscopy: procedure expose m.
parse arg out
m.o.0 = 0
call envPut 'DBIN', m.dbIn
sql = skel2Sql('nakSysCo')
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into :job, :ty, :cnt, :tst'
if sqlCode = 100 then
leave
call mAdd o, left(job, 8) left(ty, 1) right(cnt, 9) tst
end
call adrSql 'close c1'
call writeDsn out, m.o., , 1
return
endProcedure showSyscopy
skel2Sql: procedure expose m.
parse arg skel
call readDsn m.skels'('skel')', m.skel2Sql.i.
call leftSt skel2Sql.i, 72
m.skel2Sql.o.0 = 0
call envExpAll skel2Sql.o, skel2Sql.i
return catStripSt(skel2Sql.o)
endProcedure skel2Sql
catStripSt: procedure expose m.
parse arg m
r = ''
mid = ''
do x=1 to m.m.0
r = r || mid || strip(m.m.x)
mid = ' '
end
return r
endProcedure catStripSt
leftSt: procedure expose m.
parse arg m, le
do x=1 to m.m.0
m.m.x = left(m.m.x, 72)
end
return m
endProcedure leftSt
mapAltNeu: procedure expose m.
parse arg newCr, doQ
do tx=1 to m.tb.0
cc = tb'.'tx
if ^ mapHasKey(nn, newCr'.'m.cc.tb) then
call err 'old table' m.cc 'has no corr. new'
dd = mapGet(nn, newCr'.'m.cc.tb)
if ^mapHasKey(db.a2n, m.cc.db) then
call err 'old table' m.cc 'ts in bad db' m.cc.db'.'m.cc.ts
if m.dd.oldNd ^== '' then
call err 'old table' m.cc 'maps to new' m.dd ,
'which already maps to' m.dd.oldNd
nTs = m.dd.for
if mapGet(db.a2n, m.cc.db) <> left(nTs, pos('.', nTs)-1) then
/* call err 'new table' m.dd 'in wrong db' nTs wkTst????
*/ say 'new table' m.dd 'in wrong db' nTs
m.cc.newNd = dd
m.dd.oldNd = cc
end
qDep = ''
do dx=1 to m.dep.0
dd = dep'.'dx
a = m.dd.ty
if ^ mapHasKey(nn, newCr'.'m.dd.na) then do
if a <> 'A' & a <> 'Y' then
call err 'old dep' a m.dd 'has no corr. new'
m.dd.act = 'q'
qDep = qDep "or (bQualifier = '"m.dd.cr"'" ,
"and bName = '"m.dd.na"')"
iterate
end
ww = mapGet(nn, newCr'.'m.dd.na)
if a == 'V' then do
if m.ww.ty ^== 'V' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww
if m.ww.oldNd ^== '' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww ,
'which is already mapped to' m.ww.oldNd
m.ww.oldNd = dd
m.dd.newNd = ww
end
else if (a == 'A' | a == 'Y') then do
if m.dd.na ^== m.dd.bNa then
call err 'bad old alias' m.dd ,
'for' m.dd.bCr'.'m.dd.bNa
m.ww.oldAl = m.ww.oldAl m.dd
end
else do
call err 'bad dep type' m.dd.ty m.dd
end
end
do nx=1 to m.nn.0
ww = nn'.'nx
if m.ww.ty = 'T' | m.ww.ty = 'V' then do
oo = m.ww.oldNd
if oo == '' then
call err 'no old for new' m.ww.ty m.ww
else if m.oo.cr ^== newCr & m.ww.oldAl = '' then
call warn 'no old alias for new obj' m.ww.ty m.ww
end
end
do otX=1 to m.tb.0
ot = 'TB.'otX
os = m.ot.tsNd
osNa = m.os
nt = m.ot.newNd
ns = m.nt.for
if symbol('os.os') ^== 'VAR' then do
os.os = ns
m.oldTs.osNa = ns
end
else if wordPos(ns, os.os) < 1 then do
os.os = os.os ns
m.oldTs.osNa = os.os
end
if symbol('ns.ns') ^== 'VAR' then do
ns.ns = os
nt.ns = nt
end
else do
if ns.ns ^== os then
call err 'new TS maps to old' ns.ns 'and' os
if wordPos(nt, nt.ns) < 1 then
nt.ns = nt.ns nt
end
end
do tx=1 to m.ts.0
tt = ts'.'tx
newSq = ''
do nsX=1 to words(os.tt)
ns = word(os.tt, nsX)
do ntx=1 to words(nt.ns)
nt = word(nt.ns, ntX)
newSq = newSq m.nt.oldNd
end
end
/* say 'ts' m.tt 'seq' m.tt.tbSq '-->' newSq */
m.tt.tbSq = newSq
end
call createJb
if doQ & qDep <> '' then do
m.o.0 = 0
call mAdd o, 'select * from RZ2.TACCT_PKGUSED where'
pre = ' '
sql = "select dCollid, dName, dConToken" ,
"from sysibm.syspackdep",
"where (not bType in ('P', 'R')) and" ,
"(" substr(qDep, 5) ")"
flds = co na ct
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars 'CO NA'
if ^ mapHasKey(pkMap, co'.'na'.'ct) then
call err 'q package' co'.'na'.'ct 'not in dep'
dd = mapGet(pkMap, co'.'na'.'ct)
if m.dd.act ^== 'q' then do
m.dd.act = 'q'
call mAdd o, pre "(PCK_ID = '"na"' AND" ,
"PCK_CONSIST_TOKEN = '"c2x(ct)"')"
pre = ' or'
end
end
call adrSql 'close c1'
call writeDsn m.dPre'.JCL(QPKGSQL)', m.o., , 1
end
return
endProcedure mapAltNeu
createJb: procedure expose m.
m.jb.0 = 0
call mTypeNew 'StemJob', mTypeNew('Job', '', 'JOB TBND')
if m.task = 'NAKCD01' then
bLim = 4E+9
else
bLim = 1E+9
tLim = 30
tbs = 0
bys = 0
jobNo = 1
do tx=1 to m.ts.0
tt = ts'.'tx
if tbs > 0 & (bys + m.tt.used > bLim ,
| tbs + m.tt.nTb > tLim) then do
jobNo = jobNo + 1
bys = 0
tbs = 0
end
if m.tt.nTb < 1 then do
call warn 'skipping ts' m.tt 'without tables' m.tt.nTb
iterate
end
bys = bys + m.tt.used
tbs = tbs + m.tt.nTb
do nsX=1 to words(m.tt.tbSq)
ot = word(m.tt.tbSq, nsX)
if symbol('m.ot') ^== 'VAR' then
call err 'oldTable' ot 'undefined in TS' m.tt tt
call mPut mAdd(jb, m.ot), 'JOB TBND', jobNo, ot
end
end
return
endProcedure createJb
showAlt: procedure expose m.
parse arg out
m.o.0 = 0
do dx=1 to m.db.0
dd = db'.'dx
call mAdd o, 'mD' left(m.dd.alt, 20)left(m.dd.neu, 20)
end
do tx=1 to m.tb.0
tt = 'TB.'tx
ss = m.tt.tsNd
l = 'oT' left(m.tt, 20)left(m.ss, 20) m.ss.used,
right(m.ss.ntb, 4) || right(m.ss.parts, 4) m.ss.bp
call mAdd o, l
end
do dx=1 to m.dep.0
dd = dep'.'dx
ww = m.dd.newNd
tp = m.dd.ty
if tp == 'V' then do
l = 'mV' left(m.dd, 20)left(m.ww, 20)
end
else if tp == 'A' | tp == 'Y' then do
l = m.dd.act
if l = '' then
l = 'd'
else if length(l) <> 1 | l = 'd' then
call err 'bad dep act' l 'for' m.dd
l = l || tp left(m.dd, 30)left(m.dd.bCr'.'m.dd.bNa, 30)
end
else do
call err 'bad ty in dep' m.dd.ty m.dd
end
call mAdd o, l
end
do rx=1 to m.ri.0
rr = ri'.'rx
if ^mapHasKey(db.a2n, m.rr.db) ,
| ^mapHasKey(db.a2n, m.rr.bDb) then
call err 'implement external ri' m.rr ,
'->' m.rr.bCr'.'m.rr.bTb
/* q = '|f' */
else if m.rr.db <> m.rr.bDb then
q = '|d'
else
q = '= '
call mAdd o, 'mR' left(m.rr.cr'.'m.rr.tb, 20) ,
|| left(m.rr.bCr'.'m.rr.bTb, 20) q m.rr.rNa
end
do px=1 to m.pk.0
p = 'PK.'px
if m.p.act = '' then
aa = 'pk'
else if (length(m.p.act) <> 1 | m.p.act = 'k') then
call err 'bad pk act' m.p.act
else
aa = m.p.act'k'
call mAdd o, aa left(m.p.collid'.'m.p.name, 17) ,
left(c2x(m.p.conToken), 16) substr(m.p.pcTimeStamp, 3,8),
left(m.p.validate, 1)left(m.p.isolation, 1),
|| left(m.p.valid, 1)left(m.p.operative, 1),
left(m.p.qualifier,8) left(m.p.owner, 8)
end
call writeDsn out, m.o., ,1
return
endProcedure showAlt
showNeu: procedure expose m.
parse arg out
m.o.0 = 0
do jx=1 to m.jb.0
jj = 'JB.'jx
tt = m.jj.tbNd
ww = m.tt.newNd
l = 'mt'right(m.jj.job, 4) left(m.tt, 20)left(m.ww, 20),
|| left(m.tt.ts, 8) m.ww.for
call mAdd o, l
end
call writeDsn out, m.o., ,1
return
endProcedure showNeu
alias: procedure expose m.
parse arg out
m.dr.0 = 0
m.cr.0 = 0
c = 0
call sqlId cr, dr
do dx=1 to m.dep.0
dd = dep'.'dx
if m.dd.ty ^== 'A' then
iterate
c = c + 1;
if c // 50 = 0 then
call commit cr, dr
call mAdd dr, 'DROP ALIAS' m.dd';'
call mAdd cr, 'CREATE ALIAS' m.dd 'FOR' m.dd.bCr'.'m.dd.bNa';'
end
call commit cr, dr
mb = dsnGetMbr(out)
call writeDsn dsnSetMbr(out, left(mb'CREATE', 8)), m.cr., ,1
call writeDsn dsnSetMbr(out, left(mb'DROPPP', 8)), m.dr., ,1
return
endProcedure alias
commit: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), 'COMMIT;'
end
return
endProcedure commit
sqlId: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), "SET CURRENT SQLID = 'S100447';"
end
return
endProcedure sqlId
unload: procedure expose m.
parse arg fun, out, suFu
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
if suFu = '' then
call envPut 'DSNPRE', m.dPre'.'fun
else
call envPut 'DSNPRE',
, overlay(suFu, m.dPre, pos('NAK', m.dPre))'.'suFu
jOld = 0
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
say 'job' fun oldJob':' (jx-jOld) 'tables'
jOld = jx
oldJob = m.jj.job
if suFu = '' then
call envPutJOBNAME fun, oldJob
else
call envPutJOBNAME suFu, oldJob
call envExpAll o, jc
call envExpAll o, skSt
end
ot = m.jj.tbNd
os = m.ot.tsNd
if oldOs <> os then do
oldOs = os
call envPut 'TS', m.os
if m.os.parts = 0 then do
call envPut 'PARTONE', ''
call envPut 'PAUN', 'UN'
end
else do
call envPut 'PARTONE', 'PART 1'
call envPut 'PAUN', 'PA'
end
call envExpAll o, skTS
end
call envPut 'TB', m.ot
call envExpAll o, skTb
end
say 'job' fun oldJob':' (jx-jOld) 'tables'
call writeDsn out, m.o., ,1
return
endProcedure unload
loadLines: procedure expose m.
parse arg punPre
do sx=1 to m.ts.0
ss = ts'.'sx
pun = punPre'.'m.ss.db'.'m.ss.ts'.PUN'
call readDsn pun, p.
wh = ''
tbCnt = 0
do p=1 to p.0
w1 = word(p.p, 1)
if w1 = 'LOAD' then do
wh = 'l'
end
else if w1 = 'INTO' then do
if word(p.p, 2) ^== 'TABLE' then
call err 'TABLE expected in line' p 'in' pun':' p.p
w3 = word(p.p, 3)
if w3 = '' then do
p = p+1
w3 = word(p.p, 1)
end
if right(w3, 1) == '.' then do
p = p+1
w3 = w3 || word(p.p, 1)
end
dx = pos('.', w3)
if dx < 1 then
call err '. expected in w3 line' p 'in' pun':' p.p
crTb = strip(left(w3, dx-1), 'b', '"')'.',
||strip(substr(w3, dx+1), 'b', '"')
if ^ mapHasKey(crNa, crTb) then
call err 'old table' crTb 'not found' ,
'for punchLine' p 'in' pun':' p.p
tt = mapGet(crNa, crTb)
if m.tt.tsNd ^== ss then
call err 'old table' crTb ,
'wrong ts' m.tt.db'.'m.tt.ts,
'for punchLine' p 'in' pun':' p.p
if ^mDefIfNot(tt'.LO.0', 0) then
call err 'already loaded table' crTb ,
'for punchLine' p 'in' pun':' p.p
tbCnt = tbCnt + 1
if m.ss.parts == 0 then
wh = 'i'
else
wh = 'p'
end
else if w1 = 'PART' then do
if wh = 'p' then
wh = 'i'
else
call err 'PART in unpartitioned TS' m.tt.ts,
'for punchLine' p 'in' pun':' p.p
end
else if w1 = ')' then do
if strip(p.p) <> ')' then
call err 'bad ) line' p 'in' pun':' p.p
if wh <> 'i' then
call err ') in state' wh 'line' p 'in' pun':' p.p
call mAdd tt'.LO', p.p
wh = ''
end
else if wh == 'i' then do
call mAdd tt'.LO', p.p
end
else if wh == 'l' then do
if w1 ^== 'EBCDIC' then
call err 'bad line after load' ,
'in punchLine' p 'in' pun':' p.p
end
end
if wh ^== '' then
call err 'punch' pun 'ends in state' wh
if tbCnt <> m.ss.nTb then
call err tbCnt 'tables not' m.ss.nTb 'loaded for' m.ss
say 'loadCards for' tbCnt 'tables for' m.ss
end
return
endProcedure loadLines
load: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'OS)', m.skOs.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.UNL'
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
say 'job' fun oldJob':' (jx-jOld) 'tables'
jOld = jx
oldJob = m.jj.job
call envPutJOBNAME fun, oldJob
call envExpAll o, jc
call envExpAll o, skSt
end
ot = m.jj.tbNd
os = m.ot.tsNd
nt = m.ot.newNd
ns = m.nt.for
if oldOS ^== os then do
oldOS = os
tRec = 'TREC' || jx
call envPut 'TREC', tRec
call envPut 'OLDDB', m.os.db
call envPut 'OLDTS', m.os.ts
if m.os.parts = 0 then do
call envPut 'PAVAR',''
call envPut 'UNPARTDDN', 'INDDN' tRec
end
else do
call envPut 'PAVAR','P&PA..'
call envPut 'UNPARTDDN', ''
end
call envExpAll o, skOS
end
if oldNS ^== ns then do
oldNS = ns
call envPut 'TS', ns
call envExpAll o, skTs
end
call envPut 'TB', m.nt
if m.os.parts = 0 then do
call envPut 'PARTDDN', ''
call envExpAll o, skTb
call mAddSt o, ot'.LO'
end
else do
do px=1 to m.os.parts
call envPut 'PARTDDN', 'PART' px 'INDDN' tRec
call envExpAll o, skTb
call mAddSt o, ot'.LO'
end
end
end
say 'job' fun oldJob':' (jx-jOld) 'tables'
call writeDsn out, m.o., ,1
return
endProcedure load
check: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skut.
call readDsn m.skels'(nak'fun'Ts)', m.skts.
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPutJOBNAME 'CHCK'
m.o.0 = 0
call envExpAll o, jc
call envExpAll o, skUt
do rx=1 to m.ri.0
rr = 'RI.'rx
cn = m.rr.cr'.'m.rr.tb
if mapHasKey(crNa, cn) then do
ot = mapGet(crNa, cn)
nt = m.ot.newNd
dbTs = m.nt.for
end
else do
call err 'implement check on foreign table'
end
if R.dbTs == 1 then
iterate
R.dbTs = 1
call envPut 'TS', dbTs
call envExpAll o, skTs
end
call writeDsn out, m.o., ,1
return
endProcedure check
utilList: procedure expose m.
parse arg fun, out, useOld
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nakLstUt)', m.skUt.
call readDsn m.skels'(nakLstTs)', m.skTS.
call readDsn m.skels'(nak'fun')', m.skFu.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
call envExpAll o, skFu
oldJob = m.jj.job
call envPutJOBNAME fun, oldJob
call envExpAll o, jc
call envExpAll o, skUt
end
ot = m.jj.tbNd
if useOld then do
os = m.ot.tsNd
ts = m.os
end
else do
nt = m.ot.newNd
ts = m.nt.for
end
if ts.ts = 1 then
iterate
ts.ts = 1
call envPut 'TS', ts
call envExpAll o, skTS
end
if jx > 1 then
call envExpAll o, skFu
call writeDsn out, m.o., ,1
return
endProcedure utilList
envPutJobname: procedure expose m.
parse arg fun, jobNo
jobChars = '0123456789ABCDEF'
if jobNo = '' then
n = 'Y' || m.tas3 || left(fun, 4, 'Z')
else
n = 'Y' || m.tas3 || left(fun, 3, 'Z') ,
|| substr(jobChars, 1 + (jobNo // length(jobChars)), 1)
call envPut 'JOBNAME', n
return
endProcedure envPutJobname
dropAlt: procedure expose m.
parse upper arg out, dropOnly
m.o.0 = 0
call mAdd o, "bist Du wirklich sicher ?"
call mAdd o, "set current sqlId = 'q100447';"
do ddx=1 to m.db.0
dd = 'DB.'ddx
call mAdd o, 'xrop database' m.dd.alt';'
call mAdd o, 'commit;'
end
call writeDsn out, m.o., ,1
if dropOnly == 1 then
return
call readDsn m.skels'(nakJobCa)', m.jc.
m.o.0 = 0
call envPutJOBNAME 'DBDROP'
call envExpAll o, jc
call dsnTep2 o, 'SDROP', out, '*'
call writeDsn m.dPre'.JCL(DBDROPAJ)', m.o., ,1
m.o.0 = 0
call envPutJobname 'DDLNEU'
call envExpAll o, jc
call dsnTep2 o, 'SCREA', m.dPre'.JCL(DDLNEU)', '*'
call writeDsn m.dPre'.JCL(DDLNEUJ)',m.o., ,1
m.o.0 = 0
call envPutJobname 'REBIND'
call envExpAll o, jc
call db2Dsn o, 'SCREA', m.dPre'.JCL(REBIND)', '*'
call writeDsn m.dPre'.JCL(REBINDJ)',m.o., ,1
return
endProcedure dropAlt
count: procedure expose m.
parse upper arg out, useOld, lim
outMb = dsnGetMbr(out)
if useOld then
call envPut 'DBIN', m.dbIn
else
call envPut 'DBIN', m.dbInNeu
if symbol('m.cnWit.0') ^== 'VAR' then do
call readDsn m.skels'(nakCnWit)', m.cnWit.
call readDsn m.skels'(nakCnRun)', m.cnRun.
call readDsn m.skels'(nakCnRts)', m.cnRts.
call readDsn m.skels'(nakCnSQL)', m.cnSQL.
call readDsn m.skels'(nakCnSQ2)', m.cnSQ2.
call readDsn m.skels'(nakJobCa)', m.cnJC.
end
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnRun
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'RUN'), m.o2., ,1
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnRts
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'RTS'), m.o2., ,1
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnSQL
pre = ' '
if lim = '' then
lim = 9E99
ovLim = ''
do tx = 1 to m.tb.0
s = m.tb.tx.tsNd
if m.s.used > lim then do
ovLim = ovLim m.tb.tx.tb
end
else do
if useOld then do
call mAdd o, pre "select '"m.tb.tx.cr"', '"m.tb.tx.tb"'," ,
'count(*) from' m.tb.tx
end
else do
nt = m.tb.tx.newNd
call mAdd o, pre "select '"m.nt.cr"', '"m.nt.na"'," ,
'count(*) from' m.nt
end
pre = 'union'
end
end
call warn words(ovLim) 'tables over limit' lim 'of' m.tb.0':' ovLim
call envExpAll o, cnSQ2
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'SQL'), m.o2., ,1
call envPut 'DBSYS', m.dbSys
call envPutJobname outMb
m.o.0 = 0
call envExpAll o, cnJC
call dsnTep2 o, 'SRUN', m.dPre'.JCL('outMb'RUN)',
, m.dPre'.LIST('outMb'RUJ)'
call dsnTep2 o, 'SRTS', m.dPre'.JCL('outMb'RTS)',
, m.dPre'.LIST('outMb'RTJ)'
call dsnTep2 o, 'SSQL', m.dPre'.JCL('outMb'SQL)',
, m.dPre'.LIST('outMb'SQJ)'
/* call envPut 'STEP', 'SRUN'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'RUN)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'RUJ)'
call envExpAll o, cnTep2
call envPut 'STEP', 'SRTS'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'RTS)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'RTJ)'
call envExpAll o, cnTep2
call envPut 'STEP', 'SSQL'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'SQL)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'SQJ)'
call envExpAll o, cnTep2
*/ call writeDsn dsnSetMbr(out, outMb'J'), m.o., ,1
return
endProcedure count
dsnTep2: procedure expose m.
parse arg o, st, in ,out
if symbol('m.dsnTep2.0') ^== 'VAR' then
call readDsn m.skels'(nakTep2)' , m.dsnTep2.
call envPut 'STEP', st
call envPut 'DSNIN', 'DISP=SHR,DSN='in
if out == '*' then
call envPut 'DSNOUT', 'SYSOUT=*'
else
call envPut 'DSNOUT', 'DISP=SHR,DSN='out
call envExpAll o, dsnTep2
return
endProcedure dsnTep2
db2Dsn: procedure expose m.
parse arg o, st, in ,out
if symbol('m.db2Dsn.0') ^== 'VAR' then
call readDsn m.skels'(nakDsn)' , m.db2Dsn.
call envPut 'STEP', st
call envPut 'DSNIN', 'DISP=SHR,DSN='in
if out == '*' then
call envPut 'DSNOUT', 'SYSOUT=*'
else
call envPut 'DSNOUT', 'DISP=SHR,DSN='out
call envExpAll o, db2Dsn
return
endProcedure db2Dsn
splitSql: procedure expose m.
parse arg d, s
do sx=1 to m.s.0
l = strip(m.s.sx, 't')
do while length(l) > 71
cx = lastPos(", ", left(l, 72))
if cx < 20 then
call err 'cannot split line' l
call mAdd d, left(l, cx+1)
l = ' ' substr(l, cx+2)
end
call mAdd d, l
end
return
endProcedure splitSql
rebind: procedure expose m.
parse arg out, cmd, opt
m.o.0 = 0
spec = 0
triCmd = cmd
if pos('T', opt) > 0 then
triCmd = cmd 'TRIGGER'
do px=1 to m.pk.0
p = 'PK.'px
spec = spec+rebindOut(o, cmd, opt,
, m.p.collid, m.p.name, m.p.version,
, m.p.type, m.p.qualifier, m.p.owner)
end
if spec > 0 then do
call warn spec 'special rebinds (qualifier or owner)'
end
call writeDsn out, m.o., ,1
return
endProcedure rebind
rebindOut: procedure expose m.
parse arg o, cmd, opt, co, pk, ve, ty, qu, ow
if ty == 'T' then
t = cmd 'PACKAGE('co'.'pk')'
else
t = cmd 'PACKAGE('co'.'pk'.('strip(ve)'))'
q = ''
if pos('Q', opt) > 0 then
if qu ^= 'OA1P' then
q = 'QUAL(OA1P)'
if pos('O', opt) > 0 then
if wordPos(ow, 'S100447 CMNBATCH S100006') < 1 then
q = q 'OWNER(S100447)'
if q == '' then do
call mAdd o, t';'
return 0
end
if length(t q) <= 70 then do
call mAdd o, t q';'
end
else do
call mAdd o, t '-'
call mAdd o, ' ' q';'
end
return 1
endProcedure rebindOut
restartRebind: procedure expose m.
parse arg opt, in, out
sql = "select version,type, valid, operative",
"from sysibm.sysPackage",
"where location = '' and collid=? and name=? and conToken = ? "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call readDsn in, i.
m.o.0 = 0
cPk = 0
cRs = 0
do i=1 to i.0
if ^ (left(i.i, 3) == 'pk ' | left(i.i, 3) == 'qk ') then
iterate
parse var i.i 4 co '.' pk ct dt fl qu ow .
ctsq = "'" || x2c(ct) || "'"
call adrSql 'open c1 using :CO, :PK , :ctsq'
call adrSql 'fetch c1 into :fVe, :fTy, :fVd, :fOp'
rst = 0
msg = ''
if sqlCode = 100 then do
say '*** pkg not in catalog' fl co'.'pk ct
rst = 1
end
call adrSql 'fetch c1 into :fVe, :fTy, :fVd, :fOp'
if sqlCode ^= 100 then
call err 'duplicate fetch for package' co'.'pk ct
if rst then
nop
else if fVd = 'Y' & fOp = 'Y' then
nop /* say fVe fTy fVd '|| fOp 'validOp' */
else if (fVd = 'Y' | substr(fl, 3, 1) = 'N') then
msg = 'inval bef'
else if pos('=', opt) > 0 & (fVd = substr(fl, 3, 1)) then
msg = 'as before'
else
rst = 1
if pos('S', opt) > 0 then do
if rst then
msg = 'retrying '
if msg ^== '' then
say msg fTy fl '-->' fVd || fOp co'.'pk'('fVe')'
end
cPk = cPk + 1
cRs = cRs + rst
if rst then do
/* say 'retrying ' fTy fl '-->' fVd || fOp co'.'pk'('fVe')'
*/ call rebindOut o, 'REBIND', 'QO', co, pk, fVe, fTy, qu, ow
end
call adrSql 'close c1'
end
say 'retrying' cRs 'rebinds of' cPk
if m.o.0 > 0 then
call writeDsn out, m'.'o'.', , 1
return
endProcedure restartRebind
checkUnloadDS: procedure expose m.
parse arg in, pref
call readDsn in, i.
cTb = 0
cTs = 0
cDS = 0
cEr = 0
call mapReset 'TS', 'K'
do i=1 to i.0
if left(i.i, 3) ^== 'oT ' then
iterate
parse var i.i 4 cr '.' tb db '.' ts sz nTb parts bp .
call stripVars 'cr tb db ts'
if 0 then
say cr'.'tb 'in' db'.'ts 'sz' sz 'nTb' nTb 'parts' parts
dbTs = db'.'ts
cTb = cTb + 1
if mapHasKey('TS', dbTs) then do
ts.dbTs = ts.dbTs cr'.'tb
end
else do
cTs = cTs + 1
call mapAdd 'TS', dbTs, nTb
ts.dbTs = cr'.'tb
if parts = 0 then do
cEr = cEr + check1Ds(pref'.'db'.'ts'.UNL')
cDs = cDs + 1
end
else do
do px=1 to parts
cEr = cEr + check1Ds( ,
pref'.'db'.'ts'.P'right(px, 5, 0)'.UNL')
cDs = cDs + 1
end
end
end
end
say cTb 'tables,' cTs 'TS, ' cDs 'Datasets with' cEr 'errors'
k = mapKeys('TS')
do x=1 to m.k.0
dbts = m.k.x
if mapGet('TS', dbTs) ^= words(ts.dbTs) then
call err 'ts' dbTs 'should have' mapGet('TS', dbTs) ,
'tables but found' words(ts.dbTs)':' ts.dbTs
end
return
endProcedure checkUnloadDS
check1Ds: procedure expose m.
parse arg dsn
res = sysDsn("'"dsn"'")
if res ^== 'OK' then do
say dsn res
return 1
end
res = adrTso("alloc dd(ch) dsn('"dsn"')", '*')
if res <> 0 then do
say 'could not allocate' dsn
call adrTso "free dd(ch)", '*'
return 1
end
call readDDbegin ch
call readDD ch, ch., 100
if ch.0 < 100 then
say 'read' dsn ch.0
call readDDend ch
call adrTso "free dd(ch)", '*'
return 0
endProcedure check1DS
ctlSearch: procedure expose m.
parse arg fun, out, pds, mbrs, sPre
m.o.0 = 0
do mx=1 to words(mbrs)
seMb = word(mbrs, mx)
dsn = pds'('seMb')'
call readDsn dsn, l.
do l=1 to l.0 while pos('SRCH DSN:', l.l) < 1
end
cx = pos('SRCH DSN:', l.l)
if cx < 1 then
call err 'no SRCH DSN: found in' dsn
sLib = word(substr(l.l, cx+9), 1)
cnt = 0
drop f.
do l=l to l.0
cx = pos('--- STRING(S) FOUND ---', l.l)
if cx < 1 then
iterate
else if cx < 20 then
call err 'bad ...FOUND... line' l in dsn':' l.l
cMb = word(l.l, 1)
if f.cMb = 1 then do
call warn 'duplicate' cMb 'in' seMb sLib
iterate
end
f.cMb = 1
call mAdd o, 'cc' left(cMb, 9) left(seMb,9) sLib
cnt = cnt + 1
call readDsn sLib'('cMb')', m.cc.
m.ctlMbr = seMb'('cMb')'
call writeDsn sPre'.CALT.'seMb'('cMb') ::F', m.cc., , 1
if fun = 'C' then do
call transformCtl cc
call writeDsn sPre'.CNeu.'seMb'('cMb') ::F', m.cc., , 1
end
end
say cnt 'members found in' seMb sLib
end
call writeDsn out, m.o., ,1
return
endProcedure ctlSearch
ctlTransQQ: procedure expose m.
call ctlTransMM 'DSN.NAKWB.CALT.LISTNEU', 'DSN.NAKWB.CNEU.LISTNEU',
, QR055031 ,
QR055081 ,
QR055151 ,
QR058041 ,
QR058051 ,
QR058071 ,
QS055031 ,
QS055081 ,
QS055151 ,
QS058031 ,
QS058041 ,
QS058051
return
endProcedure ctlTransQQ
ctlTransMM: procedure expose m.
parse arg src, trg, mbrs
say '??mm' mbrs
do mx=1 to words(mbrs)
mb = word(mbrs,mx)
say '??' mb
call readDsn src'('mb')', m.cc.
call transformCtl cc
call writeDsn trg'('mb') ::F', m.cc., , 1
end
return
endProcedure ctlTransMM
transformTest: procedure expose m.
m.h.1 = 'wie gehts walti'
m.h.2 = 'wie ODV.walti mit imf.ersatz oder IMFDNF01DNF02ODV'
m.oldTs.TSTNAKAL.S004A = TSTNAKNE.A00004A345A
m.oldTs.TSTNAKAL.S003 = TSTNAKNE.A3A
m.h.3 = 'wie TSTNAKAL . S003 TSTNAKAL.S004A DTSTNAKAL . M014A V'
m.h.4 = 'TSTNAKAL,.| TSTNAKAL ? SP(S003 , S004A , M014A* V'
m.h.0 = 4
call mAddSt mCut(i, 0), h
call transformCtl i
do x=0 to m.h.0
say 'i' m.h.x
say 'o' m.i.x
end
exit
endProcedure transformTest
transformCtl: procedure expose m.
parse arg i
if symbol('m.tcl.0') ^== 'VAR' then do
say m.scan.tcl.name1
call scanSqlIni tcl
say m.scan.tcl.name1
say m.scan.tcl.name
if symbol('m.scan.tcl.name') ^== 'VAR' then
call err 'ini scanSql failed'
m.tcl.f.1 = 'ODV'
m.tcl.t.1 = 'OA1P'
m.tcl.f.2 = 'IMF'
m.tcl.t.2 = 'OA1P'
y = 2
do d=1 to m.db.0
y = y + 1
m.tcl.f.y = m.db.d.alt
m.tcl.t.y = m.db.d.neu
end
m.tcl.0 = y
end
do j=1 to m.i.0
lNo = substr(m.i.j, 73)
m.i.j = strip(left(m.i.j, 72), 't')
if left(m.i.j, 2) = '//' & word(m.i.j, 2) = 'JOB' then
iterate
do y=1 to m.tcl.0
cx = 1
do forever
cx = replOne(i'.'j, cx, m.tcl.f.y, m.tcl.t.y)
if cx < 1 then
leave
if y <= 2 then
iterate
call scanLine tcl, m.i.j " ' ' ' ' ' ' ' ' "
m.scan.tcl.pos = cx
call scanSql scanSkip(tcl)
if m.sqlType == '.' then do
if scanSqlDeID(scanSkip(tcl)) ^== '' then do
cx = replTS(i'.'j,
, m.scan.tcl.pos,
, length(m.tok),
, m.tcl.f.y'.'m.val)
end
end
else do
fnd = 0
do q=1 to 3 while m.scan.tcl.pos <= 73
if m.sqlType == 'i' & wordPos(m.val,
, 'SP SPACE SPACENAM') > 0 then do
fnd = 1
leave
end
call scanSql scanSkip(tcl)
end
if ^fnd then
iterate
do while m.scan.tcl.pos <= 73
if scanSqlDeID(scanSkip(tcl)) ^== '' then do
px = replTS(i'.'j,
, m.scan.tcl.pos,
, length(m.tok),
, m.tcl.f.y'.'m.val)
call scanLine tcl, m.i.j
m.scan.tcl.pos = px
end
else if scanSql(scanSkip(tcl)) == '' ,
| m.sqlType == ')' then
leave
end
end
end
end
m.i.j = strip(m.i.j, 't')
if length(m.i.j) > 72 then do
call warn 'line overFlow' length(m.i.j)m.i.j
m.i.j = left(m.i.j, 80)
end
m.i.j = left(m.i.j, 72)lNo
end
return
endProcedure transformCtl
replOne: procedure expose m.
parse arg l, x, o, n
y = pos(o, translate(m.l), x)
if y < 1 then
return 0
m.l = left(m.l, y-1) || n || substr(m.l, y + length(o))
return y + length(n)
endProcedure replOne
replTS: procedure expose m.
parse arg li, x, len, os
if symbol('m.oldTs.os') ^== 'VAR' then do
call warn 'old TS not found:' os 'in' m.ctlMbr 'line' m.li
return x
end
na = strip(m.oldTs.os)
if words(m.oldTs.os) > 1 then do
call warn 'old TS has multiple new:' os '->' nn,
'in' m.ctlMbr 'line' m.li
return x
end
na2 = strip(substr(na, pos('.', na)+1))
m.li = left(m.li, x-1-len) || na2 || substr(m.li, x)
return x - len + length(na2)
endProcedure replTS
allocList: procedure expose m.
parse upper arg nPre, list
s.1 = 'dummy member zzzzzzzz'
s.0 = 1
do wx=1 to words(list)
w = word(list, wx)
if w = 'LIST' then
call writeDsn nPre'.'w'(ZZZZZZZZ) ::F133', s., 1, 1
else
call writeDsn nPre'.'w'(ZZZZZZZZ) ::F', s., 1, 1
end
return
endProcedure allocList
err:
say '*** error:' arg(1)
call warnWrite m.dPre'.JCL'
call errA arg(1), 1
endSubroutine err
envPut: procedure expose m.
parse arg na, va
call mapPut m.vars, na, va
return
endProcedure envPut
envIsDefined: procedure expose m.
parse arg na
return mapHasKey(m.vars, na)
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(m.vars, na)
endProcedure envGet
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
endProcedure envRemove
envExpand: procedure expose m.
parse arg src
cx = pos('$', src)
if cx < 1 then
return strip(src, 't')
res = left(src, cx-1)
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 || envGet(substr(src, cx+2, ex-cx-2))
ex = ex + 1
end
else do
ex = verify(src, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_',
|| 'abcdefghijklmnopqrstuvwxyz', 'n', cx+1)
if ex < 1 then
return strip(res || envGet(substr(src, cx+1)), 't')
res = res || envGet(substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return strip(res || substr(src, ex), 't')
res = res || substr(src, ex, cx-ex)
end
endProcedure envExpand
envExpAll: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx+1
m.dst.dx = envExpand(m.src.sx)
end
m.dst.0 = dx
return
endProcedure envExpAll
testExp: procedure
call mIni
m.xx.0 = 0
call envPut 'v1', eins
call envPut 'v2', zwei
call testExp1 'ohne variabeln'
call testExp1 '$v1 variabeln'
call testExp1 'mit $v1 iabeln'
call testExp1 'mit variab$v1'
call testExp1 '${v2}variabeln'
call testExp1 'mit vari${v1}'
call testExp1 'mit v${v2}eln'
call testExp1 'mit v${v1}eln'
call testExp1 'mit $v1 viel${v2}+$v1-vars${v2}'
call envExpAll mCut(yy, 0), xx
do x=1 to m.yy.0
say 'tesStem exp' m.yy.x'|'
end
return
endProcedure testExp
testExp1: procedure expose m.
parse arg src
call mAdd xx, src
say 'testExp src' src'|'
say 'testExp exp' envExpand(src)'|'
return
endProcedure testExp1
warn: procedure expose m.
parse arg msg
msg = strip(msg)
say '***warn:' msg
call mAdd warn, left(msg, 72)
do x=73 by 68 to length(msg)
call mAdd warn, ' 'substr(msg,x, 68)
end
return
endProcedure warn
warnWrite: procedure expose m.
parse arg lib
if 0 then do
x = 'abcdefghijklmnopqrstuvwxyz'
x = '0123456789' || x || translate(x)
call warn 'test mit langer warnung' x x x x x x x x x x x'|'
end
if m.warn.0 = 0 then do
say 'keine Warnungen'
return
end
say m.warn.0 'Warnungen'
do i=1 to 20
dsn = lib'(warn'right(i, 3, 0)')'
sd = sysDsn("'"dsn"'")
if sd = 'MEMBER NOT FOUND' then
leave
end
if sd = 'MEMBER NOT FOUND' then do
call writeDsn dsn, m.warn., , 1
end
else do
say 'error cannot write warnings' dsn ':' sd
do x=1 to m.warn.0
say m.warn.x
end
end
return
endProcedure warnWrite
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlIni: procedure expose m.
parse arg m
call scanOptions m, , '0123456789_' , '--'
m.scan.m.sqlBrackets = 0
return m
endProcedure scanSqlIni
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd
call adrEdit "cursor =" lx
do while adrEdit("seek" cmd 'word', 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx
call editReadDefine m, fx
call scanReader m, m
do while m.m.editReadLx <= fx
if scanSql(scanSkip(m)) = '' then
return -1
if m.sqlType = 'i' & m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
ePos: procedure expose m.
parse arg m
return m.m.editReadLx m.scan.m.pos
endProcedure ePos
/*--- scan a sql token put type in m.sqltype:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': quantified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234
"'": string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSql: procedure expose m.
parse arg m
if scanAtEnd(m) then do
m.sqlType = ''
m.val = ''
end
else if scanStringML(m, "'") then
m.sqlType = "'"
else if scanSqlQuId(m) ^== '' then
nop
else if scanSqlNumUnit(m, 1) ^== '' then
nop
else if scanChar(m, 1) then do
m.sqlType = m.tok
m.val = ''
if m.tok = '(' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets + 1
else if m.tok = ')' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets - 1
end
else
call scanErr m, 'cannot scan sql'
return m.sqlType
endProcedure scanSql
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if ^ scanName(m) then
return ''
m.val = translate(m.tok)
m.sqlType = 'i'
return m.val
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) == '' then do
if scanString(m, '"') then do
val = strip(val, 't')
m.sqlType = 'd'
end
end
return m.val
endProcedure scansqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
if scanSqlDeId(m) == '' then
return ''
res = ''
do qx=1 by 1
m.val.qx = m.val
res = res'.'m.val
if ^ scanLit(scanSkip(m), '.') then do
m.val.0 = qx
if qx > 1 then
m.sqlType = 'q'
m.val = substr(res, 2)
return m.val
end
if scansqlDeId(scanSkip(m)) == '' then
call scanErr m, 'id expected after .'
end
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd
c3 = left(scanLook(m, 3), 3)
p = left(c3, 1) == '+' | left(c3, 1) == '-'
p = p + (substr(c3, p + 1, 1) == '.')
if pos(substr(c3, p+1, 1), '0123456789') < 1 then
return ''
n = ''
if p > 0 & left(c3, 1) ^== '.' then do
call scanChar m, 1
n = m.tok
end
if scanVerify(m, '0123456789') then
n = n || m.tok
if scanLit(m, '.') then do
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.tok
end
c3 = left(translate(scanLook(m, 3)), 3)
if left(c3, 1) == 'E' then do
p = substr(c3, 2, 1) == '+' | substr(c3, 2, 1) == '-'
if pos(substr(c3, p+2, 1), '0123456789') > 0 then do
call scanChar m, p+1
n = n || m.tok
if scanVerify(m, '0123456789') then
n = n || m.tok
c3 = scanLook(m, 1)
end
end
if checkEnd ^= 0 then
if pos(left(c3, 1), m.scan.m.name) > 0 then
call scanErr m, 'end of number' n 'expected'
m.val = n
return n
endProcedure scanSqlNum
/*--- scan a sql number with unit K M or G ---------------------------*/
scanSqlNumUnit: procedure expose m.
parse arg m, both
nu = scanSqlNum(m, 0)
if nu = '' then
return ''
sp = scanSpaceNl(m)
af = translate(scanSqlId(m))
if wordPos(af, "K M G") > 0 then do
m.sqlType = 'u'
m.val = nu || af
return m.val
end
else if af <> '' & ^ sp then
call scanErr m, 'end of number' nu 'expected'
if both ^== 1 then
call scanErr m, 'unit K M or G expected'
else if af ^== '' then
call scanBack m, m.tok
m.sqlType = 'n'
m.val = nu
return nu
endProcedure scanSqlNumUnit
scanSqlskipBrackets: procedure expose m.
parse arg m, br
call scanSpaceNl m
if br ^== '' then
nop
else if ^ scanLit(m, '(') then
return 0
else
br = 1
do forever
t = scanSql(scanSpaceNl(m))
if t = '' | t = ';' then
call scanErr m, 'closing )'
else if t = '(' then
br = br + 1
else if t ^== ')' then
nop
else if br > 1 then
br = br - 1
else if br = 1 then
return 1
else
call scanErr m, 'skipBrackets bad br' br
end
endProcedure skipBrackets
/* copy scanSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
m.scan.m.pos = 1
call scanInit m
return m
endProcedure scanLine
/*--- switch to next line if atEnd of line or unCond=1 ---------------*/
scanNL: procedure expose m.
parse arg m, unCond
if m.scan.m.reading then do
interpret m.scan.m.scanNl
end
else do
np = 1 + length(m.scan.m.src)
if np <= m.scan.m.pos then
return 0
if unCond == 1 then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
m.scan.m.pos = np
return 1
end
endProcedure scanNL
scanAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.reading then
interpret m.scan.m.scanAtEnd
else
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEnd
/*--- initialize scanner for m --------------------------------------*/
scanInit: procedure expose m.
parse arg m, rdng
m.scan.m.reading = rdng == 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
call scanInit m
m.scan.m.comment = comm
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
m.scan.m.name = m.scan.m.name1 || '0123456789'
end
if namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
return
endProcedure scanOptions
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
return substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
m.tok = scanLook(m, len)
m.scan.m.pos = m.scan.m.pos + length(m.tok)
return length(m.tok) > 0
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a string with quote char qu -------------------------------*/
scanStringML: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
lCnt = 0
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then do
m.val = m.val || substr(m.scan.m.src, qx)
if lCnt == 9 | ^ scanNl(m, 1) then
call scanErr m, 'ending Apostroph('qu') missing multi'
qx = 1
bx = 1
end
else do
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
ScanNat: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
/*--- 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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
scanLinePos: procedure expose m.
parse arg m
interpret 'return' m.scan.m.scanLinePos
endProcedure scanLinePos
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok 'scanPosition' ,
strip(left(substr(m.scan.m.src, m.scan.m.pos), 40), 't')
if m.scan.m.reading then
say scanLinePos(m)
else
say ' pos' m.scan.m.Pos 'in string' strip(m.scan.m.src, 't')
call err 'scanErr' txt
return
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- begin scanning the lines of a reader ---------------------------*/
scanReader: procedure expose m.
parse arg m, m.scan.m.rdr
call scanInit m, 1
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanReaderNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanReaderAtEnd(m, what)'
m.scan.m.scanLinePos = "scanReaderLinePos(m)"
call scanReaderNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanReaderAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if what == 'l' then
return 1
return m.scan.m.atEnd
endProcedure scanReaderAtEnd
scanReaderNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then nop
else if unCond ^= 2 & m.scan.m.pos > length(m.scan.m.src) then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' & abbrev(substr( ,
m.scan.m.src, m.scan.m.pos), m.scan.m.comment) then nop
else
return 0
if m.scan.m.atEnd then
return 0
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, 'SCAN.'m'.SRC')
if m.scan.m.atEnd then do
m.scan.m.pos = 1 + length(m.scan.m.src)
end
else do
m.scan.m.pos = 1
m.scan.m.lineX = m.scan.m.lineX + 1
end
return ^ m.scan.m.atEnd
endProcedure scanReaderNL
scanReaderLinePos: procedure expose m.
parse arg m
if m.scan.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.scan.m.pos 'in'
return qq 'line' m.scan.m.lineX':' strip(m.scan.m.src, 't')
endProcedure scanReaderLinePos
/* copy scan end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jNew: procedure expose m.
if m.j.jIni ^== 1 then
call jIni
return 'J.'mInc(j)
endProcedure jNew
jFree: procedure expose m.
parse arg m
return
endProcedure jFree
jRead: procedure expose m.
parse arg m, arg
res = '?'
interpret m.j.m.read
return res
endProcedure jRead
jWrite: procedure expose m.
parse arg m, arg
interpret m.j.m.write
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Reset m, arg'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Open m, arg'
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret 'call' m.j.m.pref'Close m'
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jClose
jDefine: procedure expose m.
parse arg m, m.j.m.pref
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jDefine
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
jOpt: 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
jIni: procedure expose m.
parse arg force
if m.j.jIni == 1 & force ^== 1 then
return
m.j.jIni = 1
m.j.0 = 0
m.j.defDD.0 = 0
m.j.jIn = jNew()
m.j.jOut = jNew()
call jDefine m.j.jIn, "jStdIOError "
call jDefRead m.j.jIn, "res = 0"
call jDefine m.j.jOut, "jStdIOError "
call jDefWrite m.j.jOut, "say arg"
return
endProcedure jIni
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
jBuf: procedure expose m.
m = jNew()
call jDefine m, "jBuf"
do ax=1 to arg()
m.j.m.buf.ax = arg(ax)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.j.m.buf.ax = arg(ax+1)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == 'r' then do
call jDefRead m, "res = jBufRead(m , arg)"
m.j.m.bufIx = 0
return m
end
if opt == 'w' then
m.j.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
call jDefWrite m, "call mAdd 'J.'m'.BUF', arg"
return m
endProcedure jBufOpen
jBufClose:
return arg(1)
endProcedure jBufClose
jBufStem: procedure expose m.
parse arg m
return 'J.'m'.BUF'
endProcedure jBufStem
jBufRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then
return 0
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jBufRead
jDsn: procedure expose m.
parse arg spec
m = jNew()
m.j.m.state = ''
call jDefine m, "jDsn"
m.j.m.defDD = 'J'mInc('J.DEFDD')
call jDsnReset m, spec
return m
endProcedure jDsn
jDsnReset: procedure expose m.
parse arg m, spec
call jClose m
m.j.m.dsnSpec = spec
return m
endProcedure jDsnReset
jDsnOpen: procedure expose m.
parse arg m, opt
call jDsnClose m
if opt == 'r' then do
aa = dsnAlloc(m.j.m.dsnSpec, 'SHR', m.j.m.defDD)
call readDDBegin word(aa, 1)
call jDefRead m, "res = jDsnRead(m , arg)"
end
else do
if opt == 'w' then
aa = dsnAlloc(m.j.m.dsnSpec, 'OLD', m.j.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.j.m.dsnSpec, 'MOD', m.j.m.defDD)
else
call err 'jBufOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call jDefWrite m, "call jDsnWrite m , arg"
end
m.j.m.state = opt
m.j.m.dd = word(aa, 1)
m.j.m.free = subword(aa, 2)
return m
endProcedure jBufOpen
jDsnClose:
parse arg m
if m.j.m.state ^== '' then do
if m.j.m.state == 'r' then do
call readDDend m.j.m.dd
end
else do
if m.j.m.buf.0 > 0 then
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
call writeDDend m.j.m.dd
end
interpret m.j.m.free
end
m.j.m.buf.0 = 0
m.j.m.bufIx = 0
m.j.m.state = ''
m.j.m.free = ''
m.j.m.dd = ''
return m
endProcedure jDsnClose
jDsnRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then do
res = readDD(m.j.m.dd, 'M.J.'m'.BUF.')
if ^ res then
return 0
ix = 1
end
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jDsnRead
jDsnWrite: procedure expose m.
parse arg m, var
ix = m.j.m.buf.0 + 1
m.j.m.buf.0 = ix
m.j.m.buf.ix = var
if ix > 99 then do
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
m.j.m.buf.0 = 0
end
return
endProcedure jDsnWrite
/* copy j end *********************************************************/
/* copy adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* 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 do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("SUBCOM DSNREXX", '*') <> 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
call adrSql "connect" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
sqlFields: procedure
parse arg flds
sql = ''
do wx=1 to words(flds)
sql = sql', :'word(flds, wx)
end
if wx > 1 then
sql = substr(sql, 3)
return sql
endProcedure sqlFields
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/* copy adrSql 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
parse 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
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
ds = ''
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
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 m begin ********************************************************
stem and type handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a.0 = m.a.0 + 1
return m.a.0
endProcedure mInc
mDefIfNot: procedure expose m.
parse arg a, put
if symbol('m.a') == 'VAR' then
return 0
m.a = put
return 1
endProcedure mDefIfNot
/*--- 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
/*--- 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 mAddAt
/*--- put into stem a the fields flds from arguments -----------------*/
mPut: procedure expose m.
parse arg a, flds
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = arg(wx+2)
end
return a
endProcedure mPut
/*--- put into stem a the fields flds from stem b --------------------*/
mPutSt: procedure expose m.
parse arg a, flds, b
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = m.b.f
end
return a
endProcedure mPutSt
/*--- put into stem a the fields flds from variable pool -------------*/
mPutVars:
parse arg ggA, ggFlds
do ggWx = 1 to words(ggFlds)
ggF = word(ggFlds, ggWx)
m.ggA.ggF = value(ggF)
end
return ggA
endProcedure mPutVars
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
if m.m.mIni ^== 1 then
call mIni
return mapReset(mAdd(m.map, 'map'))
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.a.mapKey') == 'VAR' then
call mapClear a
m.a.mapKey = translate(opt) = 'K'
if m.a.mapKey then
m.a.mapKey.0 = 0
else
m.a.mapKey.0 = 'noMapKeys'
return a
endProcedure
mapClear: procedure expose m.
parse arg a
do kx=1 to m.a.mapKey.0
k = m.a.mapKey.kx
drop m.a.mapK2V.k m.a.mapKey.kx
end
m.a.mapKey.0 = 0
return a
endProcedure mapClear
mapKeys: procedure expose m.
parse arg a
return a'.'mapKey
endProcedure mapKeys
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.mapK2V.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.mapK2V.ky = val
if m.a.mapKey then
call mAdd a'.'mapKey, ky
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg m, ky, val
if m.m.mapKey then
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call mAdd m'.'mapKey, ky
m.m.mapK2V.ky = val
return
endProcedure mapPut
mapHasKey: procedure expose m.
parse arg m, ky
return symbol('m.m.mapK2V.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg m, ky
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call err 'missing key in mapGet('m',' ky')'
return m.m.mapK2V.ky
endProcedure mapGet
mapGetOr: procedure expose m.
parse arg m, ky, orDef
if symbol('m.m.mapK2V.ky') == 'VAR' then
return m.m.mapK2V.ky
else
return orDef
endProcedure mapGetOr
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mGetType:
parse arg name
return mapGet(m.type, name)
endProcedure mGetType
mTypeNew: procedure expose m.
parse arg name, stem, flds, types
if m.m.ini ^== 1 then
call mIni
ty = mAdd(m.type, name)
call mapAdd m.type, name, ty
m.ty.ass = '='
m.ty.type = stem
m.ty.0 = words(flds)
m.ty.type.0 = m.ty.0
do y=1 to m.ty.0
m.ty.y = word(flds, y)
if word(types, y) = '' then
m.ty.type.y = m.type.1
else
m.ty.type.y = word(types, y)
end
return ty
endProcedure mTypeNew
mShow: procedure expose m.
parse arg ty, a, lv
if lv='' then
lv = 0
pr = a
if lv > 0 & lastPos('.', pr) > 0 then
pr = substr(pr, lastPos('.', pr))
say left('', lv)pr '=' m.a
do y=1 to m.ty.0
call mShow m.ty.type.y, a'.'m.ty.y, lv+1
end
if m.ty.type ^== '' then do
do y=1 to m.a.0
call mShow m.ty.type, a'.'y, lv+1
end
end
return
endProcedure mShow
mClear: procedure expose m.
parse arg ty, a, val
m.a = val
do y=1 to m.ty.0
call mClear m.ty.type.y, a'.'m.ty.y
end
if m.ty.type ^== '' then
m.a.0 = 0
return
endProcedure mClear
mTypeSay: procedure expose m.
parse arg t
say 'type' t'='m.t 'ass' m.t.ass '#' m.t.0 'tys' m.t.type
return
endProcedure mInit
mTypeCopy: procedure expose m.
parse arg ty, t, f
if m.ty.ass == '=' then
m.t = m.f
else
call err 'type.ass' m.ty.ass 'not supported'
do x = 1 to m.ty.0
fld = m.ty.x
call mTypeCopy m.ty.type.x, t'.'fld, f'.'fld
end
if m.ty.type ^== '' then do
do y = 1 to m.f.0
call mTypeCopy m.ty.type, t'.'y, f'.'y
end
m.t.0 = m.f.0
end
return t
endProcedure mTypeCopy
mIni: procedure expose m.
m.m.ini = 1
m.m.type.0 = 0
m.m.map.0 = 0
call mapReset m.type
call mapReset m.vars
siTy = mTypeNew('Simple')
stTy = mTypeNew('Stem', siTy)
tyTy = mTypeNew('Type', siTy, 'ASS TYS', siTy stTy)
ttTy = mTypeNew('StemType', tyTy)
return
endProcedure mIni
mTest: procedure
call mIni
siTy = mGetType('Simple')
tyTy = mGetType('Type')
ttTy = mGetType('StemType')
say 'siTy' siTy 'tyTy' tyTy 'stTyTy' ttTy
call mTypeSay siTy
call mTypeCopy siTy, nnn, siTy'.'ass
say 'm.nnn nach copy' m.nnn
call mTypeCopy tyTy, mmm, siTy
call mTypeSay mmm
call mTypeCopy tyTy, qqq, tyTy
call mTypeSay qqq
call mShow tyTy, qqq
call mShow ttTy, m.type
return
endProcedure mTest
/* copy m 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 *****************************************************/
}¢--- A540769.WK.REXX.O13(NAKJOB) cre=2010-01-20 mod=2010-01-20-12.18.09 A540769 ---
/* rexx ****************************************************************
nak what fun
***********************************************************************/
parse upper arg what fun
if what = '' then
parse upper value 'tst 1' with what fun
call mIni
m.tas3 = left(what, 2)right(what, 1)
m.task = 'NAK'what
nPre = 'DSN.'m.task
m.skels = 'A540769.wk.skels'
nLctl = nPre'.LCTL'
if sysvar('SYSNODE') = 'RZ1' then do
m.dbSys = 'DBAF'
newCreator = 'TSTNAKNE'
call envPut 'MGMTCLAS', 'D035Y000'
m.dPre = 'A540769.TMPNAK.'m.task
end
else if 0 then do /* rz2 proc */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D035Y000'
m.dPre = 'DSN.'m.task
end
else do /* transfer rz2 --> rz1 */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'SHR21.DIV.P021.'m.task
end
if fun = 9 then do
call testExp
exit
end
m.job.0 = 0
m.jobFlds = 'JOB CR TB DB TS NCR NTB NDB NTS'
call mTypeNew 'StemJob', mTypeNew('Job', '', m.jobFlds)
call adrSqlConnect m.dbSys
if fun = 1 then do
call function1 newCreator, nPre, nLctl
end
else if fun = 2 then do
call unload 'UNL', nLctl'(unload)'
call loadLines m.dPre'.ULI'
call load 'LOA', nLctl'(load)'
end
else
call err 'bad fun' fun
call adrSqlDisConnect m.dbSys
exit
function1: procedure expose m.
parse arg newCreator, nPre, nLctl
call infoDb nLctl'(DB)'
if 0 then
call mShow mGetType('StemDB'), db
call infoTS
if 0 then
call mShow mGetType('StemTS'), ts
if 0 then
do x=1 to m.ts.0
say m.ts.x.db'.'m.ts.x.ts m.ts.x.bp m.ts.x.used
end
call mapReset crNa
call infoTB
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
do x=1 to m.tb.0
n = m.tb.x.tsNd
say m.tb.x.cr'.'m.tb.x.tb m.tb.x.db'.'m.tb.x.ts n '->' m.n
end
call infoDep
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
do x=1 to m.dep.0
say m.dep.x.ty m.dep.x.cr'.'m.dep.x.na,
m.dep.x.bTy m.dep.x.bCr'.'m.dep.x.bNa
end
call infoNeu nLctl'(ddlNeu)'
if 0 then
call mShow mGetType('StemNN'), nn
call mapAltNeu newCreator
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
call mShow mGetType('StemNN'), nn
if 1 then
call mShow mGetType('StemJob'), job
call infoRI
if 0 then
call mShow mGetType('StemRI'), ri
call showAltNeu nLctl'(info)'
call showJob nLctl'(job)'
if 1 then
call mShow mGetType('StemJob'), job
call alias nLctl'(alia)'
call unload 'ULI', nLctl'(unloLim0)'
call err 'check not yet'
call check 'CHK', nLctl'(check)'
return
endProcedure function0
infoDB: procedure expose m.
parse arg inp
call readDsn inp, c.
dbII = 'in ('
call mapReset(db.a2n)
call mapReset(db.n2a)
call mTypeNew 'StemDB', mTypeNew(db, '', 'ALT NEU')
m.db.0 = 0
do c=1 to c.0
dbAlt = word(c.c, 1)
dbNeu = word(c.c, 2)
dd = mAdd(db, dbAlt'->'dbNeu)
m.dd.alt = dbAlt
m.dd.neu = dbNeu
call mapPut db.a2n, dbAlt, dbNeu
call mapPut db.n2a, dbNeu, dbAlt
if c>1 then
dbII = dbII', '
dbII = dbII"'"dbAlt"'"
end
m.dbIn = dbII')'
say m.db.0 'db' m.dbIn
return
endProcedure infoDB
infoTS: procedure expose m.
root = 'TS'
flds = DB TS NTB PARTS BP USED
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTS', mTypeNew(ts, '', flds)
call mapReset root
end
sqlFlds = sqlFields(flds)
sql = "select dbName, name, nTables, partitions," ,
"bPool, float(nActive)*pgSize*1024" ,
"from sysibm.systablespace",
"where dbname" m.dbIn ,
"order by 1, 2 "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
used = format(used,2,3,2,0)
nd = mPutVars(mAdd(root, db'.'ts), flds)
call mapAdd root, db'.'ts, nd
end
call adrSql 'close c1'
say m.root.0 'tablespaces'
return
endProcedure infoTS
infoTB: procedure expose m.
root = tb
flds = cr tb db ts
xFlds = tsNd newNd
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTB', mTypeNew(tb, '', flds xflds)
call mapReset root
end
newNd = ''
sqlFlds = sqlFields(flds)
sql = "select creator, name, dbName, tsName",
"from sysibm.systables",
"where dbname" m.dbIn "and type = 'T'"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
ts = strip(ts)
tsNd = mapGet('TS', db'.'ts)
nd = mPutVars(mAdd(root, cr'.'tb), flds xFlds)
if mapHasKey(root, tb) then
say '??? duplicate table' cr'.'tb
else
call mapAdd root, tb, nd
call mapAdd crNa, cr'.'tb, nd
end
call adrSql 'close c1'
say m.root.0 'tables'
return
endProcedure infoTb
stripVars:
parse arg ggList
do ggX=1 to words(ggList)
ggW = word(ggList, ggX)
x=value(ggW, strip(value(ggW)))
end
return
endSubroutine stripVars
infoDep: procedure expose m.
flds = ty cr na bTy bCr bNa
if mDefIfNot(dep'.'0, 0) then
call mTypeNew 'StemDep', mTypeNew('Dep', '', flds 'NEWND ACT')
sqlFlds = sqlFields(flds)
newNd = ''
act = ''
sql = ,
"with o (lev, dType, dCreator, dName, bType, bCreator, bName) as",
"( select 0, t.type, creator, name, '.', '', t.dbName",
"from sysibm.sysTables t",
"where t.dbname" m.dbIn,
"union all select o.lev+1, d.dType, d.dCreator, d.dName,",
"o.dType, o.dCreator, o.dName",
"from o, sysibm.sysviewdep d",
"where d.bcreator = o.dCreator and d.bName = o.dName",
"and o.lev < 999999",
"union all select o.lev+1, a.Type, a.creator, a.name,",
"o.dType, o.dCreator, o.dName",
"from o, sysibm.systables a",
"where a.tbCreator = o.dCreator and a.tbName = o.dName",
"and a.type = 'A' and o.lev < 999999",
") select dType, dCreator, dName, bType, bCreator, bName",
"from o"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if mapHasKey(crNa, cr'.'na) then do
qTy = 'TY'
qBTy = 'BTY'
qbCr = 'BCR'
qbNa = 'BNA'
oo = mapGet(crNa, cr'.'na)
if left(oo, 3) = 'TB.' then do
if ty = 'T' & bTy = '.' & bNa = m.oo.db then
nop /* say 'old table in dep' cr'.'na */
else
call err 'dep with name of old table' ty cr'.'na
end
else if ty ^== m.oo.qTy then
call err 'new dep' m.oo.qTy cr'.'na 'mismatches old' ,
m.oo.qTy m.oo
else if ty == 'A' & ^ (bTy == m.oo.qBty & bCr == m.oo.qBcr ,
& bNa == m.oo.qBNa) then
call err 'dep with duplicate different alias' cr'.'na ,
'b' bTy bCr'.'bNa ,
'oo' m.oo.qBty m.oo.qBcr'.'m.oo.qBNa
else if 0 then
say 'skipping duplicate' cr'.'na
end
else do
nd = mPutVars(mAdd(dep, cr'.'na), flds 'NEWND' 'ACT')
call mapAdd crNa, cr'.'na, nd
end
end
call adrSql 'close c1'
say m.dep.0 'dependencies'
return
endProcedure oldInfo
infoNeu: procedure expose m.
parse arg ddlNeu
flds = cr na ty for oldNd oldAl
if mDefIfNot(nn.0, 0) then do
call mapReset(nn)
call mTypeNew 'StemNN', mTypeNew('NN', '', flds)
end
oldNd = ''
oldAl = ''
r = jDsn(ddlNeu)
call jOpen r, 'r'
call scanSqlReader s, r
lastX = 0
do forever
if lastX = m.scan.s.lineX then
if ^ scanNl(s, 1) then
leave
lastX = m.scan.s.lineX
if pos('CREATE', translate(m.scan.s.src)) < 1 then
iterate
fnd = 0
do while lastX = m.scan.s.lineX & ^fnd
if scanSql(scanSkip(s)) = '' then
leave
fnd = m.sqlType = 'i' & m.val == 'CREATE'
end
if ^ fnd then do
say 'no create, ignoring line' lastx strip(m.scan.s.src)
iterate
end
if scanSqlId(scanSkip(s)) == '' then do
say 'no sqlId, ignoring line' lastx strip(m.scan.s.src)
iterate
end
subTy = ''
if wordPos(m.val, 'UNIQUE LARGE LOB') > 0 then do
subTy = m.val
plus = ''
if subTy = 'UNIQUE' then
plus = 'WHERE NOT NULL'
do wx=1 by 1
if scanSqlId(scanSkip(s)) == '' then
call scanErr s, 'no sqlId after create' subTy
else if m.val = word(plus, wx) then
subTy = subTy m.val
else if wx=1 | wx > words(plus) then
leave
else
call scanErr s, 'stopped in middle of' plus
end
end
ty = m.val
m.scan.m.sqlBrackets = 0
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'no qualId after create' subTy ty
na = m.val
na1 = m.val.1
na2 = m.val.2
for = '-'
if ty = 'ALIAS' then do
if scanSqlId(scanSkip(s)) ^== 'FOR' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'A'
end
else if ty = 'INDEX' then do
if scanSqlId(scanSkip(s)) ^== 'ON' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'X'
end
else if ty = 'TABLE' then do
do while ^ (m.scan.s.sqlBrackets = 0 & m.sqlType = 'i' ,
& m.val == 'IN')
if scanSql(scanSkip(s)) = '' | m.tok == ';' then
call scanErr s, 'in database expected'
end
if scanSqlQuId(scanSkip(s)) == '' | m.val = 'DATABASE' then
call scanErr s, 'ts name expected after create' ty na
for = m.val
ty = 'T'
end
else if ty = 'TABLESPACE' then do
if scanSqlId(scanSkip(s)) ^== 'IN' then
call scanErr s, 'IN expected after create' ty
if scanSqlDeId(scanSkip(s)) == '' then
call scanErr s, 'db name expected after create' ty
na = m.val'.'na
ty = 'S'
end
else if ty = 'VIEW' then do
ty = 'V'
for = ''
end
if 0 then
say 'create' subTy ty 'name' na 'for' for
if for ^== '-' then do
nd = mPut(mAdd(nn, na), flds, na1, na2, ty, for)
call mapAdd nn, na, nd
end
end
call jClose r
return
endProcedure infoNeu
infoRI: procedure expose m.
parse arg ddlNeu
flds = cr tb db bCr bTS bTb bDb bTS rNa
if mDefIfNot(ri.0, 0) then
call mTypeNew 'StemRI', mTypeNew('RI', '', flds)
sql = "select r.creator, r.tbName, td.dbName, td.tsName" ,
", refTbcreator, refTbName, tr.dbName, tr.tsName, relName",
"from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr",
"where r.creator = td.creator and r.tbName = td.name",
"and r.refTbcreator = tr.creator and r.reftbName = tr.name",
"and (td.dbname" m.dbIn "or tr.dbname" m.dbIn")"
/*
select char(td.dbName, 8),
char(strip(r.creator) ||'.'|| strip(r.tbName), 20) "dep",
char(case when td.dbName = tr.dbName then '=' else tr.dbName end
, 8),
char(strip(refTbcreator) ||'.'|| strip(refTbName), 20) "ref par",
char(relName, 30)
from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr
where r.creator = td.creator and r.tbName = td.name
and r.refTbcreator = tr.creator and r.reftbName = tr.name
and (td.dbname like 'BJAA_0001'
or td.dbname = 'DBJ01' or td.dbname like 'DNF%'
or tr.dbname like 'BJAA_0001'
or tr.dbname = 'DBJ01' or tr.dbname like 'DNF%')
*/
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
nd = mPutVars(mAdd(ri, cr'.'tb'.'rNa), flds)
end
call adrSql 'close c1'
say m.ri.0 'references'
return
endProcedure infoRI
mapAltNeu: procedure expose m.
parse arg newCr
do tx=1 to m.tb.0
cc = tb'.'tx
if ^ mapHasKey(nn, newCr'.'m.cc.tb) then
call err 'old table' m.cc 'has no corr. new'
dd = mapGet(nn, newCr'.'m.cc.tb)
if ^mapHasKey(db.a2n, m.cc.db) then
call err 'old table' m.cc 'ts in bad db' m.cc.db'.'m.cc.ts
if m.dd.oldNd ^== '' then
call err 'old table' m.cc 'maps to new' m.dd ,
'which already maps to' m.dd.oldNd
nTs = m.dd.for
if mapGet(db.a2n, m.cc.db) <> left(nTs, pos('.', nTs)-1) then
call err 'new table' m.dd 'in wrong db' nTs
m.cc.newNd = dd
m.dd.oldNd = cc
end
do dx=1 to m.dep.0
dd = dep'.'dx
if ^ mapHasKey(nn, newCr'.'m.dd.na) then
call err 'old dep' m.dd.ty m.dd 'has no corr. new'
ww = mapGet(nn, newCr'.'m.dd.na)
a = m.dd.ty
if a == 'V' then do
if m.ww.ty ^== 'V' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww
if m.ww.oldNd ^== '' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww ,
'which is already mapped to' m.ww.oldNd
m.ww.oldNd = dd
m.dd.newNd = ww
end
else if a == 'A' then do
if m.dd.na ^== m.dd.bNa then
call err 'bad old alias' m.dd ,
'for' m.dd.bCr'.'m.dd.bNa
m.ww.oldAl = m.ww.oldAl m.dd
end
else do
call err 'bad dep type' m.dd.ty m.dd
end
end
do nx=1 to m.nn.0
ww = nn'.'nx
if m.ww.ty = 'T' | m.ww.ty = 'V' then do
oo = m.ww.oldNd
if oo == '' then
call err 'no old for new' m.ww.ty m.ww
else if m.oo.cr ^== newCr & m.ww.oldAl = '' then
say '*warn: no old alias for new obj' m.ww.ty m.ww
end
end
bLim = 1E+9
tLim = 30
tbs = 0
bys = 0
jobNo = 1
do tx=1 to m.ts.0
tt = ts'.'tx
if tbs > 0 & (bys + m.tt.used > bLim ,
| tbs + m.tt.nTb > tLim) then do
jobNo = jobNo + 1
bys = 0
tbs = 0
end
bys = bys + m.tt.used
tbs = tbs + m.tt.nTb
m.tt.job = jobNo
end
do ox=1 to m.tb.0
ot = tb'.'ox
os = m.ot.tsNd
nt = m.ot.newNd
ns = m.nt.for
if symbol('os.os') ^== 'VAR' then
os.os = ns
else if wordPos(ns, os.os) < 1 then
os.os = os.os ns
if symbol('ns.ns') ^== 'VAR' then do
ns.ns = os
nt.ns = nt
end
else do
if ns.ns ^== os then
call err 'new TS maps to old' ns.ns 'and' os
if wordPos(nt, nt.ns) < 1 then
nt.ns = nt.ns nt
end
end
do ox=1 to m.ts.0
os = ts'.'ox
do nx=1 to words(os.os)
ns = word(os.os, nx)
do ny=1 to words(nt.ns)
nt = word(nt.ns, ny)
ot = m.nt.oldNd
say 'old' m.ot.cr m.ot.tb m.os.db m.os.ts ,
'new' m.nt.cr m.nt.na ns
nq = pos('.', ns)
call mPut mAdd(job, m.ot), m.jobFlds, m.os.job,
, m.ot.cr, m.ot.tb, m.os.db, m.os.ts,
, m.nt.cr, m.nt.na, left(ns,nq-1), substr(ns,nq+1)
end
end
end
return
endProcedure mapAltNeu
showAltNeu: procedure expose m.
parse arg out
m.o.0 = 0
do dx=1 to m.db.0
dd = db'.'dx
call mAdd o, 'mD' left(m.dd.alt, 20)left(m.dd.neu, 20)
end
do tx=1 to m.tb.0
tt = tb'.'tx
ss = m.tt.tsNd
l = 'oT' left(m.tt, 20)left(m.ss, 20) ,
|| right(m.ss.job, 4) m.ss.used,
|| right(m.ss.ntb, 4) || right(m.ss.parts, 4) m.ss.bp
call mAdd o, l
end
do tx=1 to m.tb.0
tt = tb'.'tx
ww = m.tt.newNd
l = 'mt' left(m.tt, 20)left(m.ww, 20),
|| left(m.tt.ts, 8) m.ww.for
call mAdd o, l
end
do dx=1 to m.dep.0
dd = dep'.'dx
ww = m.dd.newNd
if m.dd.ty == 'V' then
l = 'mV' left(m.dd, 20)left(m.ww, 20)
else if m.dd.ty == 'A' then
l = 'dA' left(m.dd, 20)left(m.dd.bCr'.'m.dd.bNa, 20)
else
call err 'bad ty in dep' m.dd.ty m.dd
call mAdd o, l
end
do rx=1 to m.ri.0
rr = ri'.'rx
if ^mapHasKey(db.a2n, m.rr.db) ,
| ^mapHasKey(db.a2n, m.rr.bDb) then
q = '|f'
else if m.rr.db <> m.rr.bDb then
q = '|d'
else
q = '= '
call mAdd o, 'mR' left(m.rr.cr'.'m.rr.tb, 20) ,
|| left(m.rr.bCr'.'m.rr.bTb, 20) q m.rr.rNa
end
call writeDsn out, m.o., ,1
return
endProcedure showAltNeu
showJob: procedure expose m.
parse arg out
m.o.0 = 0
do jx=1 to m.job.0
jj = 'JOB.'jx
call mAdd o, right(m.jj.job, 4) ,
left(m.jj, 20) left(m.jj.db'.'m.jj.ts, 17) ,
left(m.jj.nCr, 10) left(m.jj.nDb'.'m.jj.nTs, 17)
end
call writeDsn out, m.o., ,1
call loadJob out
return
endProcedure showAltNeu
loadJob: procedure expose m.
parse arg inp
call readDsn inp, i.
do i=1 to i.0
parse var i.i job cr '.' tb db '.' ts nCr nDb '.' nTs .
call stripVars 'CR DB NDB'
nTb = tb
say job cr'.'tb db'.'ts 'old' nCr'.'tb nDb'.'nTs
call mPutVars mAdd('JOB', cr'.'db), m.jobFlds
end
return
endProcedure loadJob
alias: procedure expose m.
parse arg out
m.dr.0 = 0
m.cr.0 = 0
c = 0
call sqlId cr, dr
do dx=1 to m.dep.0
dd = dep'.'dx
if m.dd.ty ^== 'A' then
iterate
c = c + 1;
if c // 50 = 0 then
call commit cr, dr
call mAdd dr, 'DROP ALIAS' m.dd';'
call mAdd cr, 'CREATE ALIAS' m.dd 'FOR' m.dd.bCr'.'m.dd.bNa';'
end
call commit cr, dr
call writeDsn dsnSetMbr(out, dsnGetMbr(out) || 'CREA'), m.cr., ,1
call writeDsn dsnSetMbr(out, dsnGetMbr(out) || 'DROP'), m.dr., ,1
return
endProcedure alias
commit: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), 'COMMIT;'
end
return
endProcedure commit
sqlId: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), "SET CURRENT SQLID = 'S100447';"
end
return
endProcedure sqlId
unload: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.'fun
do sx=1 to m.ts.0
ss = ts'.'sx
if jj <> m.ss.job then do
jj = m.ss.job
call envPut 'JOBNAME', 'Y' || m.tas3 || fun || jj
call envExpAll o, jc
call envExpAll o, skSt
end
call envPut 'TS', m.ss
if m.ss.parts = 0 then
call envPut 'PARTONE', ''
else
call envPut 'PARTONE', 'PART 1'
call envExpAll o, skTS
do tx=1 to m.tb.0
tt = tb'.'tx
if m.tt.tsNd ^== ss then
iterate
call envPut 'TB', m.tt.cr'.'m.tt.tb
call envExpAll o, skTb
say 'job' jj 'ts' m.ss 'tb' m.tt
end
end
call writeDsn out, m.o., ,1
return
endProcedure unload
loadLines: procedure expose m.
parse arg punPre
do sx=1 to m.ts.0
ss = ts'.'sx
pun = punPre'.'m.ss.ts'.PUN'
call readDsn pun, p.
wh = ''
tbCnt = 0
do p=1 to p.0
w1 = word(p.p, 1)
if w1 = 'LOAD' then do
wh = 'l'
end
else if w1 = 'INTO' then do
wh = 'i'
if word(p.p, 2) ^== 'TABLE' then
call err 'TABLE expected in line' p 'in' pun':' p.p
w3 = word(p.p, 3)
dx = pos('.', w3)
if dx < 1 then
call err '. expected in w3 line' p 'in' pun':' p.p
crTb = strip(left(w3, dx-1), 'b', '"')'.',
||strip(substr(w3, dx+1), 'b', '"')
if ^ mapHasKey(crNa, crTb) then
call err 'old table' crTb 'not found' ,
'for punchLine' p 'in' pun':' p.p
tt = mapGet(crNa, crTb)
if m.tt.tsNd ^== ss then
call err 'old table' crTb ,
'wrong ts' m.tt.db'.'m.tt.ts,
'for punchLine' p 'in' pun':' p.p
if ^mDefIfNot(tt'.LO.0', 0) then
call err 'already loaded table' crTb ,
'for punchLine' p 'in' pun':' p.p
tbCnt = tbCnt + 1
end
else if w1 = ')' then do
if strip(p.p) <> ')' then
call err 'bad ) line' p 'in' pun':' p.p
if wh <> 'i' then
call err ') in state' wh 'line' p 'in' pun':' p.p
call mAdd tt'.LO', p.p
wh = ''
end
else if wh == 'i' then do
call mAdd tt'.LO', p.p
end
else if wh == 'l' then do
if w1 ^== 'EBCDIC' then
call err 'bad line after load' ,
'in punchLine' p 'in' pun':' p.p
end
end
if wh ^== '' then
call err 'punch' pun 'ends in state' wh
if tbCnt <> m.ss.nTb then
call err tbCnt 'tables not' m.ss.nTb 'loaded for' m.ss
say 'loadCards for' tbCnt 'tables for' m.ss
end
return
endProcedure loadLines
load: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.UNL'
do nx=1 to m.newTs.0
ns = newTs'.'nx
if jj <> m.ns.job then do
jj = m.ns.job
call envPut 'JOBNAME', 'Y' || m.tas3 || fun || jj
call envExpAll o, jc
call envExpAll o, skSt
end
call envPut 'TREC', TREC || nx
call envPut 'TS', m.ns
tt = word(m.ns.tbNds, 1)
oo = m.tt.oldNd
call envPut 'OLDTS', m.oo.ts
call envExpAll o, skTS
do tx=1 to words(m.ns.tbNds)
tt = word(m.ns.tbNds, tx)
call envPut 'TB', m.tt
call envExpAll o, skTb
call mAddSt o, m.tt.oldNd'.LO'
say 'job' jj 'ts' m.ns 'tb' m.tt
end
end
call writeDsn out, m.o., ,1
return
endProcedure load
check: procedure expose m.
parse arg out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nakChKSt)', m.skut.
call readDsn m.skels'(nakChKTb)', m.sktb.
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'JOBNAME', 'Y' || m.tas3 || 'CHK' || jj
m.o.0 = 0
call envExpAll o, jc
call envExpAll o, skCh
do rx=1 to m.ri.0
rr = 'RI.'rx
dbTs = m.rr.db'.'m.rr.ts
if R.dbTs == 1 then
iterate
R.dbTs = 1
call envPut 'TS', dbTs
call envExpAll o, skTb
end
call writeDsn out, m.o., ,1
return
endProcedure check
err:
call errA arg(1), 1
endSubroutine err
envPut: procedure expose m.
parse arg na, va
call mapPut m.vars, na, va
return
endProcedure envPut
envIsDefined: procedure expose m.
parse arg na
return mapHasKey(m.vars, na)
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(m.vars, na)
endProcedure envGet
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
endProcedure envRemove
envExpand: procedure expose m.
parse arg src
cx = pos('$', src)
if cx < 1 then
return strip(src, 't')
res = left(src, cx-1)
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 || envGet(substr(src, cx+2, ex-cx-2))
ex = ex + 1
end
else do
ex = verify(src, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_',
|| 'abcdefghijklmnopqrstuvwxyz', 'n', cx+1)
if ex < 1 then
return strip(res || envGet(substr(src, cx+1)), 't')
res = res || envGet(substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return strip(res || substr(src, ex), 't')
res = res || substr(src, ex, cx-ex)
end
endProcedure envExpand
envExpAll: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx+1
m.dst.dx = envExpand(m.src.sx)
end
m.dst.0 = dx
return
endProcedure envExpAll
testExp: procedure
call mIni
m.xx.0 = 0
call envPut 'v1', eins
call envPut 'v2', zwei
call testExp1 'ohne variabeln'
call testExp1 '$v1 variabeln'
call testExp1 'mit $v1 iabeln'
call testExp1 'mit variab$v1'
call testExp1 '${v2}variabeln'
call testExp1 'mit vari${v1}'
call testExp1 'mit v${v2}eln'
call testExp1 'mit v${v1}eln'
call testExp1 'mit $v1 viel${v2}+$v1-vars${v2}'
call envExpAll mCut(yy, 0), xx
do x=1 to m.yy.0
say 'tesStem exp' m.yy.x'|'
end
return
endProcedure testExp
testExp1: procedure expose m.
parse arg src
call mAdd xx, src
say 'testExp src' src'|'
say 'testExp exp' envExpand(src)'|'
return
endProcedure testExp1
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions m, , '0123456789_' , '--'
m.scan.m.sqlBrackets = 0
return m
endProcedure scanSqlReader
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd
call adrEdit "cursor =" lx
do while adrEdit("seek" cmd 'word', 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx
call editReadDefine m, fx
call scanSqlReader m, m
do while m.m.editReadLx <= fx
if scanSql(scanSkip(m)) = '' then
return -1
if m.sqlType = 'i' & m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
ePos: procedure expose m.
parse arg m
return m.m.editReadLx m.scan.m.pos
endProcedure ePos
/*--- scan a sql token put type in m.sqltype:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': quantified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234
"'": string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSql: procedure expose m.
parse arg m
if scanAtEnd(m) then do
m.sqlType = ''
m.val = ''
end
else if scanString(m, "'") then
m.sqlType = "'"
else if scanSqlQuId(m) ^== '' then
nop
else if scanSqlNumUnit(m, 1) ^== '' then
nop
else if scanChar(m, 1) then do
m.sqlType = m.tok
m.val = ''
if m.tok = '(' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets + 1
else if m.tok = ')' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets - 1
end
else
call scanErr m, 'cannot scan sql'
return m.sqlType
endProcedure scanSql
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if ^ scanName(m) then
return ''
m.val = translate(m.tok)
m.sqlType = 'i'
return m.val
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) == '' then do
if scanString(m, '"') then do
val = strip(val, 't')
m.sqlType = 'd'
end
end
return m.val
endProcedure scansqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
if scanSqlDeId(m) == '' then
return ''
res = ''
do qx=1 by 1
m.val.qx = m.val
res = res'.'m.val
if ^ scanLit(scanSkip(m), '.') then do
m.val.0 = qx
if qx > 1 then
m.sqlType = 'q'
m.val = substr(res, 2)
return m.val
end
if scansqlDeId(scanSkip(m)) == '' then
call scanErr m, 'id expected after .'
end
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd
c3 = left(scanLook(m, 3), 3)
p = left(c3, 1) == '+' | left(c3, 1) == '-'
p = p + (substr(c3, p + 1, 1) == '.')
if pos(substr(c3, p+1, 1), '0123456789') < 1 then
return ''
n = ''
if p > 0 & left(c3, 1) ^== '.' then do
call scanChar m, 1
n = m.tok
end
if scanVerify(m, '0123456789') then
n = n || m.tok
if scanLit(m, '.') then do
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.tok
end
c3 = left(translate(scanLook(m, 3)), 3)
if left(c3, 1) == 'E' then do
p = substr(c3, 2, 1) == '+' | substr(c3, 2, 1) == '-'
if pos(substr(c3, p+2, 1), '0123456789') > 0 then do
call scanChar m, p+1
n = n || m.tok
if scanVerify(m, '0123456789') then
n = n || m.tok
c3 = scanLook(m, 1)
end
end
if checkEnd ^= 0 then
if pos(left(c3, 1), m.scan.m.name) > 0 then
call scanErr m, 'end of number' n 'expected'
m.val = n
return n
endProcedure scanSqlNum
/*--- scan a sql number with unit K M or G ---------------------------*/
scanSqlNumUnit: procedure expose m.
parse arg m, both
nu = scanSqlNum(m, 0)
if nu = '' then
return ''
sp = scanSpaceNl(m)
af = translate(scanSqlId(m))
if wordPos(af, "K M G") > 0 then do
m.sqlType = 'u'
m.val = nu || af
return m.val
end
else if af <> '' & ^ sp then
call scanErr m, 'end of number' nu 'expected'
if both ^== 1 then
call scanErr m, 'unit K M or G expected'
else if af ^== '' then
call scanBack m, m.tok
m.sqlType = 'n'
m.val = nu
return nu
endProcedure scanSqlNumUnit
scanSqlskipBrackets: procedure expose m.
parse arg m, br
call scanSpaceNl m
if br ^== '' then
nop
else if ^ scanLit(m, '(') then
return 0
else
br = 1
do forever
t = scanSql(scanSpaceNl(m))
if t = '' | t = ';' then
call scanErr m, 'closing )'
else if t = '(' then
br = br + 1
else if t ^== ')' then
nop
else if br > 1 then
br = br - 1
else if br = 1 then
return 1
else
call scanErr m, 'skipBrackets bad br' br
end
endProcedure skipBrackets
/* copy scanSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
m.scan.m.pos = 1
if symbol('m.scan.m.name') ^== 'VAR' then
call scanInit m
return m
endProcedure scanLine
/*--- switch to next line if atEnd of line or unCond=1 ---------------*/
scanNL: procedure expose m.
parse arg m, unCond
if m.scan.m.reading then do
interpret m.scan.m.scanNl
end
else do
np = 1 + length(m.scan.m.src)
if np <= m.scan.m.pos then
return 0
if unCond == 1 then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
m.scan.m.pos = np
return 1
end
endProcedure scanNL
scanAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.reading then
interpret m.scan.m.scanAtEnd
else
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEnd
/*--- initialize scanner for m --------------------------------------*/
scanInit: procedure expose m.
parse arg m, rdng
m.scan.m.reading = rdng == 1
m.tok = ''
m.val = ''
m.key = ''
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, m.scan.m.comment
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanInit m
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
m.scan.m.name = m.scan.m.name1 || '0123456789'
end
if namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
return
endProcedure scanOptions
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
return substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
m.tok = scanLook(m, len)
m.scan.m.pos = m.scan.m.pos + length(m.tok)
return length(m.tok) > 0
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
ScanNat: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
/*--- 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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok 'scanPosition' ,
strip(left(substr(m.scan.m.src, m.scan.m.pos), 40), 't')
if m.scan.m.reading then
interpret 'say " "' m.scan.m.scanLinePos
else
say ' pos' m.scan.m.Pos 'in string' strip(m.scan.m.src, 't')
call err 'scanErr' txt
return
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- begin scanning the lines of a reader ---------------------------*/
scanReader: procedure expose m.
parse arg m, m.scan.m.rdr
call scanInit m, 1
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanReaderNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanReaderAtEnd(m, what)'
m.scan.m.scanLinePos = "scanReaderLinePos(m)"
call scanReaderNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanReaderAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if what == 'l' then
return 1
return m.scan.m.atEnd
endProcedure scanReaderAtEnd
scanReaderNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then nop
else if unCond ^= 2 & m.scan.m.pos > length(m.scan.m.src) then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' & abbrev(substr( ,
m.scan.m.src, m.scan.m.pos), m.scan.m.comment) then nop
else
return 0
if m.scan.m.atEnd then
return 0
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, 'SCAN.'m'.SRC')
if m.scan.m.atEnd then do
m.scan.m.pos = 1 + length(m.scan.m.src)
end
else do
m.scan.m.pos = 1
m.scan.m.lineX = m.scan.m.lineX + 1
end
return ^ m.scan.m.atEnd
endProcedure scanReaderNL
scanReaderLinePos: procedure expose m.
parse arg m
if m.scan.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.scan.m.pos 'in'
return qq 'line' m.scan.m.lineX':' strip(m.scan.m.src, 't')
endProcedure scanReaderLinePos
/* copy scan end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jNew: procedure expose m.
if m.j.jIni ^== 1 then
call jIni
return 'J.'mInc(j)
endProcedure jNew
jFree: procedure expose m.
parse arg m
return
endProcedure jFree
jRead: procedure expose m.
parse arg m, arg
res = '?'
interpret m.j.m.read
return res
endProcedure jRead
jWrite: procedure expose m.
parse arg m, arg
interpret m.j.m.write
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Reset m, arg'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Open m, arg'
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret 'call' m.j.m.pref'Close m'
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jClose
jDefine: procedure expose m.
parse arg m, m.j.m.pref
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jDefine
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
jOpt: 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
jIni: procedure expose m.
parse arg force
if m.j.jIni == 1 & force ^== 1 then
return
m.j.jIni = 1
m.j.0 = 0
m.j.defDD.0 = 0
m.j.jIn = jNew()
m.j.jOut = jNew()
call jDefine m.j.jIn, "jStdIOError "
call jDefRead m.j.jIn, "res = 0"
call jDefine m.j.jOut, "jStdIOError "
call jDefWrite m.j.jOut, "say arg"
return
endProcedure jIni
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
jBuf: procedure expose m.
m = jNew()
call jDefine m, "jBuf"
do ax=1 to arg()
m.j.m.buf.ax = arg(ax)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.j.m.buf.ax = arg(ax+1)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == 'r' then do
call jDefRead m, "res = jBufRead(m , arg)"
m.j.m.bufIx = 0
return m
end
if opt == 'w' then
m.j.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
call jDefWrite m, "call mAdd 'J.'m'.BUF', arg"
return m
endProcedure jBufOpen
jBufClose:
return arg(1)
endProcedure jBufClose
jBufStem: procedure expose m.
parse arg m
return 'J.'m'.BUF'
endProcedure jBufStem
jBufRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then
return 0
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jBufRead
jDsn: procedure expose m.
parse arg spec
m = jNew()
m.j.m.state = ''
call jDefine m, "jDsn"
m.j.m.defDD = 'J'mInc('J.DEFDD')
call jDsnReset m, spec
return m
endProcedure jDsn
jDsnReset: procedure expose m.
parse arg m, spec
call jClose m
m.j.m.dsnSpec = spec
return m
endProcedure jDsnReset
jDsnOpen: procedure expose m.
parse arg m, opt
call jDsnClose m
if opt == 'r' then do
aa = dsnAlloc(m.j.m.dsnSpec, 'SHR', m.j.m.defDD)
call readDDBegin word(aa, 1)
call jDefRead m, "res = jDsnRead(m , arg)"
end
else do
if opt == 'w' then
aa = dsnAlloc(m.j.m.dsnSpec, 'OLD', m.j.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.j.m.dsnSpec, 'MOD', m.j.m.defDD)
else
call err 'jBufOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call jDefWrite m, "call jDsnWrite m , arg"
end
m.j.m.state = opt
m.j.m.dd = word(aa, 1)
m.j.m.free = subword(aa, 2)
return m
endProcedure jBufOpen
jDsnClose:
parse arg m
if m.j.m.state ^== '' then do
if m.j.m.state == 'r' then do
call readDDend m.j.m.dd
end
else do
if m.j.m.buf.0 > 0 then
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
call writeDDend m.j.m.dd
end
interpret m.j.m.free
end
m.j.m.buf.0 = 0
m.j.m.bufIx = 0
m.j.m.state = ''
m.j.m.free = ''
m.j.m.dd = ''
return m
endProcedure jDsnClose
jDsnRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then do
res = readDD(m.j.m.dd, 'M.J.'m'.BUF.')
if ^ res then
return 0
ix = 1
end
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jDsnRead
jDsnWrite: procedure expose m.
parse arg m, var
ix = m.j.m.buf.0 + 1
m.j.m.buf.0 = ix
m.j.m.buf.ix = var
if ix > 99 then do
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
m.j.m.buf.0 = 0
end
return
endProcedure jDsnWrite
/* copy j end *********************************************************/
/* copy adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* 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 do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("SUBCOM DSNREXX", '*') <> 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
call adrSql "connect" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
sqlFields: procedure
parse arg flds
sql = ''
do wx=1 to words(flds)
sql = sql', :'word(flds, wx)
end
if wx > 1 then
sql = substr(sql, 3)
return sql
endProcedure sqlFields
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/* copy adrSql 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
parse 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
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
ds = ''
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
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 m begin ********************************************************
stem and type handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a.0 = m.a.0 + 1
return m.a.0
endProcedure mInc
mDefIfNot: procedure expose m.
parse arg a, put
if symbol('m.a') == 'VAR' then
return 0
m.a = put
return 1
endProcedure mDefIfNot
/*--- 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
/*--- 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 mAddAt
/*--- put into stem a the fields flds from arguments -----------------*/
mPut: procedure expose m.
parse arg a, flds
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = arg(wx+2)
end
return a
endProcedure mPut
/*--- put into stem a the fields flds from stem b --------------------*/
mPutSt: procedure expose m.
parse arg a, flds, b
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = m.b.f
end
return a
endProcedure mPutSt
/*--- put into stem a the fields flds from variable pool -------------*/
mPutVars:
parse arg ggA, ggFlds
do ggWx = 1 to words(ggFlds)
ggF = word(ggFlds, ggWx)
m.ggA.ggF = value(ggF)
end
return ggA
endProcedure mPutVars
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
if m.m.mIni ^== 1 then
call mIni
return mapReset(mAdd(m.map, 'map'))
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.a.mapKey') == 'VAR' then
call mapClear a
m.a.mapKey = translate(opt) = 'K'
if m.a.mapKey then
m.a.mapKey.0 = 0
else
m.a.mapKey.0 = 'noMapKeys'
return a
endProcedure
mapClear: procedure expose m.
parse arg a
do kx=1 to m.a.mapKey.0
k = m.a.mapKey.kx
drop m.a.mapK2V.k m.a.mapKey.kx
end
m.a.mapKey.0 = 0
return a
endProcedure mapClear
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.mapK2V.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.mapK2V.ky = val
if m.a.mapKey then
call mAdd a.mapKey, ky
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg m, ky, val
if m.m.mapKey then
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call mAdd m.mapKey, ky
m.m.mapK2V.ky = val
return
endProcedure mapPut
mapHasKey: procedure expose m.
parse arg m, ky
return symbol('m.m.mapK2V.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg m, ky
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call err 'missing key in mapGet('m',' ky')'
return m.m.mapK2V.ky
endProcedure mapGet
mapGetOr: procedure expose m.
parse arg m, ky, orDef
if symbol('m.m.mapK2V.ky') == 'VAR' then
return m.m.mapK2V.ky
else
return orDef
endProcedure mapGetOr
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mGetType:
parse arg name
return mapGet(m.type, name)
endProcedure mGetType
mTypeNew: procedure expose m.
parse arg name, stem, flds, types
if m.m.ini ^== 1 then
call mIni
ty = mAdd(m.type, name)
call mapAdd m.type, name, ty
m.ty.ass = '='
m.ty.type = stem
m.ty.0 = words(flds)
m.ty.type.0 = m.ty.0
do y=1 to m.ty.0
m.ty.y = word(flds, y)
if word(types, y) = '' then
m.ty.type.y = m.type.1
else
m.ty.type.y = word(types, y)
end
return ty
endProcedure mTypeNew
mShow: procedure expose m.
parse arg ty, a, lv
if lv='' then
lv = 0
pr = a
if lv > 0 & lastPos('.', pr) > 0 then
pr = substr(pr, lastPos('.', pr))
say left('', lv)pr '=' m.a
do y=1 to m.ty.0
call mShow m.ty.type.y, a'.'m.ty.y, lv+1
end
if m.ty.type ^== '' then do
do y=1 to m.a.0
call mShow m.ty.type, a'.'y, lv+1
end
end
return
endProcedure mShow
mClear: procedure expose m.
parse arg ty, a, val
m.a = val
do y=1 to m.ty.0
call mClear m.ty.type.y, a'.'m.ty.y
end
if m.ty.type ^== '' then
m.a.0 = 0
return
endProcedure mClear
mTypeSay: procedure expose m.
parse arg t
say 'type' t'='m.t 'ass' m.t.ass '#' m.t.0 'tys' m.t.type
return
endProcedure mInit
mTypeCopy: procedure expose m.
parse arg ty, t, f
if m.ty.ass == '=' then
m.t = m.f
else
call err 'type.ass' m.ty.ass 'not supported'
do x = 1 to m.ty.0
fld = m.ty.x
call mTypeCopy m.ty.type.x, t'.'fld, f'.'fld
end
if m.ty.type ^== '' then do
do y = 1 to m.f.0
call mTypeCopy m.ty.type, t'.'y, f'.'y
end
m.t.0 = m.f.0
end
return t
endProcedure mTypeCopy
mIni: procedure expose m.
m.m.ini = 1
m.m.type.0 = 0
m.m.map.0 = 0
call mapReset m.type
call mapReset m.vars
siTy = mTypeNew('Simple')
stTy = mTypeNew('Stem', siTy)
tyTy = mTypeNew('Type', siTy, 'ASS TYS', siTy stTy)
ttTy = mTypeNew('StemType', tyTy)
return
endProcedure mIni
mTest: procedure
call mIni
siTy = mGetType('Simple')
tyTy = mGetType('Type')
ttTy = mGetType('StemType')
say 'siTy' siTy 'tyTy' tyTy 'stTyTy' ttTy
call mTypeSay siTy
call mTypeCopy siTy, nnn, siTy'.'ass
say 'm.nnn nach copy' m.nnn
call mTypeCopy tyTy, mmm, siTy
call mTypeSay mmm
call mTypeCopy tyTy, qqq, tyTy
call mTypeSay qqq
call mShow tyTy, qqq
call mShow ttTy, m.type
return
endProcedure mTest
/* copy m 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 *****************************************************/
}¢--- A540769.WK.REXX.O13(O) cre=2012-04-02 mod=2013-09-23-11.34.39 A540769 ----
/* 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 *******************************************************/
}¢--- A540769.WK.REXX.O13(OUT) cre=2009-11-03 mod=2013-01-11-15.33.24 A540769 ---
/* 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.O13(PATRICE) cre=2010-11-04 mod=2010-11-04-10.47.38 A540769 ---
call sqlConnect 'DBAF'
r = sqlPreAllCl(1, "select name from sysibm.sysdatabase" ,
"where name like 'DA%'" ,
"order by name",
, st, ":m.st.sx.db")
say r
do y=1 to 3
say m.st.y.db
end
call sqlDisconnect
exit
/* 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 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.O13(PDSTOSEQ) cre=2013-02-09 mod=2013-02-09-23.00.27 A540769 ---
/*REXX******************************** begin member getmem *****
callable find members interface */
/* trace ?R */
arg mArg
/* call adrTsoRc 'execio 0 diskr outDD1 (finis)'
call adrTso 'free dd(outDD1)'
/
call des 'tmp.text(ser1)'
exit */
call showTime('start')
llq = 'PLI'
call serOpen 'tmp.text(ser1)'
call serPds 'wk.rexx', '*'
/* call serPds 'wk.pli', '*' */
call serClose
exit
serPds:
parse arg serPds, serMask
call gmIni , serPds, serMask
now = date('s') Time('n')
call serBegin 'pds', serPds now
do while (gmNext() <> '')
call serBegin 'mbr', gmMbr
call serDD serPds'('strip(gmMbr)')'
call serEnd 'mbr', gmMbr
end
call serEnd 'pds', serPds now
call showTime('serPds end' serPds)
return /* end serPds */
serDD:
parse arg serDsn
call adrTso 'alloc dd(serDD2) shr dsn('serDsn')'
do forever
serRc2 = adrTsoRc('execio 100 diskr serDD2 (stem st2.)')
if serRc2 <> 0 & serRc2 <> 2 then
call err 'bad rc' serRc2 'for tso execio 1 diskr serDD2'
call serStem st2.0, 'st2.'
if serRc2 <> 0 then
leave
end
call adrTsoRc 'execio 0 diskr serDD2 (finis)'
call adrTso 'free dd(serDD2)'
return /* end serDD */
out: procedure
parse arg typ, text
select;
when typ = '=' then do;
if left(text, length(serMark)) = serMark then
call out1 serMark 'data 1'
call out1 text
end
when left(typ, 1) = '(' then
call out1 serMark 'begin' substr(typ, 2) text
when left(typ, 1) = ')' then
call out1 serMark 'end' substr(typ, 2) text
when typ = '$alloc' then
call adrTso 'alloc dd(outDD) shr dsn('text')'
when typ = '$free' then do
call adrTso 'execio 0 diskw outDD (finis)'
call adrTso 'free dd(outDD)'
end
otherwise call err 'bad typ "' typ '" in out, text' text
end
return /* end out */
serBegin: procedure expose serMark
parse arg typ, name
call serOut serMark 'begin' typ name
return
serEnd: procedure expose serMark
parse arg typ, name
call serOut serMark 'end ' typ name
return
serOpen:
parse arg serOutDsn
serMark = '(((>>>'
call adrTso 'alloc dd(serOutDD) shr dsn('serOutDsn')'
return
serClose: procedure
call adrTso 'execio 0 diskw serOutDD (finis)'
call adrTso 'free dd(serOutDD)'
call showTime('serClose' serOutDsn)
return
serOut: procedure
parse arg line1
call adrTso 'execio 1 diskw serOutDD (stem line)'
return
serStem:
parse arg serCnt, serStem
call adrTso 'execio' serCnt 'diskw serOutDD (stem' serStem')'
return
des:
parse arg desInDsn
desMark = '(((>>> '
call adrTso 'alloc dd(desInDD) shr dsn('desInDsn')'
do forever
desRc = adrTsoRc('execio 100 diskr desInDD (stem des.)')
if desRc <> 0 & desRc <> 2 then
call err 'bad rc' desRc 'for tso execio 100 diskr serInDD'
desIx = 1
do while desIx < des.0
if left(des.desIx, length(desMark)) = desMark then do
desW2 = word(des.desIx, 2)
if desW2 = 'begin' then
call desBegin subWord(des,desIx, 3)
else if desW2 = 'end' then
call desEnd subWord(des,desIx, 3)
else
call err 'bad desW2' desW2 'in' des.desIx
desIx = desIx + 1
end
else do
do dexIx = 1 by 1
dex.dexIx = des.desIx
desIx = desIx + 1
if left(des.desIx, length(desMark)) = desMark then
leave
end
call desStem dexIx, 'dex.'
end
end
if desRc <> 0 then
leave
end
call adrTsoRc 'execio 0 diskr desInDD (finis)'
call adrTso 'free dd(desInDD)'
return /* end des */
desBegin: procedure
parse arg name text
say 'desBegin' name',' text
return
desEnd: procedure
parse arg name text
say 'desEnd' name',' text
return
desStem:
parse arg desCnt, desSt2
say 'desStem' desCnt desSt2':' left(value(desSt2'.1'), 50)
return
outMbr: /* example for lmm services, but too slow| */
parse arg outId, outMbr
call adrIsp 'lmmfind dataid(&'outId') member('outMbr')'
call out '(mbr', outMbr
outCnt = 0
do forever
outRc = adrIspRc('lmget dataid(&'outId')' ,
'mode(invar) dataloc(outRec)' ,
'maxLen(99999) datalen(outLen)')
if outRc = 0 then do
outCnt = outCnt + 1
call out '=', outRec
end
else if outRc = 8 then
leave
else
call err 'rc' outRc 'for isp lmget dataid(&'outId')'
end
call out ')mbr', outMbr outCnt
return /* outMbr */
gmIni:
parse arg gmSuf, gmDsn, gmPat
call adrTso "ALLOC DS("gmDsn") F(gmDD"gmSuf") REU SHR "
call adrIsp "LMINIT DATAID(gmII"gmSuf") DATASET("gmDSN") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID(&gmII"gmSuf") OPTION(INPUT) "
if gmOpt = '' then
gmX = value('gmPP'gmSuf, '')
else
gmX = value('gmPP'gmSuf, 'pattern('gmPat')')
say 'gmPat' gmPat '=> gmPP'gmSuf '=' value('gmPP'gmSuf)
return; /* end gmIni */
gmFree:
parse arg gmSuf
if adrIspRc("LMMLIST DATAID(&gmII"gmSuf") option(free)") <> 0 then
if rc <> 8 then
call err "rc" rc "for isp" ,
"LMMLIST DATAID(&gmII"gmSuf") option(free)"
call adrIsp "LMCLOSE DATAID(&gmII"gmSuf")"
call adrIsp "LMFREE DATAID(&gmII"gmSuf")"
call adrTso "free f(gmDD"gmSuf")"
return /* end gmFree */
gmNext:
parse arg gmSuf
gmMbr = ''
gmRc = adrIspRc("LMMLIST DATAID(&gmII"gmSuf")" ,
"OPTION(LIST) MEMBER(gmMbr)" value('gmPP'gmSuf))
if gmRc <> 0 then
if gmRc <> 8 & gmRC <> 4 then
call err "adrIsp RC" gmRc "for" ,
"LMMLIST DATAID(&gmII"gmSuf")" ,
"OPTION(LIST) MEMBER(gmMbr)"
return gmMbr /* end gmNext */
showMbr:
parse arg shId, shMbr
call adrIsp 'lmmfind dataid(&'shId') member('shMbr') lrecl(lrecl)'
say 'lmmFind' shMbr 'lRecl' lRecl
do i=1 to 10
call adrIsp 'lmget dataid(&'shId') mode(invar) dataloc(rec)',
'datalen(recLen) maxlen('lrecl')'
say i 'len' recLen':' rec
end
return /* showMbr */
showTime:
parse arg showmsg
say time() sysvar('syscpu') sysvar('syssrv') showmsg
return 0
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
err:
parse arg txt
say 'fatal error in ??:' txt
exit 12
}¢--- A540769.WK.REXX.O13(PERRUT) cre=2011-02-08 mod=2011-02-08-14.59.50 A540769 ---
select
insert
}¢--- A540769.WK.REXX.O13(PI) cre= mod= ----------------------------------------
/* copy pi begin ****************************************************
pi = pipe interface and simple pipes
***********************************************************************/
/*--- begin execution of pipe pp (created by piNew)
with output redirection outDSS ---------------------------*/
piBegin: procedure expose m.
parse arg pp, outDSS
lc = m.pi.chLast.pp
do x = pp to m.pi.chLast.pp
m.wr.prcSta.x = 0
call wrDefine x, "b"
end
if m.pi.redirOut.pp then
call wr2Ds m.pi.out.lc, outDss
else
m.pi.out.lc = m.wr.out
call outPush , pp
call piBar 'b'
return
endProcedure piBegin
/*--- end executution of pipe pp (after piBegin and piBar*)
close pipe if immediate delay close ----------------------------*/
piEnd: procedure expose m.
parse arg pp, immediate
ch = m.wr.prc
call piBar 'e'
if pp ^= m.pi.chFirst.ch then
call err 'piEnd on wrong pipe'
if ch ^== m.pi.chLast.pp then
call err 'piEnd but not on lastChild'
orCl = m.wr.close.pp
if immediate == '' & (m.pi.redirIn.pp & m.pi.redirOut.pp) then
immediate = 1
if immediate == 1 then do
call piClose pp, orCl
call wrDefine pp
end
else do
call wrDefine pp, m.wr.write.pp,
, 'call piClose' pp',' quote(orCl)
if immediate == '' then
call piDefine 'call write' pp', stem', 'call wrClose' pp
else if immediate ^== '0' then
call err 'piEnd bad immediate:' immediate
end
return
endProcedure piEnd
/*--- close pipe pp, close first child with ch1Clo -------------------*/
piClose: procedure expose m.
parse arg pp, ch1Clo
if m.wr.prcSta.pp == 'c' then
return
call outPush m.pi.out.pp, pp
if m.wr.wrBuf.pp.0 ^== 0 then
call write pp
interpret ch1Clo
m.wr.wrbuf.pp.0 = 0 /* in case it was buffering */
call outPop
do cx=pp+1 to m.pi.chLast.pp
call wrClose cx
end
ch = m.pi.chLast.pp
if m.pi.redirOut.pp then
call wrClose m.pi.out.ch
m.wr.prcSta.pp = 'c'
return
endProcedure piClose
/*--- switch to next child,
be means 'b'=begin, 'e'=end, ''=middle ---------------------*/
piBar: procedure expose m.
parse arg be
ch = m.wr.prc
pp = m.pi.chFirst.ch
if m.wr.prcTyp.ch ^== 'pipe' then
call err 'piEnd but prc not pipe'
if m.wr.prcTyp.pp ^== 'pipe' then
call err 'piEnd but chFirst not pipe'
call outPop
if be == 'b' then
nc = ch
else
nc = m.pi.out.ch
if be ^== 'e' then do
if nc < m.pi.chFirst.pp | nc > m.pi.chLast.pp then
call err 'piBar newChild' nc 'out of range',
m.pi.chFirst.pp'..'m.pi.chLast.pp
call outPush m.pi.out.nc, nc
end
return
endProcedure piBar
/*--- make the current process a writer if piping
otherwise execute close function ---------------------------*/
piDefine: procedure expose m.
parse arg wri, clo, w2, w3
ch = m.wr.prc
if m.wr.prcTyp.ch == '' then do
m = ch
stem = ''
interpret clo
return
end
if m.wr.prcSta.ch ^== '' then do
if m.wr.prcSta.ch ^== 0 then
call err 'duplicate piDefine for child' ch
m.wr.prcSta.ch = 1
end
push = "call outPush" m.wr.out"," ch";"
pop = "; call outPop"
call wrDefine ch, push wri, push "do;" clo"; end"pop, w2, w3 pop
return
endProcedure piDefine
/*--- create a new pipe with cnt children
reIn, reOut whether we have redirection --------------------*/
piNew: procedure expose m.
parse arg cnt, reIn, reOut
pp = wrNew('pipe', 0)
m.pi.redirIn.pp = reIn = 1
m.pi.redirOut.pp = reOut = 1
cnt = cnt + m.pi.redirIn.pp
m.pi.chFirst.pp = pp
la = pp
ch = pp
do cx=2 to cnt
ch = wrNew('pipe', 0)
m.pi.chFirst.ch = pp
m.pi.out.la = ch
la = ch
end
m.pi.chLast.pp = ch
if m.pi.RedirOut.pp then
m.pi.out.ch = wrNew('pipe', 0)
return pp
endProcedure piNew
/*--- create a new sequence ------------------------------------------*/
piSeqNew: procedure expose m.
parse arg cnt, reIn, reOut
sq = wrNew('seq')
m.pi.prc.sq = wrNew('seq')
m.pi.code.sq.0 = 0
return sq
endProcedure piSeqNew
/*--- add the code for the next seq stastement -----------------------*/
piSeqAdd: procedure expose m.
parse arg sq, aCd
cx = m.pi.code.sq.0 + 1
m.pi.code.sq.0 = cx
m.pi.code.sq.cx = aCd
return
endProcedure
/*--- activate sequence depending on piping envrionment --------------*/
piSeq: procedure expose m.
parse arg sq
m.pi.runX.sq = 0
call piDefine "call piSeqRun" sq", 0, stem",
, "call piSeqRun" sq", 1"
return
endProcedure piSeq
/*--- execute sequence sq, if close then close it otherwise
if close then close it else write stem -------------------------*/
piSeqRun: procedure expose m.
parse arg sq, close, stem
rx = m.pi.runX.sq
pr = m.pi.prc.sq
if rx > m.pi.code.sq.0 then
return
if rx > 0 then do
if ^ close then do
call write pr, stem
return
end
call wrClose pr
end
do rx = rx+1 to m.pi.code.sq.0
call piSeqRunOne sq, rx
if m.wr.write.pr ^== '' & ^ close then do
call write pr, stem
m.pi.runX.sq = rx
call wrDefine sq, m.wr.write.pr, 'call piSeqRun' sq', 1'
return
end
call wrClose m.pi.prc.sq
end
m.pi.runX.sq = rx
call wrDefine sq
return
endProcedure piSeqRun
/*--- in sequence sq exectute statement cx ---------------------------*/
piSeqRunOne: procedure expose m.
parse arg sq, cx
pr = m.pi.prc.sq
call wrDefine pr
m.wr.prcSta.pr = 0
call outPush , pr
interpret m.pi.code.sq.cx
call outPop
return
endProcedure piSeqRunOne
/*--- comp pipe stmt (($:wr¨$:li¨$:in) stmt?)? ($:cl stmt?)? $:end? --*/
piCmpStmt: procedure expose m.
parse arg m
aa = ''
ab = ','
if symbol("m.pi.define.0") = 'VAR' then
px = 1 + m.pi.define.0
else
px = 1
if scanLit(m, '$:wr') then do
call scanSpaceNL m
m.pi.defineWr1.px = rscStmt(m, 0)
aa = 'm.pi.defineWr1.'px
end
else if scanLit(m, '$:li') then do
call scanSpaceNL m
m.pi.defineWr2.px = rscStmt(m, 0)
aa = 'm.pi.defineWr2.'px
end
else if scanLit(m, '$:in') then do
call scanSpaceNL m
m.pi.defineWr2.px = rscStmt(m, 0)
aa = 'm.pi.defineWr2.'px', "call out stem"'
end
call scanSpaceNL m
if scanLit(m, '$:cl') then do
call scanSpaceNL m
m.pi.defineClo.px = rscStmt(m, 0)
ab = 'm.pi.defineClo.'px','
end
if aa == '' & ab == ',' then
return ""
m.pi.define.0 = px
call scanSpaceNL m
if scanLit(m, '$:end') then do
call scanSpaceNL m
end
if pos('Wr1.', aa) > 0 then
return 'call piDefine' aa',' ab
else
return 'call piDefine' ',' ab aa
endProcedure piCmpStmt
/*--- generate code for a pipe from stmts, input and output --------*/
piCmpPipe: procedure expose m.
parse arg stCnt, st, inp, out
px = piNew(stCnt, inp ^== '', out ^== '')
if inp ^== '' then
if stCnt > 0 then
st = inp'; call piBar;' st
else
st = inp
return 'call piBegin' px',' out'; do;' st '; end;call piEnd' px
endProcedure piCmpPipe
/*--- compile a Sequence = '(stmt ¨ '$;')* ---------------------------*/
piCmpSeq: procedure expose m.
parse arg m
cnt = 0
sq = ''
code = ''
call scanSpaceNL m
do forever
if scanLit(m, '$;') then do
call scanSpaceNL m
end
else do
one = rscPipe(m)
if one == '' then
return rscStrip(code)
else if sq ^== '' then
call piSeqAdd sq, one
else if code == '' then
code = one
else do
sq = piSeqNew()
call piSeqAdd sq, code
call piSeqAdd sq, one
code = 'call piSeq' sq
end
end
end
endProcedure piCmpSeq
/**********************************************************************
pipe = simple pipes
***********************************************************************/
piWC: procedure expose m.
parse arg wrT, wrO, wrC
m = m.wr.prc
m.wr.wc.m.chars = 0
m.wr.wc.m.lines = 0
if wrO ^== '' then
call outLn wrO
if wrT = 0 then
wri = ''
else if wrT == '' then
wri = ';call outLn m.line'
else
wri = ';call outLn' quote(wrT) 'm.line'
if wrC == '' then
wrC = "piWC" m "counted'"
call piDefine "m.wr.wc."m".lines = m.wr.wc."m".lines + m.stem.0",
, "call outLn " quote(wrC),
" m.wr.wc."m".lines 'lines and'",
" m.wr.wc."m".chars 'characters'",
, " m.wr.wc."m".chars = m.wr.wc."m".chars + length(m.line)" wri
return
endProcedure piWC
/* copy pi end ********************************************************/
}¢--- A540769.WK.REXX.O13(PIPE) cre=2012-04-02 mod=2013-05-27-11.59.37 A540769 ---
/* 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 ******************************************************/
}¢--- A540769.WK.REXX.O13(PITEST) cre= mod= ------------------------------------
/* copy piTest begin ************************************************/
m.trace = 0
call wrIni 0
if 1 then call wrTestAll
if 1 then call rsTest
if 1 then call piTest
exit
piTest: procedure expose m.
call piTestPipe
call piTestSeq
call piTestComp
return
endProcedure piTest
piTestComp: procedure expose m.
pT = wrNew()
pR = wrNew('piTestComp')
call outPush pT
call wrTest pT,
, "--- rsTestComp1 s pi1 ==> 2 lines call piWC ""ch1 li"",",
|| " ""ch1 op"", ""ch1 cl """,
, "--- running s pi1 without pipe",
, "ch2 op",
, "ch2 li ch1 op",
, "ch2 li ch1 cl 0 lines and 0 characters",
, "ch2 cl 2 lines and 38 characters",
, "--- running s pi1 piping",
, "ch2 op",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach writeLN two */
, "ch2 li ch1 op",
, "ch2 li ch1 li writeLn line one",
, "ch2 li ch1 li writeLn line two",
, "ch2 li ch1 cl 2 lines and 32 characters",
, "ch2 cl 4 lines and 85 characters"
call piTestComp1 's pi1', wrArgs('xyz',0,
, ' call piWC "ch1 li", "ch1 op", "ch1 cl "',
, '$¨ call piWC "ch2 li", "ch2 op", "ch2 cl "')
call wrTest pT,
, "--- rsTestComp1 s pi2 ==> 6 lines $:{ call piWC ""ch1 li",
|| """, ""ch1 op"", ""ch1 cl """,
, "--- running s pi2 without pipe",
, "ch1 op",
, "ch1 li line eins",
, "ch1 li leine zwei",
, "ch1 cl 2 lines and 19 characters",
, "ch2 op",
, "ch2 cl 0 lines and 0 characters",
, "--- running s pi2 piping",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach zwei */
, "ch1 op",
, "ch1 li line eins",
, "ch1 li leine zwei",
, "ch1 cl 2 lines and 19 characters",
, "ch2 op",
, "ch2 cl 0 lines and 0 characters"
call piTestComp1 's pi2', wrArgs('xyz',0,
, '$:{ call piWC "ch1 li", "ch1 op", "ch1 cl "',
, ' $; call piWC "ch2 li", "ch2 op", "ch2 cl "',
, '$:} $<<e1 ', 'line eins', 'leine zwei',
, 'e1 ')
call wrTest pT,
, "--- rsTestComp1 s pi3 ==> 3 lines $:{ call piWC ""ch1 li",
|| """, ""ch1 op"", ""ch1 cl """,
, "--- running s pi3 without pipe",
, "ch1 op",
, "ch1 cl 0 lines and 0 characters",
, "ch2 op",
, "ch2 cl 0 lines and 0 characters",
, "--- running s pi3 piping",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach two */
, "ch1 op",
, "ch1 li writeLn line one",
, "ch1 li writeLn line two",
, "ch1 cl 2 lines and 32 characters",
, "ch2 op",
, "ch2 cl 0 lines and 0 characters"
call piTestComp1 's pi3', wrArgs('xyz',0,
, '$:{ call piWC "ch1 li", "ch1 op", "ch1 cl "',
, ' $; call piWC "ch2 li", "ch2 op", "ch2 cl "',
, ' $:} ')
call wrTest pT,
, "--- rsTestComp1 s pi4 ==> 1 lines $:li $| ""liEins<"" m.li",
|| "ne "">liEins""",
, "--- running s pi4 without pipe",
, "--- running s pi4 piping",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach liEins */
, "liEins< writeLn line one >liEins",
, "liEins< writeLn line two >liEins",
call piTestComp1 's pi4', wrArgs('xyz',0,
, '$:li $| "liEins<" m.line ">liEins"')
call wrTest pT,
, "--- rsTestComp1 s pi5 ==> 2 lines $$ liZwei open ",
, "--- running s pi5 without pipe",
, " liZwei open ",
, " liZwei close",
, "--- running s pi5 piping",
, " liZwei open ",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nch >liZwei */
, "liZwei< writeLn line one >liZwei",
, "liZwei< writeLn line two >liZwei",
, " liZwei close"
call piTestComp1 's pi5', wrArgs('xyz',0,
, '$$ liZwei open ',
, '$:li $| "liZwei<" m.line ">liZwei" $:cl $$ liZwei close')
call wrTest pT,
, "--- rsTestComp1 s pi6 ==> 2 lines $$ inDrei open ",
, "--- running s pi6 without pipe",
, " inDrei open ",
, " inDrei close",
, "--- running s pi6 piping",
, " inDrei open ",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach >inDrei */
, "inDrei< writeLn line one >inDrei",
, "inDrei< writeLn line two >inDrei",
, " inDrei close"
call piTestComp1 's pi6', wrArgs('xyz',0,
, '$$ inDrei open ',
, '$:in m.line="inDrei<" m.line ">inDrei" $:cl $$ inDrei close')
call wrTest pT,
, "--- rsTestComp1 s pi7 ==> 3 lines $$ wrVier open ",
, "--- running s pi7 without pipe",
, " wrVier open ",
, " wrVier close",
, "--- running s pi7 piping",
, " wrVier open ",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach line one */
, "wrVier stem.2 first writeLn line one",
, " wrVier close"
call piTestComp1 's pi7', wrArgs('xyz',0,
, '$$ wrVier open ',
, '$:wr $| "wrVier stem."m.stem.0 "first" m.stem.1',
, ' $:cl $$ wrVier close')
call wrTest pT,
, "--- rsTestComp1 s pi8 ==> 5 lines call piWC ""ch1 li"",",
|| " ""ch1 op"", ""ch1 cl """,
, "--- running s pi8 without pipe",
, "ch2 op",
, "ch2 li wrFuenf open ",
, "ch2 li wrFuenf stem.2 first ch1 op",
, "ch2 li wrFuenf close",
, "ch2 cl 3 lines and 55 characters",
, "--- running s pi8 piping",
, "ch2 op",
, "--- writing 2 lines",
, "--- closing run", /* wkOld war nach two */
, "ch2 li wrFuenf open ",
, "ch2 li wrFuenf stem.4 first ch1 op",
, "ch2 li wrFuenf close",
, "ch2 cl 3 lines and 55 characters"
call piTestComp1 's pi8', wrArgs('xyz',0,
, ' call piWC "ch1 li", "ch1 op", "ch1 cl "',
, '$¨ $$ wrFuenf open ',
, ' $:wr $| "wrFuenf stem."m.stem.0 "first" m.stem.1',
, ' $:cl $$ wrFuenf close',
, '$¨ call piWC "ch2 li", "ch2 op", "ch2 cl "')
call outPop
call wrTestTotal pT
return
endProcedure piTestComp
piTestComp1:
parse arg typ, st
call wrTestOut pT, 'rsTestComp1' typ '==>' m.st.0 'lines' m.st.1
code = rsCompile(pC, st, left(typ, 1)'p') /* nur mit pipe | */
say 'code' code
call wrTestOut pT, 'running' typ 'without pipe'
call rsRun code
call wrTestOut pT, 'running' typ 'piping'
call outPush , pR
call rsRun code
call wrTestOut pT, 'writing 2 lines'
call writeLn pR, 'writeLn line one', 'writeLn line two'
call wrTestOut pT, 'closing run'
call wrClose pR
call outPop
call wrClose pT
return
endProcedure piTestComp1
piTestSeq: procedure expose m.
pT = wrNew()
call outPush pT
sq = piSeqNew()
call piSeqAdd sq, 'call outLn "first seq"'
call piSeqAdd sq, 'call outLn "second seq"'
call piSeqAdd sq, 'call piWC "seq3 li", "seq3 op", "seq3 cl"'
call piSeqAdd sq, 'call outLn "four th seq"'
call piSeqAdd sq, 'call piWC "seq5 li", "seq5 op", "seq5 cl"'
call piSeqAdd sq, 'call outLn "six th seq end"'
call wrTest pT,
, "--- before piSeq immediate",
, "first seq",
, "second seq",
, "seq3 op",
, "seq3 cl 0 lines and 0 characters",
, "four th seq",
, "seq5 op",
, "seq5 cl 0 lines and 0 characters",
, "six th seq end",
, "--- before piSeq close"
call wrTestOut pt, 'before piSeq immediate'
call piSeq sq
call wrTestOut pt, 'before piSeq close'
call wrClose sq
call wrClose pT
call outPop
pp = wrNew('abc')
call outPush pT, pP
call wrTest pT,
, "--- before piSeq in pipe no write",
, "--- before piSeq close",
, "first seq",
, "second seq",
, "seq3 op",
, "seq3 cl 0 lines and 0 characters",
, "four th seq",
, "seq5 op",
, "seq5 cl 0 lines and 0 characters",
, "six th seq end"
call wrTestOut pt, 'before piSeq in pipe no write'
call piSeq sq
call wrTestOut pt, 'before piSeq close'
call wrClose pp
call wrClose pT
call wrTest pT,
, "--- before piSeq in pipe 2 writes",
, "--- before write",
, "--- before piSeq close", /* wkOld war nach before close*/
, "first seq",
, "second seq",
, "seq3 op",
, "seq3 li writeLn line one",
, "seq3 li and two before close",
, "seq3 cl 2 lines and 36 characters",
, "four th seq",
, "seq5 op",
, "seq5 cl 0 lines and 0 characters",
, "six th seq end"
call wrTestOut pt, 'before piSeq in pipe 2 writes'
call piSeq sq
call wrTestOut pt, 'before write'
call writeLn pp, 'writeLn line one', 'and two before close'
call wrTestOut pt, 'before piSeq close'
call wrClose pp
call wrClose pT
call outPop
call wrTestTotal pT
return
endProcedure piTestSeq
piTestPipe: procedure expose m.
pT = wrNew()
pR = wrNew('abc')
call outPush pT, pR
call wrTest pT,
, "--- piTest begin pipe(1) no wrDefine",
, "zeile eins aus pipe(1)",
, "zeile drei aus pipe(1)",
, "vier und Schluss",
, "--- piTest begin pipe(1) with wrDefine",
, "zeile eins aus pipe(1)",
, "--- before piCh1 piWriClose",
, "zeile drei aus pipe(1) nach wrDefine",
, "vier",
, "--- before piCh1 piEnd",
, "--- after piCh1 piEnd",
, "piCh1 line writeLn pp zwei",
, "piCh1 line writeLn pp fuenf", /* wkOld alt nach drei */
, "piCh1 line writeLn pp sechs nach piEnd",
, "piCh1 line sieben vor close",
, "close piCh1"
call wrTestOut pT, 'piTest begin pipe(1) no wrDefine'
pp = piNew(1)
call piBegin pp
call outLn 'zeile eins aus pipe(1)'
call writeLn pp, 'writeLn pp zwei, disappear no wrDefine'
call outLn 'zeile drei aus pipe(1)', 'vier und Schluss'
call piEnd pp, 1
call wrTestOut pT, 'piTest begin pipe(1) with wrDefine'
call piBegin pp
call outLn 'zeile eins aus pipe(1)'
call writeLn pp, 'writeLn pp zwei'
call wrTestOut pT, 'before piCh1 piWriClose'
call piDefine , "call outLn 'close piCh1'",
, "call outLn 'piCh1 line' m.line"
call outLn 'zeile drei aus pipe(1) nach wrDefine', 'vier'
call writeLn pp, 'writeLn pp fuenf'
call wrTestOut pT, 'before piCh1 piEnd'
call piEnd pp, 0
call wrTestOut pT, 'after piCh1 piEnd'
call writeLn pp, 'writeLn pp sechs nach piEnd', 'sieben vor close'
call wrClose pp
call wrClose pT
call wrTest pT,
, "--- piTest begin pipe(1) immediate",
, "zeile eins aus pipe(1)",
, "--- before piCh1 piWriClose",
, "zeile drei aus pipe(1) nach wrDefine",
, "vier",
, "--- before piCh1 piEnd immediate",
, "piCh1 line writeLn pp zwei",
, "piCh1 line writeLn pp fuenf", /* wkOld alt nach vier */
, "close piCh1",
, "--- after piCh1 piEnd immediate"
call wrTestOut pT, 'piTest begin pipe(1) immediate'
call piBegin pp
call outLn 'zeile eins aus pipe(1)'
call writeLn pp, 'writeLn pp zwei'
call wrTestOut pT, 'before piCh1 piWriClose'
call piDefine , "call outLn 'close piCh1'",
, "call outLn 'piCh1 line' m.line"
call outLn 'zeile drei aus pipe(1) nach wrDefine', 'vier'
call writeLn pp, 'writeLn pp fuenf'
call wrTestOut pT, 'before piCh1 piEnd immediate'
call piEnd pp, 1
call wrTestOut pT, 'after piCh1 piEnd immediate'
call wrClose pT
call wrTest pT,
, "--- piTest begin pipe(2) ",
, "--- before piCh1 piWriClose",
, "outLn piCh2 fuenf nach bar",
, "outLn piCh2 sieben vor wrDefine",
, "--- before piCh2 piDefine",
, "zeile acht aus piCh2 nach wrDefine",
, "vier vor bar",
, "--- before piCh1 piEnd 0",
, "--- after piEnd 0 vor close",
, "piCh2 line zeile eins aus piCh1",
, "piCh2 line zeile drei aus piCh1 nach wrDefine",
, "piCh2 line vier vor bar",
, "piCh2 line piCh1 line writeLn pp zwei", /* wkOld na sechs */
, "piCh2 line piCh1 line writeLn pp sechs",
, "piCh2 line close piCh1",
, "close piCh2"
call wrTestOut pT, 'piTest begin pipe(2) '
pp = piNew(2)
call piBegin pp
call outLn 'zeile eins aus piCh1'
call writeLn pp, 'writeLn pp zwei'
call wrTestOut pT, 'before piCh1 piWriClose'
call piDefine , "call outLn 'close piCh1'",
, "call outLn 'piCh1 line' m.line"
call outLn 'zeile drei aus piCh1 nach wrDefine', 'vier vor bar'
call piBar
call outLn 'outLn piCh2 fuenf nach bar'
call writeLn pp, 'writeLn pp sechs'
call outLn 'outLn piCh2 sieben vor wrDefine'
call wrTestOut pT, 'before piCh2 piDefine'
call piDefine , "call outLn 'close piCh2'",
, "call outLn 'piCh2 line' m.line"
call outLn 'zeile acht aus piCh2 nach wrDefine', 'vier vor bar'
call wrTestOut pT, 'before piCh1 piEnd 0'
call piEnd pp, 0
call wrTestOut pT, 'after piEnd 0 vor close'
call wrClose pp
call wrClose pT
call wrTest pT,
, "--- piTest begin pipe(2) ",
, "--- before piCh1 piWriClose",
, "outLn piCh2 fuenf nach bar",
, "outLn piCh2 sieben vor wrDefine",
, "--- before piCh2 piDefine",
, "zeile acht aus piCh2 nach wrDefine",
, "vier vor bar",
, "--- before piCh1 piEnd 0",
, "--- after piEnd ",
, "piCh2 line zeile eins aus piCh1",
, "piCh2 line zeile drei aus piCh1 nach wrDefine",
, "piCh2 line vier vor bar",
, "piCh2 line piCh1 line writeLn pp zwei", /*wkOld nach sechs*/
, "piCh2 line piCh1 line writeLn pp sechs",
, "piCh2 line piCh1 line neun nach end",
, "piCh2 line piCh1 line zehn schluss",
, "piCh2 line close piCh1",
, "close piCh2"
call wrTestOut pT, 'piTest begin pipe(2) '
pp = piNew(2)
call piBegin pp
call outLn 'zeile eins aus piCh1'
call writeLn pp, 'writeLn pp zwei'
call wrTestOut pT, 'before piCh1 piWriClose'
call piDefine , "call outLn 'close piCh1'",
, "call outLn 'piCh1 line' m.line"
call outLn 'zeile drei aus piCh1 nach wrDefine', 'vier vor bar'
call piBar
call outLn 'outLn piCh2 fuenf nach bar'
call writeLn pp, 'writeLn pp sechs'
call outLn 'outLn piCh2 sieben vor wrDefine'
call wrTestOut pT, 'before piCh2 piDefine'
call piDefine , "call outLn 'close piCh2'",
, "call outLn 'piCh2 line' m.line"
call outLn 'zeile acht aus piCh2 nach wrDefine', 'vier vor bar'
call wrTestOut pT, 'before piCh1 piEnd 0'
call piEnd pp, 0
call wrTestOut pT, 'after piEnd '
call writeLn pp, 'neun nach end', 'zehn schluss'
call wrClose pp
call wrClose pT
call wrTest pT,
, "--- piTestWc chi 4 end 0 writes 0",
, "piCh4 open",
, "--- before piEnd 0",
, "--- before write 0",
, "--- before close",
, "piCh4 line piCh3 open",
, "piCh4 line piCh3 line piCh2 open",
, "piCh4 line piCh3 line piCh2 line piCh1 open",
, "piCh4 line piCh3 line piCh2 line piCh1 close 0 lines and 0",
|| " characters",
, "piCh4 line piCh3 line piCh2 close 2 lines and 46 character",
|| "s",
, "piCh4 line piCh3 close 4 lines and 115 characters",
, "piCh4 close 6 lines and 207 characters"
pp = piNew(4)
call piTestWC pp, pT, 4, 0, 0
call wrClose pT
call wrTest pT,
, "--- piTestWc chi 4 end 1 writes 0",
, "piCh4 open",
, "--- before piEnd 1",
, "piCh4 line piCh3 open",
, "piCh4 line piCh3 line piCh2 open",
, "piCh4 line piCh3 line piCh2 line piCh1 open",
, "piCh4 line piCh3 line piCh2 line piCh1 close 0 lines and 0",
|| " characters",
, "piCh4 line piCh3 line piCh2 close 2 lines and 46 character",
|| "s",
, "piCh4 line piCh3 close 4 lines and 115 characters",
, "piCh4 close 6 lines and 207 characters",
, "--- before write 0",
, "--- before close"
call piTestWC pp, pT, 4, 1, 0
call wrClose pT
call wrTest pT,
, "--- piTestWc chi 4 end 0 writes 4",
, "piCh4 open",
, "--- before piEnd 0",
, "--- before write 4",
, "--- before close", /* wkOld war nach end4 */
, "piCh4 line piCh3 open",
, "piCh4 line piCh3 line piCh2 open",
, "piCh4 line piCh3 line piCh2 line piCh1 open",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 1",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 2",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 3",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 4",
, "piCh4 line piCh3 line piCh2 line piCh1 close 4 lines and 6",
|| "8 characters",
, "piCh4 line piCh3 line piCh2 close 6 lines and 159 characte",
|| "rs",
, "piCh4 line piCh3 close 8 lines and 273 characters",
, "piCh4 close 10 lines and 409 characters"
call piTestWC pp, pT, 4, 0, 4
call wrClose pT
call wrTest pT,
, "--- piTestWc chi 4 end 0 writes 4",
, "--- before piEnd 0",
, "--- before write 4",
, "--- before close",
, "--- wrFromDs stem=abc",
, "piCh4 open",
, "piCh4 line piCh3 open",
, "piCh4 line piCh3 line piCh2 open",
, "piCh4 line piCh3 line piCh2 line piCh1 open",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 1",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 2",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 3",
, "piCh4 line piCh3 line piCh2 line piCh1 line write after en",
|| "d 4",
, "piCh4 line piCh3 line piCh2 line piCh1 close 4 lines and 6",
|| "8 characters",
, "piCh4 line piCh3 line piCh2 close 6 lines and 159 characte",
|| "rs",
, "piCh4 line piCh3 close 8 lines and 273 characters",
, "piCh4 close 10 lines and 409 characters"
pp = piNew(4,0,1)
call piTestWC pp, pT, 4, 0, 4, 'stem=abc'
call wrTestOut pT, 'wrFromDs stem=abc'
call wrFromDS pT, 'stem=abc'
call wrClose pT
call wrTest pT,
, "--- pipe both redirections start",
, "--- after piEnd state c",
, "--- after piClose state c",
, "--- wrFromDs stem=ghi",
, "piCh2 open",
, "piCh2 line def eins",
, "piCh2 line def zwei",
, "piCh2 line def drei",
, "piCh2 close 3 lines and 24 characters"
call wrTestOut pT, 'pipe both redirections start'
pp = piNew(1,1,1)
call wrArgs "def", 0, 'def eins', 'def zwei', 'def drei'
call piBegin pp, 'stem=ghi'
call piDefine , 'call wrFromDs m.wr.out, "stem=def"'
call piBar
call piWC 'piCh2 line', 'piCh2 open', 'piCh2 close'
call piEnd pp
call wrTestOut pT, 'after piEnd state' m.wr.prcSta.pp
call wrClose pp
call wrTestOut pT, 'after piClose state' m.wr.prcSta.pp
call wrTestOut pT, 'wrFromDs stem=ghi'
call wrFromDS pT, 'stem=ghi'
call wrClose pT
call outPop
call wrTestTotal pT
return
endProcedure piTestPipe
piTestWC: procedure expose m.
parse arg pp, pT, cCh, cEnd, cAf, cBeg
call wrTestOut pT, 'piTestWc chi' cCh 'end' cEnd 'writes' cAf
call piBegin pp, cBeg
call piWC 'piCh1 line', 'piCh1 open', 'piCh1 close'
do c=2 to cCh
call piBar
call piWC 'piCh'c 'line', 'piCh'c 'open', 'piCh'c 'close'
end
call wrTestOut pT, 'before piEnd' cEnd
call piEnd pp, cEnd
call wrTestOut pT, 'before write' cAf
do c=1 to cAf
call writeLn pp, 'write after end' c
end
call wrTestOut pT, 'before close'
call wrClose pp
return
endProcedure piTestWC
/* copy piTest end **************************************************/
}¢--- A540769.WK.REXX.O13(PLOAD) cre=2009-12-01 mod=2011-09-07-13.44.11 A540769 ---
/* rexx ****************************************************************
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
7. 9.2011 W. Keller: templates fuer Utility statt jcl alloc
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
7. 9.2011 W. Keller: dsn <= 44 auf für maximal db, ts und parts
1.12.2009 W. Keller: inDDn nicht mehr nötig mit m.load <> ''
13.11.2009 W. Keller: orderTS Option funktioniert wieder
08.08.2008 W. Keller: orderTS Option eingefügt
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
call errReset 'h'
/* Info DSN spezifizieren - hier sind alle LOADS verzeichnet */
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0 /* Debug Funktion ausschalten */
/* Programm Inputparameter (args) verarbeiten */
idN = '' /* idN = pload Nummer */
do wx = 1 to words(args) /* Anzahl Worte in args */
w = word(args, wx) /* w = Wort1,2 - wenn wx=1,2 */
if w = '?' then
call help
else if w = 'D' then /* Anschalten Debug Funktion */
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w /* Wort in '0123456789' - NOMATCH = Default */
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret mainOpt/userOpt */
call interDsn m.mainLib'(mainOpt)' /* m.mainlib = DSN.PLOAD.INFO */
/* überprüfen ob userOpt member existiert */
/* Wenn ja, hat dieses Priorität 1 */
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then /* dsn,member vorhanden? */
call interDsn userOpt /* m.mainlib = DSN.PLOAD.INFO */
/* get next ploadid (idN) */
if idN = '' then
idN = log('nextId') /* get next ploadid from log */
call genId idN /* idN = ploadid ohne N */
/* edit the options dataset with the data to be loaded */
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
call adrIsp "edit dataset('"m.optDsn"')", 4
/* pssss..... warten.... */
/* pssss..... warten.... */
/* pssss..... warten.... */
/* User hat PF3 gedrückt, weiter gehts... */
/* interpret options dataset */
call interDsn m.optDsn /* m.optDsn = DSN.PLOAD.N0186.SRC(OPTIONS) */
/* überprüfen ob Punchfile im Options Member spezifiziert wurde */
if m.punchList = '' then /* m.punchlist aus MAINOPT Member */
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume) /* m.volume aus MAINOPT Member */
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')' /* default value aus mainopt */
/* member, anonsten BLANK */
/* Wenn orderts = 1, dann erst alle copy und unloads
und erst nachher loads,
wenn SONST wegen Referential Integrity TS check pending werden
geht weder copy noch unload */
if m.orderts \= 0 then
m.orderts = 1
do wx=1 to words(m.punchList) /* analyze all punchfiles */
/* 1.Punchfile, dann word = 1 */
/* 2.Punchfile, dann word = 2 */
w = word(m.punchList, wx) /* save current punshfile dsn in w */
call debug 'analyzing punchfile' w vol
/* if m.debug=1 - say xxxxx */
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni /* set m.oo.lastId= 1 */
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- Adress SQL -----------------------------------------------------*/
adrSql: /* 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 do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
/*--- SQL Connect ----------------------------------------------------*/
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("SUBCOM DSNREXX", '*') <> 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
call adrSql "connect" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
/*--- SQL Disconnect -------------------------------------------------*/
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
/*--- Write SQLCA ----------------------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/*--- cleanup at end of program and disconnect from DB2 --------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- generate a SRC datatset for the created ploadid ----------------*/
/*--- Members are PUNCH and OPTIONS ----------------*/
genId: procedure expose m.
parse arg iNum /* iNum = idN (ploadid ohne N) */
m.id = 'N'right(iNum, 4, 0) /* m.id = Nnnnn, e.g N0125 */
/* return punch dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC(PUNCH) */
puDsn = genSrcDsn("PUNCH")
/* format dsn from jcl format to tso format */
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do /* punch dataset existiert bereits */
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* return options dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC */
lib = genSrcDsn()
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
m.optDsn = genSrcDsn('OPTIONS')
/* format dsn from jcl format to tso format */
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then /* m.mgmtClas aus MAINOPT Member */
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contains variables and help ----------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTs'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call mAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
/* write new OPTIONS member */
call writeDsn m.optDsn, m.op.
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
/* DSN.PLOAD.INFO(MAINOPT) */
/* DSN.PLOAD.INFO(userid()) */
/* DSN.PLOAD.INFO(OPTIONS) */
interDsn: procedure expose m.
parse arg dsn /* procedure input variable
in dsn ablegen */
call debug 'interpreting' dsn /* if m.debug=1 - say xxxxx */
call readDsn dsn, x. /* read dataset */
/* concat all the lines */
/* seperate them when a ; was found */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn /* if m.debug=1 - say xxxxx */
return
endProcedure interDsn
/*--- get the next ploadid from DSN.PLOAD.INFO(LOG) -----------------*/
/*--write the next ploadid into DSN.PLOAD.INFO(LOG) -----------------*/
log: procedure expose m.
parse arg fun /* fun = 'nextId' or 'load' */
dsn = m.mainLib'(LOG)'
call readDsn dsn, l. /* read dataset */
zx = l.0 /* Anzahl lines in dsn */
cId = m.id /* next ploadid */
/* für fun = 'load' */
/* next ploadid reservieren */
if fun = 'nextId' then do
id = strip(left(l.zx, 8)) /* ploadid aus log member */
/* pos1-8, e.g. N0125 */
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
/* | = ODER Verknüpfung */
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
/* max ploadid + 1 e.g. max=N0192, next=N0193 */
zx = zx + 1
/* max line dsn + 1 */
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
/* l.zx = N0192 20081112 11:29 newId */
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do /* fun <> 'nextId' or 'load' */
call err 'bad log fun' fun
end
/* write new ploadid in LOG member */
call writeDsn dsn, l., zx /* DSN.pLoad.INFO(LOG) L. 163 */
return substr(cId, 2) /* return next ploadid ohne N */
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
/* w vol, m.treeLd, m.treePn */
pu = readDsnOpen(ooNew(), puDsn) /* open (alloc) punchfile */
/* ooNew() = increment m.oo.lastId (initialised by ooInit proc.) */
/* ooNew() = save punchfile in tree structure. */
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
/* if m.debug=1 - say xxxxx */
end
else do
call debug 'template chunck' m.utilType m.tok
/* if m.debug=1 - say xxxxx */
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then do
if m.load = '' then
call err 'no inDDN for' info
loDdn = overrideLoad(mAddK1(ld, 'INDDN'))
end
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
/* if m.debug=1 - say xxxxx */
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
/* if m.debug=1 - say xxxxx */
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
/* if m.debug=1 - say xxxxx */
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOAD')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOA')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
/* add a second copy template,
to avoid duplicate on the copy before/after */
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNL", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYD) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
call jcl '3 SORTDEVT DISK'
call jcl '3 WORKDDN(TSYUTD,TSOUTD)'
call jcl '3 ERRDDN TERRD MAPDDN TMAPD'
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
/*
call jcl '40SYSMAP DD DISP=(,PASS)',
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005,'
call jcl '46SPACE=(CYL,(1000,5000))'
call jcl '40SYSUT1 DD DISP=(,PASS)',
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005,'
call jcl '46SPACE=(CYL,(1000,5000))'
call jcl '40SORTOUT DD DISP=(,PASS)' ,
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005,'
call jcl '46SPACE=(CYL,(1000,5000))'
call jcl '40SYSERR DD DISP=(,PASS)' ,
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005'
*/ call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx /* mbr = PUNCH oder OPTIONS */
dsn = m.dsnPref'.'m.id'.SRC' /* e.g.dsn = DSN.PLOAD.N0181.SRC */
/* m.dsnpref aus MAINOPT Member */
if mbr = '' then
return dsn /* e.g.dsn = DSN.PLOAD.N0181.SRC */
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')' /* DSN.PLOAD.N0185.SRC(PUNCH) */
/* DSN.PLOAD.N0185.SRC(OPTIONS) */
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then do
if length(dsn) > 44 then
call err 'dsn too long' dsn
return dsn
end
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* 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, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'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
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.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.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil 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
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 showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
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
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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
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
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
lmmRmMbr: procedure
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
/**********************************************************************
adr*: address an environment
***********************************************************************/
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
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 *************************************************/
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/* copy adrSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
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
scanNum(m) : scan integer (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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
/* File einlesen, z.B. PUNCHFILE */
readDsnOpen: procedure expose m.
parse arg oid, spec
/* oid = ooNew(), spec = punchfile(volume) */
x = dsnAlloc(spec, 'SHR', 'RE'oid)
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* x = RE2 call adrTso "free dd(RE2)"; */
dd = word(x, 1)
/* dd = RE2 */
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
/* m.oo.lastid = 1 */
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
/* m.oo.lastid inkrementieren */
/* m.oo.lastid = neue adresse (objekt) erstellen */
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
/* nächste Zeile einlesen */
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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
/*--- 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: readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- 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 (member) ----------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 1))
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
/*--- read dsn, e.g. DSN.PLOAD.INFO(MAINOPT) -------------------------*/
readDSN:
parse arg ggDsnSpec, ggSt
/* DSN.PLOAD.INFO(MAINOPT), ggSt = X.
DSN.PLOAD.INFO(LOG) , ggSt = L. */
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
/* READDSN */ /* X. or L. */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
/* ggAlloc,2 = call adrTso "free dd(READDSN)"; */
return
endSubroutine readDsn
/*--- write dsn, e.g. DSN.PLOAD.INFO(LOG) ----------------------------*/
/*--- write dsn, e.g. DSN.PLOAD.INFO(OPTIONS) ------------------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
/* DSN.PLOAD.INFO(LOG) , ggSt = L., ggCnt = maxline + 1
DSN.PLOAD.INFO(OPTIONS), ggSt = m.op, ggCnt = ''
ggsay = wie m.debug = 1 */
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)' /* READDSN */
/* L. or m.op */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val /* m = ROOT, Ky = ROOT */
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta /* m = ROOT, delta = '' */
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* 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 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 symbol('m.out.ini') == 1 then
return
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.O13(PLOADW) cre=2009-11-13 mod=2009-11-13-15.43.52 A540769 ---
/* rexx ****************************************************************
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
08.08.2008 W. Keller: orderTS Option eingefügt
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
load überschreiben ohne inDDN erlauben|
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
m.testFast = 0 /* args = '' & userId() = 'A540769' */
if m.testFast then
args = 108
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0
idN = '' /* parse arguments */
do wx = 1 to words(args)
w = word(args, wx)
if w = '?' then
call help
else if w = 'D' then
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret main/userOption */
call interDsn m.mainLib'(mainOpt)'
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then
call interDsn userOpt
if idN = '' then /* check/create id options */
idN = log('nextId')
call genId idN
if ^ m.testFast then
call adrIsp "edit dataset('"m.optDsn"')", 4
call interDsn m.optDsn
if m.punchList = '' then
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume)
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')'
m.orderTS = m.orderTS <> 0
do wx=1 to words(m.punchList) /* analyze all punchfiles */
w = word(m.punchList, wx)
call debug 'analyzing punchfile' w vol
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- cleanup at end of program --------------------------------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- debug output if m.debug is set ---------------------------------*/
debug: procedure expose m.
if m.debug then
say 'debug' arg(1)
return
endProcedure debug
/*--- error message an suicide ---------------------------------------*/
err:
parse arg ggMsg
call errA ggMsg, 1
endSubroutine err
/*--- generate an id -------------------------------------------------*/
genId: procedure expose m.
parse arg iNum
m.id = 'N'right(iNum, 4, 0)
/* if punch is present, warn the user
because db2 utility probably was started already */
puDsn = genSrcDsn("PUNCH")
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
if m.testFast then do
say 'weiter wegen m.testFast'
end
else do
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* create the src dataset for this id, if it does not exist */
lib = genSrcDsn()
m.optDsn = genSrcDsn('OPTIONS')
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contents of variables and help -------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTS'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call stAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
call writeDsn m.optDsn, m.op.
m.srcOpt = 1
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
interDsn: procedure expose m.
parse arg dsn
call debug 'interpreting' dsn
call readDsn dsn, x.
/* concat all the lines */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn
return
endProcedure interDsn
/*--- handle the log file --------------------------------------------*/
log: procedure expose m.
parse arg fun
dsn = m.mainLib'(LOG)'
call readDsn dsn, l.
zx = l.0
cId = m.id
if fun = 'nextId' then do /* reserve the next id */
id = strip(left(l.zx, 8))
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
zx = zx + 1
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do
call err 'bad log fun' fun
end
call writeDsn dsn, l., zx
return substr(cId, 2)
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
pu = readDsnOpen(ooNew(), puDsn)
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
end
else do
call debug 'template chunck' m.utilType m.tok
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then
call err 'no inDDN for' info
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOAD')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOAD')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
/* add a second copy template,
to avoid duplicate on the copy before/after */
call jcl '2 TEMPLATE TCOPYQ'
call jcl '2 ' ,
"DSN('&SSID..&DB..&SN..Q&PART(2)..D&DATE(3)..T&TIME.')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNLO", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYQ) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
call jcl '40SYSMAP DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSUT1 DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SORTOUT DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSERR DD SYSOUT=*'
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx
dsn = m.dsnPref'.'m.id'.SRC'
if mbr = '' then
return dsn
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')'
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then
return dsn
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* 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, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'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
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.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.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil 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
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 showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() '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
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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
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
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
lmmRmMbr: procedure
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
/**********************************************************************
adr*: address an environment
***********************************************************************/
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
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 adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* 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 do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("SUBCOM DSNREXX", '*') <> 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
call adrSql "connect" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/* copy adrSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
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
scanNum(m) : scan integer (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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
readDsnOpen: procedure expose m.
parse arg oid, spec
x = dsnAlloc(spec, 'SHR', 'RE'oid)
dd = word(x, 1)
call readDDBegin dd
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
readCatOpen: procedure expose m.
parse arg oid, src
if symbol("m.oo.oid.readCatOid") ^= 'VAR' then
m.oo.oid.readCatOid = ooNew()
catOid = m.oo.oid.readCatOid
ox = 0
do ix=2 to arg()
s = arg(ix)
do while s <> ''
ex = pos('$', s)
if ex > 0 then do
w = strip(left(s, ex-1))
s = substr(s, ex+1)
end
else do
w = strip(s)
s = ''
end
if w ^= '' then do
ox = ox + 1
m.oo.oid.readCat.ox = w
end
end
end
m.oo.oid.readCat.0 = ox
m.oo.oid.readCatIx = 0
call ooDefRead catOid, 'res=0'
return ooDefRead(oid, 'res = readCat("'oid'", var);',
, 'call readCatClose "'oid'";')
endProcedure readCatOpen
readCat: procedure expose m.
parse arg oid, var
catOid = m.oo.oid.readCatOid
do forever
if ooRead(catOid, var) then
return 1
catIx = m.oo.oid.readCatIx + 1
if catIx > 1 then
call ooReadClose catOid
if catIx > m.oo.oid.readCat.0 then
return 0
m.oo.oid.readCatIx = catIx
src = m.oo.oid.readCat.catIx
if left(src, 1) = '&' then
call ooReadStemOpen catOid, strip(substr(src, 2))
else
call readDsnOpen catOid, src
end
endProcedure readCat
readCatClose: procedure expose m.
parse arg oid
if m.oo.oid.readCatIx > 0 then
call ooReadClose m.oo.oid.readCatOid
return
endProcedure readCatClose
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
call ooIni
/* ri = readDsnOpen(ooNew(), 'wk.text(testin)') */
call ooArgs2Stem aaa, 1, 'aaa.1 eins', 'aaa.2 zwei', 'aaa.3 drei'
ri = readCatOpen(ooNew(), "&AAA $ wk.text(testin) ",,'&' aaa,
, 'wk.text(msk1) $ &AAA')
do i=1 by 1 while ooRead(ri, line)
say 'line' i strip(m.line, 't')
end
call ooReadClose ri
exit
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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
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, 1))
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 m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* copy m 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 *****************************************************/
}¢--- A540769.WK.REXX.O13(PLOAD0) cre=2009-12-01 mod=2009-12-01-14.52.58 A540769 ---
/* rexx ****************************************************************
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
08.08.2008 W. Keller: orderTS Option eingefügt
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
load überschreiben ohne inDDN erlauben|
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
/* Info DSN spezifizieren - hier sind alle LOADS verzeichnet */
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0 /* Debug Funktion ausschalten */
/* Programm Inputparameter (args) verarbeiten */
idN = '' /* idN = pload Nummer */
do wx = 1 to words(args) /* Anzahl Worte in args */
w = word(args, wx) /* w = Wort1,2 - wenn wx=1,2 */
if w = '?' then
call help
else if w = 'D' then /* Anschalten Debug Funktion */
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w /* NOMATCH = Default
Check Wortn IN '0123456789'
????? */
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret mainOpt/userOpt */
call interDsn m.mainLib'(mainOpt)' /* m.mainlib = DSN.PLOAD.INFO */
/* überprüfen ob userOpt member existiert */
/* Wenn ja, hat dieses Priorität 1 */
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then /* dsn,member vorhanden? */
call interDsn userOpt /* m.mainlib = DSN.PLOAD.INFO */
/* get next ploadid (idN) */
if idN = '' then
idN = log('nextId') /* get next ploadid from log */
call genId idN /* idN = ploadid ohne N */
/* edit the options dataset with the data to be loaded */
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
call adrIsp "edit dataset('"m.optDsn"')", 4
/* pssss..... warten.... */
/* pssss..... warten.... */
/* pssss..... warten.... */
/* User hat PF3 gedrückt, weiter gehts... */
/* interpret options dataset */
call interDsn m.optDsn /* m.optDsn = DSN.PLOAD.N0186.SRC(OPTIONS) */
/* überprüfen ob Punchfile im Options Member spezifiziert wurde */
if m.punchList = '' then /* m.punchlist aus MAINOPT Member */
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume) /* m.volume aus MAINOPT Member */
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')' /* default value aus mainopt */
/* member, anonsten BLANK */
/* Wenn orderts = 1, dann erst alles laden dann copy. */
/* Dies aufgrund der probleme mit refrential integrity */
if m.orderts <> 0 then
m.orderts = 1
do wx=1 to words(m.punchList) /* analyze all punchfiles */
/* 1.Punchfile, dann word = 1 */
/* 2.Punchfile, dann word = 2 */
w = word(m.punchList, wx) /* save current punshfile dsn in w */
call debug 'analyzing punchfile' w vol
/* if m.debug=1 - say xxxxx */
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni /* set m.oo.lastId= 1 */
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- Adress SQL -----------------------------------------------------*/
adrSql: /* 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 do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
/*--- SQL Connect ----------------------------------------------------*/
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("SUBCOM DSNREXX", '*') <> 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
call adrSql "connect" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
/*--- SQL Disconnect -------------------------------------------------*/
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
/*--- Write SQLCA ----------------------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/*--- cleanup at end of program and disconnect from DB2 --------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- debug output if m.debug is set -- m.debug = 1 ------------------*/
debug: procedure expose m.
if m.debug then
say 'debug' arg(1)
return
endProcedure debug
/*--- error message an suicide ---------------------------------------*/
err:
parse arg ggMsg
call errA ggMsg, 1
endSubroutine 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 ------------------------------------------------*/
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
/*--- generate a SRC datatset for the created ploadid ----------------*/
/*--- Members are PUNCH and OPTIONS ----------------*/
genId: procedure expose m.
parse arg iNum /* iNum = idN (ploadid ohne N) */
m.id = 'N'right(iNum, 4, 0) /* m.id = Nnnnn, e.g N0125 */
/* return punch dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC(PUNCH) */
puDsn = genSrcDsn("PUNCH")
/* format dsn from jcl format to tso format */
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do /* punch dataset existiert bereits */
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* return options dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC */
lib = genSrcDsn()
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
m.optDsn = genSrcDsn('OPTIONS')
/* format dsn from jcl format to tso format */
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then /* m.mgmtClas aus MAINOPT Member */
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contains variables and help ----------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTs'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call mAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
/* write new OPTIONS member */
call writeDsn m.optDsn, m.op.
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
/* DSN.PLOAD.INFO(MAINOPT) */
/* DSN.PLOAD.INFO(userid()) */
/* DSN.PLOAD.INFO(OPTIONS) */
interDsn: procedure expose m.
parse arg dsn /* procedure input variable
in dsn ablegen */
call debug 'interpreting' dsn /* if m.debug=1 - say xxxxx */
call readDsn dsn, x. /* read dataset */
/* concat all the lines */
/* seperate them when a ; was found */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn /* if m.debug=1 - say xxxxx */
return
endProcedure interDsn
/*--- get the next ploadid from DSN.PLOAD.INFO(LOG) -----------------*/
/*--write the next ploadid into DSN.PLOAD.INFO(LOG) -----------------*/
log: procedure expose m.
parse arg fun /* fun = 'nextId' or 'load' */
dsn = m.mainLib'(LOG)'
call readDsn dsn, l. /* read dataset */
zx = l.0 /* Anzahl lines in dsn */
cId = m.id /* next ploadid */
/* für fun = 'load' */
/* next ploadid reservieren */
if fun = 'nextId' then do
id = strip(left(l.zx, 8)) /* ploadid aus log member */
/* pos1-8, e.g. N0125 */
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
/* | = ODER Verknüpfung */
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
/* max ploadid + 1 e.g. max=N0192, next=N0193 */
zx = zx + 1
/* max line dsn + 1 */
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
/* l.zx = N0192 20081112 11:29 newId */
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do /* fun <> 'nextId' or 'load' */
call err 'bad log fun' fun
end
/* write new ploadid in LOG member */
call writeDsn dsn, l., zx /* DSN.pLoad.INFO(LOG) L. 163 */
return substr(cId, 2) /* return next ploadid ohne N */
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
/* w vol, m.treeLd, m.treePn */
pu = readDsnOpen(ooNew(), puDsn) /* open (alloc) punchfile */
/* ooNew() = increment m.oo.lastId (initialised by ooInit proc.) */
/* ooNew() = save punchfile in tree structure. */
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
/* if m.debug=1 - say xxxxx */
end
else do
call debug 'template chunck' m.utilType m.tok
/* if m.debug=1 - say xxxxx */
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then
call err 'no inDDN for' info
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
/* if m.debug=1 - say xxxxx */
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
/* if m.debug=1 - say xxxxx */
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
/* if m.debug=1 - say xxxxx */
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOAD')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOAD')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
/* add a second copy template,
to avoid duplicate on the copy before/after */
call jcl '2 TEMPLATE TCOPYQ'
call jcl '2 ' ,
"DSN('&SSID..&DB..&SN..Q&PART(2)..D&DATE(3)..T&TIME.')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNLO", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYQ) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
call jcl '40SYSMAP DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSUT1 DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SORTOUT DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSERR DD SYSOUT=*'
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx /* mbr = PUNCH oder OPTIONS */
dsn = m.dsnPref'.'m.id'.SRC' /* e.g.dsn = DSN.PLOAD.N0181.SRC */
/* m.dsnpref aus MAINOPT Member */
if mbr = '' then
return dsn /* e.g.dsn = DSN.PLOAD.N0181.SRC */
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')' /* DSN.PLOAD.N0185.SRC(PUNCH) */
/* DSN.PLOAD.N0185.SRC(OPTIONS) */
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then
return dsn
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* 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, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'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
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.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.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil 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
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 showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
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
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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
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
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
lmmRmMbr: procedure
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
/**********************************************************************
adr*: address an environment
***********************************************************************/
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
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 *************************************************/
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/* copy adrSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
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
scanNum(m) : scan integer (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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
/* File einlesen, z.B. PUNCHFILE */
readDsnOpen: procedure expose m.
parse arg oid, spec
/* oid = ooNew(), spec = punchfile(volume) */
x = dsnAlloc(spec, 'SHR', 'RE'oid)
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* x = RE2 call adrTso "free dd(RE2)"; */
dd = word(x, 1)
/* dd = RE2 */
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
/* m.oo.lastid = 1 */
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
/* m.oo.lastid inkrementieren */
/* m.oo.lastid = neue adresse (objekt) erstellen */
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
/* nächste Zeile einlesen */
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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
/*--- 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: readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- 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 (member) ----------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 1))
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
/*--- read dsn, e.g. DSN.PLOAD.INFO(MAINOPT) -------------------------*/
readDSN:
parse arg ggDsnSpec, ggSt
/* DSN.PLOAD.INFO(MAINOPT), ggSt = X.
DSN.PLOAD.INFO(LOG) , ggSt = L. */
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
/* READDSN */ /* X. or L. */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
/* ggAlloc,2 = call adrTso "free dd(READDSN)"; */
return
endSubroutine readDsn
/*--- write dsn, e.g. DSN.PLOAD.INFO(LOG) ----------------------------*/
/*--- write dsn, e.g. DSN.PLOAD.INFO(OPTIONS) ------------------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
/* DSN.PLOAD.INFO(LOG) , ggSt = L., ggCnt = maxline + 1
DSN.PLOAD.INFO(OPTIONS), ggSt = m.op, ggCnt = ''
ggsay = wie m.debug = 1 */
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)' /* READDSN */
/* L. or m.op */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val /* m = ROOT, Ky = ROOT */
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta /* m = ROOT, delta = '' */
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* copy m end *********************************************************/
/*--- 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 *****************************************************/
}¢--- A540769.WK.REXX.O13(POS) cre= mod= ---------------------------------------
/* copy pos begin *****************************************************
StringHandling
pos*: several repetitions of pos (from left or right)
dsn*: convenience functions using pos* for dataset names
***********************************************************************/
/*--- return the index of rep'th occurrence of needle
negativ rep are counted from right -------------------------*/
posRep: procedure
parse arg needle, hayStack, rep, start
if rep > 0 then do
if start = '' then
start = 1
do cc = 1 to rep
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return sx
end
else if rep < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -rep
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return sx
end
else
return 0
endProcedure posRep
/*--- return n'th level (separated by needle, negative from right) ---*/
posLev: procedure
parse arg needle, hayStack, rep, start
if rep > 1 then do
sx = posRep(needle, hayStack, rep-1, start)
if sx < 1 then
return 0
return 1+sx
end
else if rep < -1 then do
sx = posRep(needle, hayStack, rep+1, start)
if sx < 1 then
return 0
return 1+lastPos(needle, hayStack, sx-1)
end
else if rep ^= -1 then
return rep /* for 0 and 1 */
else if start == '' then /* pos fails with empty start| */
return 1 + lastPos(needle, hayStack)
else
return 1 + lastPos(needle, hayStack, start)
endProcedure posLev
/*--- 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)
cnt = 0
do forever
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
cnt = cnt + 1
start = start + length(needle)
end
endProcedure posCount
/*--- concatenate several parts to a dsn -----------------------------*/
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
/*--- set the membername mbr into dsn --------------------------------*/
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
endProcedure dsnSetMbr
/*--- get the membername from dsn ------------------------------------*/
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), 't', "'")
endProcedure dsnGetMbr
/*--- get the index of the lx'd level of dsn -------------------------*/
dsnPosLev: procedure
parse arg dsn, lx
sx = posLev('.', dsn, lx)
if sx ^= 1 then
return sx
else
return 1 + (left(dsn, 1) == "'")
endProcedure dsnPosLev
/*--- get the the lx'd level of dsn ----------------------------------*/
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
/* copy pos end ****************************************************/
}¢--- A540769.WK.REXX.O13(POVMONKO) cre= mod= ----------------------------------
/* rexx *************************************************************
POV Monats Statistik Kollektor
Ueberblick
Alloziert die Monats Files
lässt TS5240 laufen (Die Tagesfile müssen im JCL alloziert werden)
falls TS5240 einen Returncode 0 zurückgibt
wird das alte Monatsfile gesavt und durch das neue ersetzt
sonst
wird das neue Monatsfile auf .....ER<Datum> umbenannt
die (fehlerfreien) neuen Monatsfiles werden auf RZ1 transferiert
Parameter: 4 space getrennte Worte ('*' oder '' für Default)
1. Wort: MonatVon (yyMM), default letzter Monat
2. Wort: MonatBis (yyMM), default aktueller Monat
3. Wort: dsnPrefix für MonatsFiles, default 'OMS.DIV.P0.STAT.'rz
4. Wort: 'SV': erstelle jeden Tag einen Save vom InputMonatsfile
mit suffix .SVjjmmtt, kein Save falls 4. Wort leer
FileNamen
mit jj zweistelliges Jahr, mm Monat , tt Tag
zzz RZ Name (RZ1, RZ2, RZ4)
OMS.DIV.P0.STAT.zzz.YjjMoo (altes) Monatsfile
OMS.DIV.P0.STAT.zzz.YjjMoo.NEW (neues) Monatsfile
OMS.DIV.P0.STAT.zzz.YjjMoo.SVjjoott Save des alten Monatsfile
OMS.DIV.P0.STAT.zzz.YjjMoo.ERjjoott Fehlerhaftes neues Monatsfile
History
12.11.04 Walter Keller, KPCO4 neu
10.12.04 Walter Keller, Parameter eingebaut
*********************************************************************/
/*********************************************************************
main code BEGIN
*********************************************************************/
parse arg monatVon monatBis dsnPref svSuf
say 'start POV Monats Statistik Kollektor'
say ' Version 0.2 OMS.DIV.P0.CLIST(POVMONKO)'
rz = sysvar('SYSNODE')
if dsnPref = '' | dsnPref = '*' then
dsnPref = 'OMS.DIV.P0.STAT.'rz
say ' in RZ' rz 'dsnPrefix' dsnPref
today = date('s')
if monatVon <> '' & monatVon <> '*' then
monatVon = checkMonat(monatVon)
else if substr(today, 5, 2) > '01' then
monatVon = substr(today, 3, 4) - 1
else
monatVon = substr(today, 3, 4) - 89
if monatBis = '' | monatBis = '*' then
monatBis = substr(today, 3, 4)
else
monatBis = checkMonat(monatBis)
say ' Monate' translate(format(monatVon, 4), '0' , ' ') ,
'-' translate(format(monatBis, 4), '0' , ' ')
erSuf = 'ER' || right(today, 6)
if svSuf = '' | svSuf = '*' then do
svSuf = ''
say ' ohne save errorSuffix' erSuf
end
else do
if length(svSuf) > 2 then
svSuf = left(svSuf, 2)
svSuf = svSuf || right(today, 6)
say ' save mit suffix' svSuf 'errorSuffix' erSuf
end
call allocateDsn
call adrTso "call *(ts5240) 't'"
call freeRename (adrTsoRc = 0)
exit
if rz ^= 'RZ1' then
call transferDsn /* transfer new datasets to rz1 */
return /* main */
/*********************************************************************
main code END
*********************************************************************/
checkMonat: procedure
parse arg ym
if verify(ym, '0123456789') <> 0 then
call err('monat nicht numerisch:' ym)
else if ym > 9999 then
call err('monat hat mehr als 4 Stellen (yymm):' ym)
if ym // 100 < 1 | ym // 100 > 12 then
call err('monat nicht zischen 1 und 12:' ym)
return ym /* checkMonat */
allocateDsn:
/*********************************************************************
generate Datasetnames
allocate month input and output DD's for current and previous month
*********************************************************************/
ym = monatVon
monatBis = translate(format(monatBis, 4), '0', ' ')
do i=1 by 1 /* compute fileNames */
yymm.i = translate(format(ym // 10000, 4), '0', ' ')
dsn.i = dsnPref'.Y'left(yymm.i, 2)'M'right(yymm.i, 2)
if yymm.i = monatBis then
leave
if ym // 100 >= 12 then
ym = ym + 89
else
ym = ym + 1
end
hix = i
say hix 'monate' yymm.1 '-' yymm.hix 'save' svSuf 'pref' dsnPref
like = ''
do i=1 to hix /* allocate mon in */
if sysDsn("'"dsn.i"'") = 'OK' then do
if like = '' then
like = "'"dsn.i"'"
call adrTso "alloc dd(MoIn"yymm.i") shr reuse",
"dsn('"dsn.i"')"
end
else
call adrTso "alloc dd(MoIn"yymm.i") reuse dummy"
end
if like = '' then
call err 'no existing dataset found from ' dsn.1 'to' dsn.hix
do i=1 to hix /* allocate mon out */
dsn = "'"dsn.i".NEW'"
if sysDsn(dsn) = 'OK' then
call adrTso "delete" dsn
call adrTso "alloc dd(MoOu"yymm.i") new catalog reuse",
" dsn("dsn") like("like") MGMTCLAS(S005N000)"
end
return; /* allocateDsn */
freeRename:
/*********************************************************************
free and rename the month Datasets depending on result
*********************************************************************/
parse arg ok
do i=1 to hix
call adrTso "free dd(MoIn"yymm.i")"
ff = listDsi('MoOu'yymm.i file)
if ff ^= 0 then
call err 'rc' ff 'from listDsi(MoOu'yymm.i 'file)',
'reason' sysReason
say 'listDsi(moOu'yymm.i') use' sysUsed 'alloc'sysAlloc sysUnits
if sysUsed = 0 then do
call adrTso "free dd(MoOu"yymm.i") delete"
end
else do
call adrTso "free dd(MoOu"yymm.i") catalog"
if ok then do
if sysDsn("'"dsn.i"'") = 'OK' then do
if svSuf = '' then
call adrTso "delete '"dsn.i"'"
else if sysDsn("'"dsn.i"."svSuf"'") = 'OK' then
call adrTso "delete '"dsn.i"'"
else
call adrTso "rename '"dsn.i"' '"dsn.i"."svSuf"'"
end
call adrTso "rename '"dsn.i".NEW' '"dsn.i"'"
transfer.i = 1
end
else do
if sysDsn("'"dsn.i"."erSuf"'") = 'OK' then
call adrTso "delete '"dsn.i"."erSuf"'"
call adrTso "rename '"dsn.i".NEW' '"dsn.i"."erSuf"'"
end
end
end
return /* freeRename */
transferDsn:
/*********************************************************************
transfer the newly created/modified month files to RZ1
*********************************************************************/
do i=1 to hix
say 'transfer.'i transfer.i
if transfer.i = 1 then
call connectDirect dsn.i, 'RZ1', dsn.i
end
return /* end transfer */
connectDirect: procedure
/*******************************************************************
send the file frDsn from the current not
to the node toNode as toDsn
using connect direct
********************************************************************/
parse upper arg frDsn, toNode, toDsn
say 'sending' frDsn 'to' toNode toDsn 'with connect direct'
call adrTso "alloc shr dd(sysut1) reuse dsn('"frDsn"')"
call adrTso "alloc new delete dd(DDIN) dsn("tempPref()".ddin)" ,
"recfm(f,b) lrecl(80)"
t.1 ="DSN='"toDsn"'"
t.2 ="DEST='"toNode"'"
t.3 ="MGMTCLAS='S005N000'"
t.4 ="DSNCOPY='YES'"
call adrTso 'EXECIO 4 DISKW DDIN (STEM t. FINIS)'
if 0 then do
call adrTso 'EXECIO * DISKr DDIN (STEM r. FINIS)'
say 'read' r.0
do i=1 to r.0
say i r.i
end
end
call adrTso "call *(OS2900)"
/* call adrTso 'free dd(sysut1)' a ghost freed it already */
call adrTso 'free dd(ddin) delete'
/* os2900 does not free it dd's, so we do it
otherwise the second run will fail... */
call adrTso 'free dd(ddPrint)'
call adrTso 'free dd(work01)'
call adrTso 'free dd(cmdout)'
call adrTso 'free dd(dmprint)'
say 'end connectDirect'
return /* end connectDirect */
tempPref: procedure
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
return d /* end tempPref */
adrTso:
parse arg tsoCmd
/* say 'adrTso' tsoCmd */
address tso tsoCmd
adrTsoRc = rc
say 'adrTso rc' adrTsoRc 'for' tsoCmd
return
err:
parse arg errMsg
say 'fatal error:' errMsg
exit 12
}¢--- A540769.WK.REXX.O13(PRB) cre=2013-02-01 mod=2013-11-08-11.34.21 A540769 ---
/* rexx ---------------------------------------------------------------
edit macro fuer prb Columns 8.11.13 kidi 63
Walter Keller
line Commands
d: replace deleted lines with generate columns
a: b: add generated columns there
Options in First word of argument
g: tacct_general table (default)
p: tacct_program table
s: sum on numeric columns
e: fosFmte7 on numeric columns plus totals
n: add all numeric columns (not just the short list)
r: surround numeric columns with real
c: add all not numeric columns
second and following (space separated) words of argument
a<alias>: alias (default g)
e<expr> : sql expression with ~(tilde) placeHolder for current column
8.11.13 walter r=real option added to avoid fixpoint overflow
----------------------------------------------------------------------*/
call errReset hi
call mapIni
call adrEdit 'macro (args) NOPROCESS'
if pos('?', args) > 0 then
return help()
pc = adrEdit("process dest range D", 0 4 8 12 16)
if pc = 16 then
call err 'Only A or B line expected, \n ' ,
'You entered incomplete or conflicting line commands'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
m.dst = rFi - 1
call adrEdit 'delete' rFi rLa
end
if pc = 0 | pc = 4 then do
call adrEdit "(d1) = lineNum .zDest", 0 4
m.dst = d1 /* rc=4 ist lineNum 0| */
end
if pc = 12 then do
call adrEdit "(c1, c2) = cursor"
m.dst = c1
end
call addLine '-- begin prb insert' args
parse var args arg1 argR
argR = ' 'argR
if pos('p', arg1) > 0 then
tb = 'program'
else
tb = 'general'
txt = '-- tacct_'tb
i = mapInline('prb_'tb)
m.alias = left(tb, 1)
cx = pos(' a', argR)
if cx > 0 then
m.alias = word(substr(argR, cx+2), 1)
txt = strip(txt m.alias)','
if m.alias \== '' then
m.alias = m.alias'.'
m.e7 = pos('e', arg1) > 0
if m.e7 then
txt = txt 'fsoFmtE7,'
allNum = pos('n', arg1) > 0
notNum = pos('c', arg1) > 0
txt = txt word('short all', allNum + 1)','
m.expr = '~'
cx = pos(' e', argR)
if cx > 0 then
m.expr = word(substr(argR, cx+2), 1)
if pos('r', arg1) > 0 then
m.expr = repAll(m.expr, '~', 'real(~)')
if pos('s', arg1) > 0 then
m.expr = 'sum('m.expr')'
if length(txt m.expr) > 65 then do
call addLine txt
txt = '-- '
end
call addLine txt 'expr' m.expr
listExt = 0
do ix=1 to m.i.0
if abbrev(word(m.i.ix, 1), '*') then do
listExt = 1
iterate
end
parse var m.i.ix cNo col typ len 52 as 62
if cNo == 'f' then do
as = subWord(m.i.ix, 3)
fArgs = CLines()
if m.e7 then
call addFunction col, fArgs, as
iterate
end
if cNo == '+' then do
fArgs = CLines()
if m.e7 then
call addPlus typ, fArgs, as
iterate
end
if wordPos(typ, 'REAL FLOAT INTEGER SMALLINT DECIMAL') ,
< 1 then do
if notNum then
call addLine ' ,' haCol('as', col, as)
iterate
end
if listExt & (c.col == 1 | \ allNum) then
iterate
c.col = 1
call addLine ' ,' haCol('ages', col, as)
end
call addLine '-- end prb insert' args
exit
/*--- read all following c lines and return its words ---------------*/
cLines: procedure expose m. i ix
r = ''
do ix=ix+1 to m.i.0 while abbrev(m.i.ix, 'c ')
r = r strip(substr(m.i.ix, 3))
end
ix = ix - \ abbrev(m.i.ix, 'c ')
return r
endProcedure cLines
/*--- handle one column
opts: a=add alias
g=aggregate
e=fmtE7
s=as column name --------------------------------------*/
haCol: procedure expose m.
parse arg opts, col, as
r = col
if pos('a', opts) > 0 then
r = m.alias || r
r1 = r
if pos('g', opts) > 0 then
r = repAll(m.expr, '~', r)
if pos('e', opts) > 0 & m.e7 then
r = 'fosFmtE7('r')'
if pos('s', opts) > 0 then
if m.e7 & as \== '' then
r = r '"'strip(as)'"'
else if r1 <> r then
r = r col
return r
endProcedure haCol
/*--- handle non numeric column
opts: a=add alias
g=aggregate
e=fmtE7
s=as column name --------------------------------------*/
/*--- add one function
, arguments with alias and aggregate and AS ".." ---------------*/
addFunction: procedure expose m.
parse arg fun, aCols, as
t = ''
do ax=1 to words(aCols)
t = t',' haCol('ag', word(aCols, ax))
end
t = fun'('substr(t, 3)') "'strip(as)'"'
call addLineSplit t, ','
return
endProcedure addFunction
/*--- add one function
, arguments with alias and aggregate and AS ".." ---------------*/
addPlus: procedure expose m.
parse arg fun, aCols, as
t = ''
do ax=1 to words(aCols)
t = t '+' haCol('a', word(aCols, ax))
end
t = haCol('g', '('substr(t, 4)')')
if fun == '-' then
t = haCol('e', t)
else
t = strip(fun)'('t')'
call addLineSplit t '"'strip(as)'"', '+'
return
endProcedure addPlus
addLine: procedure expose m.
parse arg li
call adrEdit "line_after" m.dst " = (li)"
m.dst = m.dst + 1
return
endProcedure addLine
addLineSplit: procedure expose m.
parse arg src, spl
r = ' ,' src
do while length(r) > 70
lx = lastPos(spl, r, 70)
call addLine left(r, lx-1)
r = ' ' substr(r, lx)
end
call addLIne r
return
endProcedure addLIneSPlit
$</prb_general/
*** PBDD.TACCT_GENERAL
32 ELAPSETOD FLOAT 8 totElap
33 ELAPSETCB FLOAT 8 totCPU
37 EDB2TOD FLOAT 8 db2Elap
38 EDB2TCB FLOAT 8 db2CPU
f fosGeWait wait % 1. % 2. % 3.
c eWaitIO waitReadIO waitWriteIO openClsElap
c datasetElap eWaitLAL
c sysLgRngElap logWrtElap waitArcLog archReadWar
c drainLkWDR claimRlWcl
c gblLokElap wtelawtk wtelawtm wtelawtn
c wtelawto wtelawtq gblMsgElap
c waitSyncEvent otherSWElap spWaitElap
c funcWait lobWaitElap
+ - - sqls
c p2Commits aborts
c selects inserts updates deletes
c describes prepares opens fetches closes
c setcurprec dclglobaltt sqlcrgtt
35 P2COMMITS FLOAT 8 commit
36 ABORTS FLOAT 8 abort
132 SELECTS FLOAT 8
133 INSERTS FLOAT 8
134 UPDATES FLOAT 8
135 DELETES FLOAT 8
136 DESCRIBES FLOAT 8
137 PREPARES FLOAT 8
138 OPENS FLOAT 8
139 FETCHES FLOAT 8
140 CLOSES FLOAT 8
86 LOGWRTELAP FLOAT 8 logEla
88 LOGRECORDS FLOAT 8 logRecs
89 LOGBYTES FLOAT 8 logByte
153 BPGETPAGE FLOAT 8
154 BPPGUPDAT FLOAT 8
155 BPSYNCRD FLOAT 8
156 BPPREFET FLOAT 8
157 BPSYNCWR FLOAT 8
158 BPLISTPREF FLOAT 8
159 BPDPF FLOAT 8
160 BPNGT FLOAT 8
161 BPSIO FLOAT 8
+ - REAL wait
c eWaitIO waitReadIO waitWriteIO openClsElap
c datasetElap eWaitLAL
c sysLgRngElap logWrtElap waitArcLog archReadWar
c drainLkWDR claimRlWcl
c gblLokElap wtelawtk wtelawtm wtelawtn
c wtelawto wtelawtq gblMsgElap
c waitSyncEvent otherSWElap spWaitElap
c funcWait lobWaitElap
*** PBDD.TACCT_GENERAL
1 OCCURRENCES INTEGER 4
2 SYSTEMID CHAR 4
3 SUBSYSTEM CHAR 4
4 PLANNAME CHAR 8
5 AUTHID CHAR 8
6 CONNECTION CHAR 8
7 CORRID CHAR 12
8 ORIGPRIMID CHAR 8
9 LUWIDNID CHAR 8
10 LUWIDLUNM CHAR 8
11 LUWIDINST CHAR 6
12 LUWIDCOMIT FLOAT 8
13 CONNTYPE CHAR 8
14 DATETIME TIMESTMP 10
15 DATE DATE 4
16 LOCATION CHAR 16
17 GROUPNAME CHAR 8
18 FIRSTPKG CHAR 18
19 ACCTTOKN CHAR 22
20 ENDUSERID CHAR 16
21 ENDUSERTX CHAR 32
22 ENDUSERWN CHAR 18
23 PSTNUMBER CHAR 4
24 PSBNAME CHAR 8
25 CICSTRAN CHAR 4
26 CORRNAME CHAR 8
27 NETWORKID CHAR 16
28 TRANSCNT FLOAT 8
29 CLASS2CNT FLOAT 8
30 CLASS3CNT FLOAT 8
31 IFCIDSEQ# FLOAT 8
32 ELAPSETOD FLOAT 8
33 ELAPSETCB FLOAT 8
34 ELAPSESRB FLOAT 8
35 P2COMMITS FLOAT 8
36 ABORTS FLOAT 8
37 EDB2TOD FLOAT 8
38 EDB2TCB FLOAT 8
39 EDB2SRB FLOAT 8
40 EWAITIO FLOAT 8 synIOWait
41 EWAITLAL FLOAT 8 locLoLaWait
42 ENTEXEVNT FLOAT 8
43 WAITEVNT FLOAT 8
44 WAITREADIO FLOAT 8 othReaWait
45 WAITWRITEIO FLOAT 8 othWriWait
46 WAITSYNCEVENT FLOAT 8 uniSwiWait
47 WAITARCLOG FLOAT 8 arcLogWait
48 WEVLOCK FLOAT 8
49 WEVREAD FLOAT 8
50 WEVWRITE FLOAT 8
51 WEVSYNCH FLOAT 8
52 CLASS1CPU_ZIIP FLOAT 8
53 CLASS2CPU_ZIIP FLOAT 8
54 TRIGGERCPU_ZIIP FLOAT 8
55 CPUZIIPELIGIBLE FLOAT 8
56 ARCLOG FLOAT 8
57 DRAINLKRND FLOAT 8
58 DRAINLKWDR FLOAT 8 drainWait
59 CLAIMRLWCL FLOAT 8 claimWait
60 CLAIMRLRNC FLOAT 8
61 ARCHREADWAR FLOAT 8 arcReaWait
62 ARCHREADNAR FLOAT 8
63 OPENCLSELAP FLOAT 8 opeCloWait
64 SYSLGRNGELAP FLOAT 8 sysLgRaWait
65 DATASETELAP FLOAT 8 datSetWait
66 OTHERSWELAP FLOAT 8 othSwiEla
67 OPENCLSEVNT FLOAT 8
68 SYSLGRNGEVNT FLOAT 8
69 DATASETEVNT FLOAT 8
70 OTHERSWEVNT FLOAT 8
71 LATCHCNTWTP FLOAT 8
72 LATCHCNTRNH FLOAT 8
73 GBLMSGELAP FLOAT 8 gblMsgWait s
74 GBLMSGEVNT FLOAT 8
75 GBLLOKELAP FLOAT 8 gblConWait s
76 GBLLOKEVNT FLOAT 8
77 SPTCB FLOAT 8 stoProCpu c1 nurWLM
78 SPTCBINDB2 FLOAT 8 stoProDb2 c2
79 SPEVNT FLOAT 8
80 SPWAITELAP FLOAT 8 stoProWait
81 SPWAITCNT FLOAT 8
82 PARATASKS FLOAT 8
83 PARALLTASKS FLOAT 8
84 CPUSUCONV FLOAT 8
85 LOGWRTEVNT FLOAT 8
86 LOGWRTELAP FLOAT 8 logWrtWait
87 WLMSVCCLASS CHAR 8
88 LOGRECORDS FLOAT 8
89 LOGBYTES FLOAT 8
90 FUNCTCB FLOAT 8 funcCpu c1 cpu
91 FUNCSQLTCB FLOAT 8 funcD2Cpu c2 cpu
92 FUNCSQLEVNT FLOAT 8
93 LOBWAITCNT FLOAT 8
94 FUNCWAIT FLOAT 8 funcWait
95 FUNCELAP FLOAT 8 funcEla c1 ela
96 FUNCSQLELAP FLOAT 8 funcD2Ela c2 ela
97 TRIGGERTCB FLOAT 8 triD2Cpu
98 TRIGGERELAP FLOAT 8 triD2Ela
99 PREENCTCB FLOAT 8 ???
100 PREENCSQLTCB FLOAT 8 ???
101 SPROCELAP FLOAT 8 stoProToEla
102 SPROCSQLELAP FLOAT 8 stoProD2Ela
103 ENCTRIGGERTCB FLOAT 8 triNesToCpu
104 ENCTRIGGERELAP FLOAT 8 triNesToEla
105 LOBWAITELAP FLOAT 8
106 SPNFCPUZIIP FLOAT 8 ???
107 SPNFCPU FLOAT 8 ???
108 SPNFELAP FLOAT 8 ???
109 UDFNFCPUZIIP FLOAT 8
110 UDFNFCPU FLOAT 8
111 UDFNFELAP FLOAT 8
112 SVPOINTREQ FLOAT 8
113 SVPOINTREL FLOAT 8
114 SVPOROLLBK FLOAT 8
115 WTELAWTK FLOAT 8 gblChiWait
116 WTELAWTM FLOAT 8 gblOtLWait
117 WTELAWTN FLOAT 8 gblPrPWait
118 WTELAWTO FLOAT 8 gblPgPWait
119 WTELAWTQ FLOAT 8 gblOtPWait
120 WTEVARNK FLOAT 8
121 WTEVARNM FLOAT 8
122 WTEVARNN FLOAT 8
123 WTEVARNO FLOAT 8
124 WTEVARNQ FLOAT 8
125 WTELAWFC FLOAT 8 ???
126 WTEVFCCT FLOAT 8
127 WTELIXLT FLOAT 8
128 WTEVIXLE FLOAT 8
129 SETCURPREC FLOAT 8
130 DCLGLOBALTT FLOAT 8
131 PARAGLOBALTT FLOAT 8
132 SELECTS FLOAT 8
133 INSERTS FLOAT 8
134 UPDATES FLOAT 8
135 DELETES FLOAT 8
136 DESCRIBES FLOAT 8
137 PREPARES FLOAT 8
138 OPENS FLOAT 8
139 FETCHES FLOAT 8
140 CLOSES FLOAT 8
141 PARAMAXDEG FLOAT 8
142 PARAREDGRP FLOAT 8
143 SQLCALLAB FLOAT 8
144 SQLCALLTO FLOAT 8
145 SQLCRGTT FLOAT 8
146 REOPTIMIZE FLOAT 8
147 DIRECTROWIX FLOAT 8
148 DIRECTROWTS FLOAT 8
149 FUNC FLOAT 8
150 FUNCAB FLOAT 8
151 FUNCTO FLOAT 8
152 FUNCRJ FLOAT 8
153 BPGETPAGE FLOAT 8
154 BPPGUPDAT FLOAT 8
155 BPSYNCRD FLOAT 8
156 BPPREFET FLOAT 8
157 BPSYNCWR FLOAT 8
158 BPLISTPREF FLOAT 8
159 BPDPF FLOAT 8
160 BPNGT FLOAT 8
161 BPSIO FLOAT 8
162 DEADLOCKS FLOAT 8
163 SUSPENDS FLOAT 8
164 TIMEOUTS FLOAT 8
165 LOCKESHR FLOAT 8
166 LOCKEXCL FLOAT 8
167 MAXPGLOCKS FLOAT 8
168 SUSPLATCH FLOAT 8
169 SUSPOTHER FLOAT 8
170 LOCKREQS FLOAT 8
171 CLAIMREQ FLOAT 8
172 CLAIMREQUN FLOAT 8
173 DRAINREQ FLOAT 8
174 DRAINREQUN FLOAT 8
175 GBPREADINVBD FLOAT 8
176 GBPREADINVBR FLOAT 8
177 GBPREADNOPGD FLOAT 8
178 GBPREADNOPGR FLOAT 8
179 GBPREADNOPGN FLOAT 8
180 GBPWRITCHG FLOAT 8
181 GBPWRITCLEAN FLOAT 8
182 GBPUNREGPG FLOAT 8
183 GBPEXPLICITXI FLOAT 8
184 GBPWRITCHK2 FLOAT 8
185 GBPASYNPRIM FLOAT 8
186 GBPASYNSEC FLOAT 8
187 GBPDEPGETPG FLOAT 8
188 GBPPLKSPMAP FLOAT 8
189 GBPPLKDATA FLOAT 8
190 GBPPLKIDX FLOAT 8
191 GBPPLKUNLK FLOAT 8
192 GBPPSUSSPMAP FLOAT 8
193 GBPPSUSDATA FLOAT 8
194 GBPPSUSIDX FLOAT 8
195 GBPWARMULTI FLOAT 8
196 GBPWAR FLOAT 8
197 GLPLOCKLK FLOAT 8
198 GLPLOCKCHG FLOAT 8
199 GLPLOCKUNLK FLOAT 8
200 GLXESSYNCLK FLOAT 8
201 GLXESSYNCCHG FLOAT 8
202 GLXESSYNCUNLK FLOAT 8
203 GLSUSPIRLM FLOAT 8
204 GLSUSPXES FLOAT 8
205 GLSUSPFALSE FLOAT 8
206 GLINCOMPAT FLOAT 8
207 GLNOTFYSENT FLOAT 8
208 GLFALSECONT FLOAT 8
209 RLFCPULIMITU FLOAT 8
210 RLFCPUUSEDU FLOAT 8
211 UNLOCKREQS FLOAT 8
212 QUERYREQS FLOAT 8
213 CHNGREQS FLOAT 8
214 IFIELAPSED FLOAT 8
215 IFITCBCPU FLOAT 8
216 IFIELAPDTC FLOAT 8
217 IFIELAPEXT FLOAT 8
218 PROGRAMS FLOAT 8
219 LOADTS TIMESTMP 10
$/prb_general/
$</prb_program/
*** PBDD.TACCT_PROGRAM
27 ELAPSEPKG FLOAT 8 pkgElap
28 CPUTCBPKG FLOAT 8 pkgCpu
46 CLASS7CPU_ZIIP FLOAT 8 pkgZIIP
f fosPrWait wait % 1. % 2. % 3.
c ELAPSYNCIO ELPLOCK ELPOTHREAD ELPOTHWRIT
c ELPUNITSW ELPARCQIS ELPDRAIN ELPCLAIM
c ELPARCREAD ELPPGLAT GBLMSGELAP GBLLOKELAP
c SPWAITELAP FUNCWAIT LOBWAITELAP WTELAWTK
c WTELAWTM WTELAWTN WTELAWTO WTELAWTQ
52 BPGETPAGE FLOAT 8 bpGetPg
53 BPPGUPDAT FLOAT 8 bpUpdPg
54 BPSYNCRD FLOAT 8 bpSynRe
75 SQLCALL FLOAT 8
26 SQLCOUNT FLOAT 8
66 SELECTS FLOAT 8
67 INSERTS FLOAT 8
68 UPDATES FLOAT 8
69 DELETES FLOAT 8
70 DESCRIBES FLOAT 8 describ
71 PREPARES FLOAT 8 prepare
72 OPENS FLOAT 8
73 FETCHES FLOAT 8
74 CLOSES FLOAT 8
+ - real wait
c ELAPSYNCIO ELPLOCK ELPOTHREAD ELPOTHWRIT
c ELPUNITSW ELPARCQIS ELPDRAIN ELPCLAIM
c ELPARCREAD ELPPGLAT GBLMSGELAP GBLLOKELAP
c SPWAITELAP FUNCWAIT LOBWAITELAP WTELAWTK
c WTELAWTM WTELAWTN WTELAWTO WTELAWTQ
*** all of PBDD.TACCT_PROGRAM
1 OCCURRENCES INTEGER 4
2 SYSTEMID CHAR 4
3 SUBSYSTEM CHAR 4
4 PLANNAME CHAR 8
5 AUTHID CHAR 8
6 CONNECTION CHAR 8
7 CORRID CHAR 12
8 ORIGPRIMID CHAR 8
9 CONNTYPE CHAR 8
10 DATETIME TIMESTMP 10
11 DATE DATE 4
12 LOCATION CHAR 16
13 GROUPNAME CHAR 8
14 ENDUSERID CHAR 16
15 ENDUSERTX CHAR 32
16 ENDUSERWN CHAR 18
17 CORRNAME CHAR 8
18 CLASS7CNT FLOAT 8
19 CLASS8CNT FLOAT 8
20 IFCIDSEQ# FLOAT 8
21 CPUSUCONV FLOAT 8
22 EXECLOCATION CHAR 16
23 COLLECTIONID CHAR 18
24 PROGRAMNAME CHAR 18
25 CONSISTOKEN CHAR 16
26 SQLCOUNT FLOAT 8
27 ELAPSEPKG FLOAT 8
28 CPUTCBPKG FLOAT 8
29 ELAPSYNCIO FLOAT 8 syncIOW
30 ELPLOCK FLOAT 8
31 ELPOTHREAD FLOAT 8 othReaW
32 ELPOTHWRIT FLOAT 8 othWriW
33 ELPUNITSW FLOAT 8 unitSwW
34 ELPARCQIS FLOAT 8 arcLQuW
35 ELPDRAIN FLOAT 8 drainW
36 ELPCLAIM FLOAT 8 claimW
37 ELPARCREAD FLOAT 8 arcLReW
38 ELPPGLAT FLOAT 8 pgLatW
39 GBLMSGELAP FLOAT 8 glMsgW
40 GBLLOKELAP FLOAT 8 glLockW
41 SPWAITELAP FLOAT 8 stPrW
42 SPROCCNT FLOAT 8
43 FUNCWAIT FLOAT 8
44 FUNCCNT FLOAT 8
45 LOBWAITELAP FLOAT 8 lobW
46 CLASS7CPU_ZIIP FLOAT 8
47 WTELAWTK FLOAT 8 glChiW
48 WTELAWTM FLOAT 8 glOthW
49 WTELAWTN FLOAT 8 glPrtW
50 WTELAWTO FLOAT 8 glPgPhW
51 WTELAWTQ FLOAT 8 glOtPhW
52 BPGETPAGE FLOAT 8
53 BPPGUPDAT FLOAT 8
54 BPSYNCRD FLOAT 8
55 RLFCPULIMITU FLOAT 8
56 RLFCPUUSEDU FLOAT 8
57 SUSPLATCH FLOAT 8
58 SUSPOTHER FLOAT 8
59 LOCKREQS FLOAT 8
60 UNLOCKREQS FLOAT 8
61 QUERYREQS FLOAT 8
62 CHNGREQS FLOAT 8
63 IRLMREQS FLOAT 8
64 CLAIMREQ FLOAT 8
65 DRAINREQ FLOAT 8
66 SELECTS FLOAT 8
67 INSERTS FLOAT 8
68 UPDATES FLOAT 8
69 DELETES FLOAT 8
70 DESCRIBES FLOAT 8
71 PREPARES FLOAT 8
72 OPENS FLOAT 8
73 FETCHES FLOAT 8
74 CLOSES FLOAT 8
75 SQLCALL FLOAT 8
76 LOADTS TIMESTMP 10
$/prb_program/
/* 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 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
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- 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
fmt = '%s%qn%s%qe%q^'fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mDigits = '0123456789'
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || m.mDigits
m.mAlfDot = m.mAlfNum || '.'
m.mBase64 = m.mAlfUC || m.mAlfLC || m.mDigits'+-'
m.mId = m.mAlfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.mPrint = m.mAlfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
verifId: procedure expose m.
parse arg src, extra, sx
if sx == '' then
sx = 1
if pos(substr(src, sx, 1), m.mDigits) > 0 then
return sx
else
return verify(src, m.mId || extra, 'n', sx)
endProcedure verifId
/* copy m 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 *****************************************************/
/* 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 ********************************************************/
}¢--- A540769.WK.REXX.O13(PRIME) cre=2009-05-04 mod=2010-04-22-09.26.51 A540769 ---
parse arg st
st = trunc(100000/9) + 5
say 'starting from st' st
cnt = 0
do n=st + 1 - st//2 by -2 while cnt < 20
do d=3 by 2 to n-2 while n // d \= 0
end
if d > n-2 then do
say n '1:'right(100000//N,5) '4:'right(400000//N, 5),
'8:'right(800000//N,5) '12:'right(1200000//N, 5)
cnt = cnt + 1
end
end
}¢--- A540769.WK.REXX.O13(PROC) cre= mod= --------------------------------------
/* rexx ***************************************************************
**********************************************************************/
call prTest
exit
err: parse arg ggMsg; call errA ggMsg; exit 12;
/* copy pr begin ****************************************************/
prTest: procedure
m.trace = 0
call prIni
do i=1 to 5
call prPut 'v'i, 'v'i'-from-1'
end
call prInvoke prNew(), 'call prTest1 2'
return
endProcedure prTest
prTest1: procedure expose m.
parse arg n
say n 'begin' prTestVV()
do i=n to 5
call prPut 'v'i, 'v'i'-from-'n
end
say n 'put ' prTestVV()
if n <= 5 then
call prInvoke prNew(), 'call prTest1' (n+1)
say n 'end ' prTestVV()
return
endProcedure prTest1
prTestVV: procedure expose m.
parse arg n
r = ''
do i=1 to 5
r = r 'v'i'='prGet('v'i)
end
return strip(r)
endProcedure prTestVV
prIni: procedure expose m.
parse arg force
if m.pr.ini == 1 & force ^== 1 then
return
call memIni force
m.pr.proc = -1
p0 = prNew()
call outBegin p0, '*'
m.pr.out.p0 = p0
m.pr.proc = p0
m.pr.proc0 = p0
m.pr.hist.0 = 1
m.pr.hist.1 = p0
m.pr.ini = 1
return
endProcedure prIni
/*----------------------------------------------------------------------
return a new child process of the active process
----------------------------------------------------------------------*/
prNew: procedure expose m.
this = memNew()
m.pr.parent.this = m.pr.proc
m.pr.out.this = ''
m.pr.out.0 = 0
m.pr.out.max = 999999
return this
endProcedure prNew
/*----------------------------------------------------------------------
push process p to the history stack and make it the active process
----------------------------------------------------------------------*/
prPush: procedure expose m.
parse arg p
top = m.pr.hist.0
if m.pr.hist.top ^== m.pr.proc then
call err 'prPush: hist top proc mismatch'
top = m.pr.hist.0 + 1
m.pr.hist.0 = top
m.pr.hist.top = p
m.pr.proc = p
return top
endProcedure prPush
/*----------------------------------------------------------------------
pop the active process from history stack
activate the previous process
if arg tx not empty, ensure it equals the old active process
----------------------------------------------------------------------*/
prPop: procedure expose m.
parse arg tx
top = m.pr.hist.0
if m.pr.hist.top ^== m.pr.proc then
call err 'prPop: hist top proc mismatch'
if tx ^== '' then
if top ^== tx then
call err 'prPop: hist top is' top '<> expected' tx
if top <= 1 then
call err 'prPop: empty history'
top = top - 1
m.pr.hist.0 = top
m.pr.proc = m.pr.hist.top
return
endProcedure prPop
/*----------------------------------------------------------------------
push process ggPR, interpret rexx ggRexx and pop the process
----------------------------------------------------------------------*/
prInvoke: procedure expose m.
parse arg ggPr, ggRexx
ggOldProcTopHistVariable = prPush(ggPr)
interpret ggRexx
call prPop ggOldProcTopHistVariable
return
endProcedure prInvoke
prOut: procedure expose m.
parse arg line
this = m.pr.proc
x = m.pr.out.this.0 + 1
m.pr.out.this.0 = x
m.pr.out.this.x = line
if x > m.pr.out.this.max then do
memWriteBlock m.pr.out.this, pr'.'out'.'this
m.pr.out.this.0 = 0
end
return
endProcedure prOut
/*----------------------------------------------------------------------
get the value of a $-variable, fail if undefined
----------------------------------------------------------------------*/
prGet: procedure expose m.
parse arg name, s
p = m.pr.proc
do while p >= 0
if symbol('m.pr.p.name') = 'VAR' then
return m.pr.p.name
p = m.pr.parent.p
end
if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure prGet
/*----------------------------------------------------------------------
put (store) the value of a $-variable
----------------------------------------------------------------------*/
prPut: procedure expose m.
parse arg name, value
p = m.pr.proc
m.pr.p.name = value
call trc 'assign('p')' name '= <'value'>'
return
endProcedure prPut
prWriteBegin: procedure expose m.
parse arg m, pTyp pOpt
m.pr.write.m.type = pTyp
m.pr.write.m.max = 0
m.pr.write.m.bNo = 0
m.pr.write.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.pr.write.m.max = 999999999
end
else if pTyp == 'd' then do
m.pr.write.m.dd = pOpt
m.pr.write.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.pr.write.m.type = 'd'
m.pr.write.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.pr.write.m.dd = 'wri'm
else
m.pr.write.m.dd = m
m.pr.write.m.max = 100
inf = 'dd' m.pr.write.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.pr.write.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.pr.write.m.0 = 1
m.pr.write.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.pr.write.m.info = pTyp'-'m.pr.write.m.type inf
return
endProcedure outBegin
prWriteLine: procedure expose m.
parse arg m, data
r = m.pr.write.m.0 + 1
m.pr.write.m.0 = r
m.pr.write.m.r = strip(data, 't')
if m.pr.write.m.max <= r then do
call outBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
return
endProcedure outLine
prWriteBlock: procedure expose m.
parse arg m, data
if m.pr.write.m.0 ^== 0 then do
call outBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
if data ^== '' then do
call outBlockOne m, data
return
endProcedure prWriteBlock
prWriteBlockOne: procedure expose m.
parse arg m, data
m.pr.write.m.bNo = m.pr.write.m.bNo + m.data.0
if m.pr.write.m.type == 'd' then do
call writeNext m.pr.write.m.dd, 'M.'data'.'
end
else if m.pr.write.m.type = 'i' then do
interpret m.pr.write.m.rexx
end
else if m.pr.write.m.type == 'b' then do
if data == 'PR.WRITE.'m then
call err 'recursive block write' m
q = m.pr.write.m.0
do r = 1 to m.data.0
q = q + 1
m.pr.write.m.q = m.data.r
end
m.pr.write.m.0 = q
end
else if m.pr.write.m.type == '*' then do
do r = 1 to m.data.0
say 'prWrite:' m.data.r
end
end
else
call err 'blockOne bad m.pr.write.'m'.type' m.pr.write.m.type
return
endProcedure outBlock
prWriteEnd: procedure expose m.
parse arg m
if m.pr.write.m.0 ^== 0 & m.pr.write.m.type ^== 'b' then do
call writeBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
if m.pr.write.m.type == 'd' then do
call writeDDEnd m.pr.write.m.dd
if left(m.pr.write.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
else if m.pr.write.m.type == 'i' then do
if m.pr.write.rexxClose ^== '' then
interpret m.pr.write.rexxClose
end
return
endProcedure prWriteEnd
outInfo: procedure expose m.
parse arg m
if m.pr.write.m.type = 'b' then
m.pr.write.m.bNo = m.pr.write.m.0
return m.pr.write.m.bNo 'records written to',
m 'type' m.pr.write.m.info
/* copy pr end ****************************************************/
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
memIni: procedure expose m.
parse arg force
if m.mem.ini == 1 & force ^== 1 then
return
m.mem.0 = 0
m.mem.ini = 1
return
endProcedure memIni
memNew: procedure expose m.
m.mem.0 = m.mem.0 + 1
return m.mem.0
endProcedure memNew
inAll: procedure expose m.
parse arg m, inTO, out
call inBegin m, inTO
if out == '' then do
call inBlock m, '*'
if inBlock(m) | m ^== m.in.m.block then
call err 'not eof after inBlock *'
end
else do
rx = 0
do while inBlock(m)
bl = m.in.m.block
do ix=1 to m.bl.0
rx = rx + 1
m.out.rx = m.bl.ix
end
end
m.out.0 = rx
end
call inEnd m
return
endSubroutine inAll
inBegin: procedure expose m.
parse arg m, pTyp pOpt
m.in.m.type = pTyp
m.in.m.rNo = 0
m.in.m.bNo = 0
m.in.m.0 = 0
m.in.m.eof = 0
m.in.m.block = in'.'m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = in'.'m'.'string
m.in.m.type = 'b'
end
else if pTyp == 'b' then do
m.in.m.block = pOpt
end
else if pTyp == 'd' then do
m.in.m.dd = pOpt
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.in.m.type = 'd'
m.in.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.in.m.dd = 'in'm
else
m.in.m.dd = m
inf = 'dd' m.in.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.in.m.dd') shr dsn('pOpt')'
end
else
call err 'inBegin bad type' pTyp
m.in.m.info = pTyp'-'m.in.m.type inf
return
endProcedure inBegin
inLine: procedure expose m.
parse arg m
r = m.in.m.rNo + 1
if r > m.in.m.0 then do
if ^ inBlock(m) then
return 0
r = 1
end
m.in.m.line = m.in.m.block'.'r
m.in.m.rNo = r
return 1
endProcedure inLine
inBlock: procedure expose m.
parse arg m, cnt
if m.in.m.type == 'd' then do
m.in.m.bNo = m.in.m.bNo + m.in.m.0
m.in.m.eof = ^ readNext(m.in.m.dd, 'm.in.'m'.', cnt)
return ^ m.in.m.eof
end
else if m.in.m.type == 'b' then do
if m.in.m.bNo > 0 then do
m.eof = 1
return 0
end
m.in.m.bNo = 1
b = m.in.m.block
m.in.m.0 = m.b.0
return 1
end
else
call err 'inBlock bad m.in.'m'.type' m.in.m.type
endProcedure inBlock
inLineInfo: procedure expose m.
parse arg m, lx
if lx = '' then
lx = m.in.m.rNo
cl = m.in.m.block'.'lx
xx = m.in.m.rNo
if m.in.m.type == 'd' then
xx = xx + m.in.m.bNo
return 'record' xx '(m.'cl 'type' strip(m.in.m.info)'):' m.cl
endProcedure inLineInfo
inEnd: procedure expose m.
parse arg m
if m.in.m.type == 'd' then do
call readDDEnd m.in.m.dd
if left(m.in.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
outBegin: procedure expose m.
parse arg m, pTyp pOpt
m.out.m.type = pTyp
m.out.m.max = 0
m.out.m.bNo = 0
m.out.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.out.m.max = 999999999
end
else if pTyp == 'd' then do
m.out.m.dd = pOpt
m.out.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.out.m.type = 'd'
m.out.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.out.m.dd = 'out'm
else
m.out.m.dd = m
m.out.m.max = 100
inf = 'dd' m.out.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.out.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.out.m.0 = 1
m.out.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.out.m.info = pTyp'-'m.out.m.type inf
return
endProcedure outBegin
outLine: procedure expose m.
parse arg m, data
if m.out.m.0 < m.out.m.max then do
r = m.out.m.0 + 1
m.out.m.0 = r
m.out.m.r = strip(data, 't')
end
else if m.out.m.type = '*' then do
m.out.m.bNo = m.out.m.bNo + 1
say 'out:' data
end
else if m.out.m.type = 's' then do
m.out.m.bNo = m.out.m.bNo + 1
m.out.m.1 = m.out.m.1 strip(data)
end
else do
call outBlock m
m.out.m.0 = 1
m.out.m.1 = data
end
return
endProcedure outLine
outBlock: procedure expose m.
parse arg m, pp
if pp == '' then
oo = out'.'m
else
oo = pp
if m.out.m.type = '*' then do
do r = 1 to m.oo.0
say 'out:' m.oo.r
end
end
else if m.out.m.type = 's' then do
do r = 1 to m.oo.0
m.out.m.1 = m.out.m.1 strip(m.oo.r)
end
end
else if m.out.m.type = 'b' then do
if pp ^== '' then do
q = m.out.m.0
do r = 1 to m.oo.0
q = q + 1
m.out.m.q = m.oo.r
end
m.out.m.0 = q
end
end
else if m.out.m.type == 'd' then do
m.out.m.bNo = m.out.m.bNo + m.oo.0
call writeNext m.out.m.dd, 'M.'oo'.'
if pp == '' then
m.out.m.0 = 0
end
return
return 1
endProcedure outBlock
outEnd: procedure expose m.
parse arg m
if m.out.m.type == 'd' then do
call outBlock m
call writeDDEnd m.out.m.dd
if left(m.out.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure outEnd
outInfo: procedure expose m.
parse arg m
if m.out.m.type = 'b' then
m.out.m.bNo = m.out.m.0
return m.out.m.bNo 'records written to' m 'type' m.out.m.info
endProcedure outInfo
/* copy mem end *****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDDBegin: procedure
return /* end readDDBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg ggTsoCmd
address tso ggTsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg ggTsoCmd
address tso ggTsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
adrIspRc:
parse arg ggIspCmd
address ispexec ggIspCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ggIspCmd
address ispexec ggIspCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ggIspCmd
return /* end adrIsp */
adrEdit:
parse arg ggEditCmd, ret
address isrEdit ggEditCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' ggEditCmd
return /* end adrEdit */
adrEditRc:
parse arg ggEditCmd
address isrEdit ggEditCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(PROTOTYP) cre=2012-08-24 mod=2012-08-24-10.57.29 A540769 ---
$#@
call sqlConnect dbaf
$;
$>.fEdit()
call sqlSel 'select name db from sysibm.sysDatabase' ,
"where name like 'DGDB%'" ,
"or name like 'DGO%'" ,
"or name like '%A1X%'"
$| $@¢
$=dx = 0
$@forWith db $@/db/
$=dx =- $dx+1
if $dx // 100 = 1 then $@=¢
//A540769W JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//*MAIN CLASS=LOG0
$!
$@=¢
//************ $dx db $DB
//STEP$dx EXEC PGM=PTLDRIVM,REGION=0M,
// PARM='EP=PTLHDDLB'
//STEPLIB DD DISP=SHR,DSN=DSN.CADB2.RZ1.P1.CDBALOAD
// DD DISP=SHR,DSN=DB2@.RZ1.P0.DSNLOAD
//PTILIB DD DISP=SHR,DSN=DSN.CADB2.RZ1.P1.CDBALOAD
// DD DISP=SHR,DSN=DB2@.RZ1.P0.DSNLOAD
//PTIPARM DD DISP=SHR,DSN=DSN.CADB2.RZ1.P1.CDBAPARM
//ACMBLKI DD DUMMY DSN=A540769.ACM.INPUT.D120823.T141828,
//HDDLOUT DD DISP=SHR,DSN=DSN.DBADM.PROTOTYP($DB)
//ERRORMSG DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//PARMFILE DD *
OBJTYPE DB
NAME $DB
SSID DBAF
SQLID S100447
LOCATION LOCAL
$!
$/db/
$!
$;
call sqlDisconnect dbaf
$#out 20120823 16:54:44
$#out 20120823 16:49:54
$#out 20120823 16:42:41
$#out 20120823 16:41:38
}¢--- A540769.WK.REXX.O13(PROTSTFO) cre=2012-08-24 mod=2012-08-24-12.17.53 A540769 ---
$#@ $*( -sta force auf alle Prototypen in RECP or RBDP pending
Achtung: dies ist eine kriminelle Aktion
nur durchführen falls ......
$*)
$= dbsy = DBAF
call reoRefSt $dbsy '-1'
call sqlConnect $dbsy
call sqlSel 'select * from S100447.tDbState' ,
"where ( db like 'DGDB%'" ,
"or db like 'DGO%'" ,
"or db like '%A1X%')" ,
"and( sta like '%RBDP%' or sta like '%RECP%')"
$|
$@forWith sta $@¢
db = strip($DB)
sp = strip($SP)
if m.dbsp.db.sp = 1 then do
$** say 'already' db'.'sp
end
else do
say '-sta db('db') sp('sp') access(force) ***' $STA
m.dbSp.db.sp = 1
$** Kommentar in naechster Zeile entfernen
$** nur wenn ganz sicher ||||||
$**??? call sqlDsn st, $dbsy, '-sta db('db') sp('sp') access(force)'
if 0 then do /* output anzeigen */
do sx=1 to m.st.0
say '.' m.st.sx
end
end
$*) end
$!
call sqlDISConnect
$#out 20120824 12:12:15
}¢--- A540769.WK.REXX.O13(PVSCOUNT) cre= mod= ----------------------------------
/* REXX ***************************************************************/
parse arg num
say num
call wrIni
ABC = 'ab'num
wx = wr2DS(wrNew(), 'disp=shr dsn=wk.text(cnt'num')')
call outPush wx
call lmdBegin ABC, 'PVR.*.*.W*.D2005'num'*'
yy = 0
do while lmdNEXT(ABC, l.)
yy = yy + l.0
do y=1 to l.0
call afpCount word(l.y, 1)
end
end
say yy 'files found'
call lmdEnd ABC
call outPop
call wrClose wx
exit
afpCount: procedure expose m.
parse arg dsn
/* afp constants */
afp = '5A'x
bpg = 'D3A8AF'x
epg = 'D3A9AF'x
nop = 'D3EEEE'x
dat = date('s',substr(dsnGetLev(dsn, +5), 4), 'j')
/* get file name */
call adrTso "alloc dd(afpDD) shr dsn('"dsn"')"
recs = 0
qW = ''
do while readDD(afpDD, r.)
recs = recs + r.0
do x=1 to r.0
if left(r.x, 1) ^== afp then do
if left(r.x, 4) == '@#H0' then do
id = substr(r.x, 6, 4)
q = wordPos(id, qW)
if q = 0 then do
qW = qW id
q = wordPos(id, qW)
q.q.hd = 0
q.q.tr = 0
q.q.pb = 0
q.q.pe = 0
end
q.q.hd = q.q.hd + 1
end
else if left(r.x, 4) == '@#T0' then do
q.q.tr = q.q.tr + 1
end
end
else do
if substr(r.x, 4, 3) == bpg then
q.q.pb = q.q.pb + 1
else if substr(r.x, 4, 3) == epg then
q.q.pe = q.q.pe + 1
end
end
end
call readDDend afpDD
call adrTso 'free dd(afpDD)'
ht = 0
pt = 0
do q=1 to words(qW)
call outLn left(word(qW, q),5) right(q.q.hd, 8) ,
right(q.q.pb,8) dat dsn
if q.q.hd ^= q.q.tr then
call err 'trailer' q.q.tr 'mismatch'
if q.q.pb ^= q.q.pe then
call err 'ePG' q.q.pe 'mismatch'
ht = ht + q.q.hd
pt = pt + q.q.pb
end
call outLn left('*', 5) right(ht, 8) right(pt, 8) dat dsn recs
return
endProcedure pvsCount
/* rexx ***************************************************************
test infrastructure plus tests für wr, scan (ohne adr)
***********************************************************************/
m.trace = 0
call wrIni
call vsTestAll
exit
call vsTestAll
exit
/* copy vsT begin ******************************************************
test vs: data, seq, expression, redirection, heredata
***********************************************************************/
/*--- all wr and vs tests --------------------------------------------*/
vsTestAll: procedure expose m.
call wrTestAll
call vsTest
call wrTestTotal
return
endProcedure vsTestAll
/*--- all vs tests ---------------------------------------------------*/
vsTest: procedure expose m.
call vsTestBase
call vsTestSeq
call vsTestData
call vsTestEins
return
endProcedure vsTest
/*--- initialize for a vsTest ----------------------------------------*/
vsTestIni:
call wrIni
pT = wrNew()
pR = wrNew(pT)
pC = wrNew()
return
endSubroutine vsTestIni
/*--- execute a vs Test, stem st contains source to compile ---------*/
vsTest1:
parse arg typ, st
call wrTestOut pT, 'vsTest1' typ '==>' m.st.0 'lines' m.st.1
code = vsCompile(pC, st, left(typ, 1))
say code
call outPush pT
call vsRun code
call wrClose pT
call outPop
return
endProcedure vsTest1
vsTestBase: procedure expose m.
call vsTestIni
call wrTest pT,
, "var eins Wert von Eins.",
, "$=eins=Wert von Eins",
, " line eins 1",
, " line eins 2",
, "$=zwei=defZwei /* default */",
, " line zwei",
, "$=zwei=defZwei",
, " line zwei",
, "var eins Wert von Eins, zwei defZwei, drei defDrei."
call outPush pT
call vsPut 'eins', 'Wert von Eins'
call outLn 'var eins' vsGet('eins')'.'
call vsDis 'eins', 'defEins', 'line eins 1' , 'line eins 2'
call vsDis 'zwei', 'defZwei', 'line zwei'
call vsDis 'zwei', 'defZwei', 'line zwei'
call vsDef 'drei', 'defDrei'
call outLn 'var eins' vsGet('eins')', zwei' vsGet('zwei'),
|| ', drei' vsGet('drei')'.'
call outPop
call wrClose pT
return
endProcedure vsTestBase
vsTestSeq: procedure expose m.
call vsTestIni
/* assignments with stripped trailing blanks */
call wrTest pT,
, "--- vsTest1 s seqAssS ==> 8 lines $=a1=value of variable",
|| " a1.",
, "a1=<<value of variable a1.>> ",
, "a2=<<value of variable a2.>> ",
, "a3=<<value of variable a3.>> ",
, "a4=<<value of variable a4.>> ",
, "a5=<<value of variable a.5>> ",
, "a6=<<value of variable a6.>> "
call vsTest1 's seqAssS', wrArgs(t1, 0,
, '$=a1=value of variable a1.', '$$a1=<<$a1>> ',
, '$=a2= value of variable a2. ', '$$a2=<<${a2}>> ',
, '$=a3=value of variable a3.$$a3=<<$a3>> ',
, '$=a4= value of variable a4. $$a4=<<${a4}>> ',
, '$=a5=value of variable $"a.5"$$a5=<<$a5>> ',
, '$=a6= value of variable $"a6." $$a6=<<${a6}>> ')
/* rexx assingment $= | */
/* seq: pipes separated by $; */
call wrTest pT,
, "--- vsTest1 s seqAssR ==> 10 lines $=w1=warEins$=w2=warZ",
|| "wo$|$'$w1='$w1 $""""""$w1""""=""${w2}",
, "$w1=warEins ""$w1""=warZwo",
, "> st w1=warEins",
, "stem=abc aus block",
, "in Block x vX",
, "in Block x vY"
call vsTest1 's seqAssR', wrArgs(t1, 0,
, '$=w1=warEins$=w2=warZwo$|$''$w1=''$w1 $"""$w1""="${w2}',
, '', '', ' $; ', '$;$;$; ',
, '$|$"> st w1=$w1"',' $>stem=st $;$;$<$stem=st$;',
, ' $:{x="vX" $| "in Block x" x',
, ' x="vY" $| "in Block x" x $:} $>stem=abc $;',
, ' $| "stem=abc aus block" $; $<stem=abc')
/* rExpr */
call wrTest pT,
, "--- vsTest1 s seqRExpr ==> 5 lines $| ""eins"" , ",
, "eins zwei drei",
, "vier",
, "6abc4d5 13"
call vsTest1 's seqRExpr', wrArgs(t1, 0,
, '$| "eins" , ', ' "zwei" , ', '"drei" ',
, 'call outLn "vier"',
, '$| 1+2+3$"a"$"b"$''c''4''d''5 $"7"+6')
return
endProcedure vsTestSeq
vsTestData: procedure expose m.
call vsTestIni
/* data: sExpr ¨ block with partial line semantics */
call wrTest pT,
, "--- vsTest1 d dataSExpr ==> 5 lines und wie 4*5=$(4*5$),",
, "und wie 4*5=20,",
, "v1=",
, "vEins ",
, " v2=vZwei und leerZeile",
, " ",
, "und SchlussvEinsvZwei."
call vsTest1 'd dataSExpr', wrArgs(t1, 0,
, 'und wie 4*5=$(4*5$),',
, 'v1=$:{ $=v1=vEins$:}$v1 ',
, ' $:{ $=v2=vZwei$:} ',
'v2=${v2} und leerZeile', ' ', 'und Schluss$v1$v2.')
/* pipe with input redirection */
call wrTest pT,
, "--- vsTest1 d dataInp ==> 9 lines $:{ m.a.1=""a.1 eins"";m",
|| ".a.2=""a.2 zwei"";m.a.0=2 $;",
, "out O",
, "a.1 eins",
, "a.2 zwei",
, "drei out O",
, "out P",
, "a.1 eins",
, "a.2 zwei",
, "sechs out P"
call vsTest1 'd dataInp', wrArgs(t1, 0,
, '$:{ m.a.1="a.1 eins";m.a.2="a.2 zwei";m.a.0=2 $;',
, '$>stem=O $<stem=A $; $>>stem=O $| "drei out O"$;',
, '$>stem=P $<stem=A $| "sechs out P"$;',
, '$<<eof1 ', 'out O', 'eof1 $<stem=O ',
, '$<<eof2 ', 'out P', 'eof2 $<stem=P $:}')
/* input redirection with $ ==> interpret as data */
call wrTest pT,
, "--- vsTest1 d dataInpS ==> 17 lines $:{ $=v1=varEins$=v2=v",
|| "arZwei",
, "hereData ohne $",
, "v1=$v1",
, "v2=${v2} Punkt1.",
, "hereData mit $",
, "v1=varEins",
, "v2=varZwei Punkt2.",
, "ohne Dolllar",
, "v1=$v1",
, "v2=${v2} Punkt3.",
, "mit Dolllar",
, "v1=varEins",
, "v2=varZwei Punkt3."
call vsTest1 'd dataInpS', wrArgs(t1, 0,
, '$:{ $=v1=varEins$=v2=varZwei',
, '$|$"hereData ohne $"$;',
, '$<<eof1 ', 'v1=$v1', 'v2=${v2} Punkt1.', 'eof1$;',
, '$|$"hereData mit $"$;',
, '$<<$eof2 ', 'v1=$v1', 'v2=${v2} Punkt2.', 'eof2$;' ,
, '$>stem=a$<<eof1 ', 'v1=$v1' , 'v2=${v2} Punkt3.' , 'eof1' ,
, '$;$| "ohne Dolllar"$; $<stem=a $; ',
, '$| "mit Dolllar"$; $<$stem=a$:}')
/* hereData may be nested */
call wrTest pT,
, "--- vsTest1 d dataHere ==> 14 lines $:{ $=v1=1$=v2=0$=v3=0",
|| "$;",
, "hereData1 begin v1=1 v2=0 v3=0",
, "hereData2 begin v1=1 v2=1 v3=0",
, "hereData3 only v1=1 v2=1 v3=1",
, "hereData3 only v1=1 v2=1 v3=2",
, "hereData3 only v1=1 v2=1 v3=3",
, "hereData2 end v1=1 v2=1 v3=3",
, "hereData2 begin v1=1 v2=2 v3=3",
, "hereData3 only v1=1 v2=2 v3=4",
, "hereData3 only v1=1 v2=2 v3=5",
, "hereData3 only v1=1 v2=2 v3=6",
, "hereData2 end v1=1 v2=2 v3=6",
, "hereData1 end v1=1 v2=2 v3=6"
call vsTest1 'd dataHere', wrArgs(t1, 0,
, '$:{ $=v1=1$=v2=0$=v3=0$;',
, '$<<$data1 ', 'hereData1 begin v1=$v1 v2=$v2 v3=$v3',
, '$:{do ii=1 to 2; $=v2=$($v2+1$)$;',
, '$<<$data2 ', 'hereData2 begin v1=$v1 v2=$v2 v3=$v3',
, ' $:{do jj=1 to 3; $=v3=$($v3 + 1 $) $; ',
, '$<<$data3 ',
, 'hereData3 only v1=$v1 v2=$v2 v3=$v3',
, 'data3 $; end $:} ',
, 'hereData2 end v1=$v1 v2=$v2 v3=$v3',
, 'data2 $; end $:} ',
, 'hereData1 end v1=$v1 v2=$v2 v3=$v3',
, 'data1 $:} ')
m.wrTest.pT.new.0 = 0 /* same test via stem */
call vsTest1 'd dataHere', wrArgs(t1, 0,
, '$:{ $=v1=1$=v2=0$=v3=0$;',
, '$<<data1 ', 'hereData1 begin v1=$v1 v2=$v2 v3=$v3',
, '$:{do ii=1 to 2; $=v2=$($v2+1$)$;',
, '$<<$data2 ', 'hereData2 begin v1=$v1 v2=$v2 v3=$v3',
, ' $:{do jj=1 to 3; $=v3=$($v3 + 1 $) $; ',
, '$<<$data3 ',
, 'hereData3 only v1=$v1 v2=$v2 v3=$v3',
, 'data3 $; end $:} ',
, 'hereData2 end v1=$v1 v2=$v2 v3=$v3',
, 'data2 $; end $:} ',
, 'hereData1 end v1=$v1 v2=$v2 v3=$v3',
, 'data1 $>stem=a$; $<$stem=a $:}')
return
endProcedure vsTestData
vsTestEins: procedure expose m.
call vsTestIni
call wrTest pT,
, "--- vsTest1 d eins11 ==> 3 lines $:{$=v1='eins' ",
, "v1 'eins' 12 12"
call vsTest1 'd eins11', wrArgs('cc',0, "$:{$=v1='eins' ",
, " $| 'v1' $v1 ,", " 3*4 $(3*4$) $:}")
call wrTest pT,
, "--- vsTest1 d eins12 ==> 2 lines erste Zeile $'$v1='$v1",
, " erste Zeile $v1='eins'",
, "und 2."
call vsTest1 'd eins12' ,
, wrArgs('cc',0, " erste Zeile $'$v1='$v1","und 2.")
call wrTest pT,
, "--- vsTest1 d eins13 ==> 4 lines und wie ,",
, "und wie ,",
, "und wie ""geht's"" dir$? 1+1=2| v1 war 'eins' ",
, "v1 vNeuEins v2 vZwei "
call vsTest1 'd eins13', wrArgs(t1, 0,
, 'und wie ,',
, 'und wie $"""geht''s""" dir$''$?'' 1+1=$(1+ ,', ' 1 $)| ',
'v1 war $v1 $:{$=v1=vNeuEins $=v2=vZwei$:} ' ,
, 'v1 $v1 v2 ${v2} ')
return
endProcedure vsTestEins
/* copy vsT end *****************************************************/
/* copy wrTest begin ***************************************************
test infrastructure plus tests for wr, wr io and scan
***********************************************************************/
/*--- all tests ------------------------------------------------------*/
wrTestAll: procedure
call wrTestWr
call wrTestWrFore
call wrTestIO
call wrTestScan
call wrTestTotal
return
endProcedure wrTestAll
/*--- test wr writerDescriptor nur mit stems -------------------------*/
wrTestWr: procedure expose m.
call wrIni
pT = wrNew()
call wrTest pT,
, "--- wrTestWr ==> wrIni",
, "--- writeLn eins",
, "text eins", "text eins.2", "text eins.3",
, "--- write a",
, "m.a.1: elf",
, "m.a.2: zwoelf",
, "--- writeLn 20",
, "text 20",
, "--- closing buffer"
call wrTestOut pT, 'wrTestWr ==> wrIni'
call wrTestOut pT, 'writeLn eins'
call writeLn pT, 'text eins', 'text eins.2', 'text eins.3'
m.a.1 = 'm.a.1: elf'
m.a.2 = 'm.a.2: zwoelf'
m.a.0 = 2
call wrTestOut pT, 'write a'
call write pT, a
call wrTestOut pT, 'writeLn 20'
call writeLn pT, 'text 20'
call wrTestOut pT, 'closing buffer'
call wrClose pT
call wrTest pT,
, "--- stem A ==> test",
, "a.1 eins ",
, "a.2 zwei ",
, "--- stem A ==> B ==> test",
, "a.1 eins ",
, "a.2 zwei ",
, "--- stem A,A==> B strip ==> test",
, "a.1 eins",
, "a.2 zwei",
, "a.1 eins",
, "a.2 zwei"
pX = wrNew()
m.a.1 = 'a.1 eins '
m.a.2 = 'a.2 zwei '
m.a.0 = 2
call wrTestOut pt, 'stem A ==> test'
call wrFromDS pT, 'stem=A'
call wrDSFromDS pX, 'stem=B', 'stem=A'
call wrTestOut pt, 'stem A ==> B ==> test'
call wrFromDS pT, 'stem=B'
call wr2DS pX, 'stem=B strip=1'
call wrFromDS pX, 'stem=A'
call wrFromDS pX, 'stem=A'
call wrClose pX
call wrTestOut pt, 'stem A,A==> B strip ==> test'
call wrFromDS pT, 'stem=B'
call wrClose pT
return
endProcedure wrTestWr
/*--- foreground test, schreibt nur auf Bildschirm ohne Vergleich ----*/
wrTestWrFore: procedure expose m.
call wrIni
say '--- wrTestWr Foreground wr2DS dsn=*'
t = wrNew()
call wr2DS t, 'dsn=*'
call writeLn t, 'first writeln to dsn=*'
say '--- write ABC to dsn=*'
call write t, wrArgs('ABC', 0, 'ABC.1 eins', 'ABC.2','ABC.3 .')
call writeLn t, 'after write a', 'last writeln to dsn=*'
call wrClose t
say '--- wrTestWr Foreground end'
return
endProcedure wrTestWrFore
/*--- test io Funktionen auf Datasets --------------------------------*/
wrTestIO: procedure expose m.
call wrIni
pO = wrNew()
pT = wrNew()
dsnPr = 'test.out'
tst = date('s') time()
do i=0 by 1
if i>5 then
call err 'no nonExisting dataset found in' dsnPr'0..'dsn
dsn = dsnPr||i
if sysDsn(dsn) == 'DATASET NOT FOUND' then
leave
end
call wrTest pT,
, "--- allocating "dsn,
, "--- writing to "dsn,
, "--- appending to "dsn,
, "--- reading "dsn,
, "zeile eins ln "tst" ",
, "zeile zwei a.1 "tst" ",
, "zeile zwei a.2 "tst" ",
, "zeile vier ln "tst" ",
, "zeile funf app "tst" ",
, "zeile sech a.1 "tst" ",
, "zeile sieb a.2 "tst" ",
, "zeile acht app "tst" ",
, "--- sysdsn("dsn") = DATASET NOT FOUND"
call wrTestOut pT, 'allocating' dsn
call wr2DS pO, 'disp=new,catalog lrecl=35 dsn='dsn
call wrTestOut pT, 'writing to' dsn
call writeLn pO, 'zeile eins ln ' tst
call write pO, wrArgs(a, 0, 'zeile zwei a.1' tst,
, 'zeile zwei a.2' tst)
call writeLn pO, 'zeile vier ln' tst
call wrClose pO
call wrTestOut pT, 'appending to' dsn
call wr2DS pO, 'dsn='dsn 'strip=1', 'a'
call writeLn pO, 'zeile funf app' tst ' '
call write pO, wrArgs(a, 0, 'zeile sech a.1' tst ' ',
, 'zeile sieb a.2' tst)
call writeLn pO, 'zeile acht app' tst ' '
call wrClose pO
call wrTestOut pT, 'reading' dsn
call wrFromDs pT, 'dsn='dsn 'disp=old,delete'
call wrTestOut pT, 'sysdsn('dsn') =' sysdsn(dsn)
call wrClose pT
return
endProcedure wrTestIO
/*--- test scan ------------------------------------------------------*/
wrTestScan: procedure
call wrIni
t = wrNew()
call wrTest t,
, "--- scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s",
|| "' ",
, "scan name tok a034 key M.S.KEY val M.S.VAL",
, "scan char tok , key M.S.KEY val ",
, "scan name tok Und key M.S.KEY val ",
, "scan space 1 tok key M.S.KEY val ",
, "scan name tok hr123sdfER key M.S.KEY val ",
, "scan string quo tok ""st1"" key M.S.KEY val st1",
, "scan space 1 tok key M.S.KEY val ",
, "scan string apo tok 'str2''mit''apo''s' key M.S.KEY val st",
|| "r2'mit'apo's",
, "scan space 4 tok key M.S.KEY val "
call wrSc1 ,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call wrClose t
call wrTest t,
, "--- scan src litEinsefr 23 sdfER'str1'litZwei ""str2""""mi",
|| "t quo""s ",
, "scan literal tok litEins key M.S.KEY val ",
, "scan name tok efr key M.S.KEY val ",
, "scan space 1 tok key M.S.KEY val ",
, "scan number tok 23 key M.S.KEY val ",
, "scan space 1 tok key M.S.KEY val ",
, "scan name tok sdfER key M.S.KEY val ",
, "scan string apo tok 'str1' key M.S.KEY val str1",
, "scan literal tok litZwei key M.S.KEY val str1",
, "scan space 1 tok key M.S.KEY val ",
, "scan string quo tok ""str2""""mit quo"" key M.S.KEY val st",
|| "r2""mit quo",
, "scan name tok s key M.S.KEY val str2""mit quo",
, "scan space 1 tok key M.S.KEY val "
call wrSc1 ,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call wrClose t
call wrTest t,
, "--- scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan word tok aha;+-=f key aha val aha;+-=f",
, "scan keyValue tok cdEf key ab val cdEf",
, "scan keyValue tok 'strIng' key eF val strIng",
, "scan no word tok key eF val "
call wrSc1 w 0 0," aha;+-=f ab=cdEf eF='strIng' "
call wrClose t
call wrTest t,
, "--- scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan word tok aha;+-=f key AHA val AHA;+-=F",
, "scan keyValue tok cdEf key AB val cdEf",
, "scan keyValue tok 'strIng' key EF val strIng",
, "scan no word tok key EF val "
call wrSc1 w 1 0," aha;+-=f ab=cdEf eF='strIng' "
call wrClose t
call wrTest t,
, "--- scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan word tok aha;+-=f key aha val aha;+-=f",
, "scan keyValue tok cdEf key ab val CDEF",
, "scan keyValue tok 'strIng' key eF val strIng",
, "scan no word tok key eF val "
call wrSc1 w 0 1," aha;+-=f ab=cdEf eF='strIng' "
call wrClose t
call wrTest t,
, "--- scan 3 Zeilen mit nextLine",
, "name erste",
, "space",
, "name Zeile",
, "space",
, "nextLine",
, "nextLine",
, "space",
, "name dritte",
, "space",
, "name Zeile",
, "space",
, "name schluss",
, "space"
call wrArgs a, 0, 'erste Zeile ',,' dritte Zeile schluss '
call scanStem s, a
call wrTestOut t, 'scan 3 Zeilen mit nextLine'
do forever
if scanName(s) then call writeLn t, 'name' m.s.tok
else if scanVerify(s, ' ') then call writeLn t, 'space'
else if scanNL(s) then call writeLn t, 'nextLine'
else leave
end
call wrClose t
call wrTest t,
, "--- scan 3 Zeilen mit spaceLn",
, "name erste",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name dritte",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name schluss",
, "spaceLn"
call scanStem s, a
call wrTestOut t, 'scan 3 Zeilen mit spaceLn'
do forever
if scanName(s) then call writeLn t, 'name' m.s.tok
else if scanSpaceLn(s) then call writeLn t, 'spaceLn'
else leave
end
call wrClose t
return
endProcedure wrTestScan
/*--- one single test scan with lines to scan in stem ln -------------*/
wrSc1:
parse arg fun o1 o2, ln
call wrTestOut t, 'scan src' ln
call scanBegin s, ln
do while ^scanAtEnd(s)
if fun = w then do
if scanKeyValue(s, o1, o2) then o = 'keyValue '
else if scanword(s, o1) then o = 'word '
else o = 'no word '
end
else if scanLit(s, 'litEins') then o = 'literal '
else if scanLit(s, 'litZwei') then o = 'literal '
else if scanName(s) then o = 'name '
else if scanString(s) then o = 'string apo'
else if scanString(s, '"') then o = 'string quo'
else if scanNum(s) then o = 'number '
else if scanVerify(s, ' ') then o = 'space' length(m.s.tok)
else if scanChar(s,1) then o = 'char '
else call scanErr s 'not scanned'
call writeLn t, 'scan' o 'tok' m.s.tok 'key' m.s.key ,
'val' m.s.val
end
return
endProcedure wrSc1
/***********************************************************************
test writer infrastructure
***********************************************************************/
/*--- make writerDescriptor m a testWriter
--- and use remaining lines as compare values -----------------*/
wrTest: procedure expose m.
parse arg m
call wriClo m, 'call wrTestWrite' m ', stem', 'call wrTestClose' m
ox = 0
do ax=2 to arg()
ox = ox + 1
m.wrTest.m.ox = arg(ax)
end
m.wrTest.m.0 = ox
m.wrTest.m.new.0 = 0
m.wrTest.m.err = 0
if symbol("m.wrTest.err") ^= 'VAR' then
m.wrTest.err = 0
return
endProcedure wrTest
/*--- write to test: say lines and compare them ----------------------*/
wrTestWrite: procedure expose m.
parse arg m, stem
nx = m.wrTest.m.new.0
do ix=1 to m.stem.0
nx = nx + 1
m.wrTest.m.new.nx = m.stem.ix
say 'testOut' m.stem.ix
if nx > m.wrTest.m.0 then do
if nx = m.wrTest.m.0 + 1 then
call wrTestErr m, 'more new Lines' nx
end
else if m.wrTest.m.nx ^== m.stem.ix then do
say 'old ^^^' m.wrTest.m.nx
call wrTestErr m, 'line' nx 'difference'
end
end
m.wrTest.m.new.0 = nx
return
endProcedure wrTestWrite
/*--- close test: check differences and say compare strings ----------*/
wrTestClose: procedure expose m.
parse arg m, stem
if m.wrTest.m.new.0 ^= m.wrTest.m.0 then do
call wrTestErr m, 'old' m.wrTest.m.0 'lines ^= new' ,
m.wrTest.m.new.0
do nx = m.wrTest.m.new.0 + 1 to ,
min(m.wrTest.m.new.0+10, m.wrTest.m.0)
say 'old - ' m.wrTest.m.nx
end
end
say '***' m.wrTest.m.err 'errors'
if m.wrTest.m.err > 0 then do
say 'new lines:' m.wrTest.m.new.0
len = 60
do nx=1 to m.wrTest.m.new.0
str = quote(m.wrTest.m.new.nx, '"')
pr = ' , '
do while length(str) > len
l=len
if substr(str, l-1, 1) = '"' then
if posCount('"', left(str, l-1)) // 2 = 0 then
l = l-1
say pr left(str, l-1)'",'
str = '"'substr(str, l)
pr = ' ||'
end
say pr str || left(',', nx < m.wrTest.m.new.0)
end
end
return
endProcedure wrTestClose
/*--- write a single test message ------------------------------------*/
wrTestOut: procedure expose m.
parse arg m, msg
call writeLn m, '---' msg
return
endProcedure wrTestOut
/*--- say total errors and fail if not zero --------------------------*/
wrTestTotal: procedure expose m.
if m.wrTest.err = 0 then
say m.wrTest.err 'errors total'
else
call err m.wrTest.err 'errors total'
return
endProcedure wrTestTotal
/*--- test err: message, count it and continue -----------------------*/
wrTestErr: procedure expose m.
parse arg m, msg
say '*** error' msg
m.wrTest.m.err = m.wrTest.m.err + 1
m.wrTest.err = m.wrTest.err + 1
return
endProcedure wrTestErr
/* copy wrTest end **************************************************/
/* rexx ***************************************************************
test infrastructure plus tests für wr, scan (ohne adr)
***********************************************************************/
parse arg args
call wrIni
call outLn '--- begin VS with' args
call vsKeyValue args, 1, 1
call outPush wr2DS(wrNew(), 'dd=vsOut')
call vsRun vsCompile(wrNew(), 'dd=vsIn')
call outPop
call outLn '--- end VS with' args
exit 0
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
/* copy vs begin ****************************************************/
/*--- get the value of a $-variable, fail if undefined ---------------*/
vsGet: procedure expose m.
parse arg name, s
if symbol('m.var.name') == 'VAR' then
return m.var.name
else
call err 'var' name 'not defined'
endProcedure vsGet
/*--- put (store) the value of a $-variable --------------------------*/
vsPut: procedure expose m.
parse arg name, value
m.var.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure vsPut
/*--- set variable name to default def if undefined ------------------*/
vsDef: procedure expose m.
parse arg name, def
if symbol('m.var.name') == 'VAR' then
return 0
m.var.name = def
return 1
endProcedure vsDef
/*--- set variable name to defau def if undefined
display value and arguments 3.. ------------------------------*/
vsDis: procedure expose m.
parse arg name, def
msg = ''
if def ^== '++' then
if vsDef(name, def) then
msg = ' /* default */'
call outLn '$='name'='vsGet(name)msg
do i=3 to arg()
call outLn ' ' arg(i)
end
return
endProcedure vsDis
/*--- set variables from string with key=value pairs -----------------*/
vsKeyValue: procedure expose m.
parse arg src, uk, uv
sc = 'VS.KEYVALUE'
call scanBegin sc, src
do while scanKeyValue(sc, uk==1, uv==1)
call vsPut m.sc.key, m.sc.val
end
if ^ scanAtEOL(sc) then
call scanErr sc, 'hier sollte key=value stehen'
return
endProcedure vsKeyValue
/*--- run the code created by vsCompile ------------------------------*/
parse arg rexx
if m.wr.trace then
say 'interpreting' rexx
interpret rexx
if m.wr.trace then
say 'interpreted'
return
endProcedure vsRun
/*--- work in writerDescriptor m to compile the vs-Source in aStem
as typ d=data or s=sequence and return rexx code
aStem is either a stem or a dss ---------------------------*/
vsCompile: procedure expose m.
parse arg m, aStem, typ
st = aStem
if pos('=', aStem) > 0 then do
st = 'VS.COMPILE.'m
call wrDSFromDS m, 'stem='st, aStem
end
if m.wr.trace == 1 then
call wrFromDS m.wr.sysout, 'stem='st
call scanStem m, st
m.rs.m.rExprCont = m.scan.alnum || """'@#$.?"
if typ == 's' then
code = vscSeq(m, st)
else
code = vscData(m, st)
if scanAtEnd(m) then
return code
else if typ == 's' then
call scanErr m, 'sequence (statement or "$;") expected'
else
call scanErr m, 'data (sExpression or block) expected'
endProcedure vsCompile
/*--- data = (sExpr ¨ block ¨ nl)* with partial line semantics -------*/
vscData: procedure expose m.
parse arg m, stem
code = ''
do forever
bx = m.scan.m.pos
ex = vscSExpr(m,,0)
eol = scanAtEol(m)
if ex ^== '' then do
if (bx = 1 & eol) then
code = code'; call outLn' ex /* complete line */
else if substr(m.scan.m.src, bx, m.scan.m.pos-1) ^= '' then
code = code'; call outLn' ex /* not space */
end
else if eol then do
if ^ scanNL(m) then
return vscStrip(code)
end
else do
bl = vscBlock(m)
if bl == '' then
return vscStrip(code)
code = code';' bl
end
end
endProcedure vscData
/*--- strip generated code of leading semicolons ---------------------*/
vscStrip: procedure
parse arg orig
vx = verify(orig, '; ')
if vx > 0 then
return substr(orig, vx)
else /* Achtung '' und ' ' nicht vermischen | */
return left(' ', length(orig) > 0)
endProcedure vscStrip
/*--- run the code created by vsCompile ------------------------------*/
vsRun: procedure expose m.
parse arg rexx
if m.wr.trace then
say 'interpreting' rexx
interpret rexx
if m.wr.trace then
say 'interpreted'
return
endProcedure vsRun
/*--- compile a block = '$:{' seq '$:}' ------------------------------*/
vscBlock: procedure expose m.
parse arg m, seqOnly
if ^ scanLit(m, '$:{') then
return ''
code = vscSeq(m)
if ^ scanLit(m, '$:}') then
call scanErr m, 'closing $:} missing'
return code' ' /* donot return '', we found a block | */
endProcedure vscBlock
/*--- compile a Sequence = '(stmt ¨ '$;')* ---------------------------*/
vscSeq: procedure expose m.
parse arg m
code = ''
call scanSpaceLn m
do forever
if scanLit(m, '$;') then do
call scanSpaceLn m
end
else do
one = vscStmt(m)
if one == '' then
return vscStrip(code)
code = code';' one
end
end
endProcedure vscSeq
/*--- compile a statement: (rExpr¨ouput¨input¨ass¨block)+ -----------*/
vscStmt: procedure expose m.
parse arg m
code = ''
out = ''
do forever
if scanLit(m, '$>') then do /* outputredirection */
if out ^== '' then
call scanErr m, 'duplicate output redirection'
app = scanLit(m, '>')
out = vscSExpr(m,,1)
if out == '' then
call scanErr m,
, "output redirection without sExpression"
wx = wrNew()
out = 'call wr2DS' wx',' out
if app then
out = out', "a"'
out = out '; call outPush' wx
end
else do /* other statements */
one = vscInput(m) /* input redirection */
if one = '' then one = vscAss(m) /* assignment */
if one = '' then one = vscBlock(m) /* block */
if one = '' then one = vscRExpr(m) /* rexx statements */
if one = '' then
leave
code = code';' one
end
call scanSpaceLn m
end
if out == '' then
return vscStrip(code)
else
return out';' vscStrip(code)'; call outPop'
endProcedure vscStmt
/*--- input: $$ sExprS ¨ $| rExpr ¨ $<... ¨ $<<... ----------------*/
vscInput: procedure expose m.
parse arg m
if scanLit(m, '$|') then /* input rexx expression */
return 'call outLn' vscRExpr(m)
else if scanLit(m, '$$') then /* input shell expression */
return 'call outLn' vscSExpr(m,,0)
else if ^ scanLit(m, '$<') then
return ''
hereData = scanLit(m, '<')
dol = scanLit(m, "$")
if ^ hereData then do /* $< DSS */
dss = vscSExpr(m,,1)
if dss == '' then
call scanErr m, "input redirection without sExpression"
if dol then /* compile dss */
return 'call vsRun vsCompile('wrNew()',' dss')'
else /* output dss */
return 'call outDS' dss
end
/* $<< hereData */
if ^ scanVerify(m, ' ', 'm') then
call scanErr m, '$<< delimiter expected'
delim = m.m.tok
call scanVerify m, ' '
if ^scanAtEol(m) then
call scanErr m, 'rest of line must be empty'
ox = 0
dx = wrNew()
stem = 'WR.DATA.'dx /* get data to stem */
do forever
if ^scanNextLine(m) then
call scanErr m, 'no matching delimiter for $<<'delim
if scanLit(m, delim) then
leave
ox = ox + 1
m.stem.ox = m.scan.m.src
end
m.stem.0 = ox
if dol then
return 'do;' vsCompile(dx, stem) '; end' /* compile stem */
else
return 'call outDS' quote('stem='stem) /* output stem */
endProcedure vscHereData
/*--- assignent statemt $=...=... ------------------------------------*/
vscAss: procedure expose m.
parse arg m
if ^ scanLit(m, '$=') then
return ''
nam = vscSExpr(m, '=|', 1)
if scanLit(m, '|') then
return 'call vsPut' nam',' vscRExpr(m)
else if scanLit(m, '=') then
return 'call vsPut' nam',' vscSExpr(m,,1)
else
call scanErr m, '= or | missing after $= in assignment'
endProcedure vscAss
/*--- shell expression (text ¨ sub)+ -------------------------------*/
vscSExpr: procedure expose m.
parse arg m, stp, strip
code = ''
if strip == 1 then
call scanVerify m, ' '
do forever
call scanVerify m, "$"stp, 'm'
str = m.m.tok
sub = vscSub(m)
if sub == '' then
leave
if str == '' then
code = code '||' sub
else
code = code '||' quote(str) '||' sub
end
if strip == 1 then do
str = strip(str, 't')
call scanVerify m, ' ' /* if stp contains a space */
end
if str ^== '' then
code = code '||' quote(str)
if code == '' then
return ''
else
return substr(code, 5) /* drop leading ' || ' */
endProcedure vscSExpr
/*--- rexx expression (text ¨ sub ¨ ',' ' '* nl rExpr)* -----------*/
vscRExpr: procedure expose m.
parse arg m, stp
code = ''
do forever
if scanAtEOL(m) then do
str = strip(code, 't')
if right(str, 1) ^== ',' then
return str
code = strip(left(str, length(str) - 1))' '
if ^ scanNL(m) then
return code
end
else do
if scanVerify(m, "$"stp, 'm') then do
nn = m.m.tok
end
else do
nn = vscSub(m)
if nn == '' then
return code
end
/* now the tricky stuff: */
if nn = '' then /* is a space or || needed */
code = code' ' /* between old and new code? */
else if right(nn, 1) == ' ' then
nn = strip(nn, 't')' '
if pos(left(nn, 1), m.rs.m.rExprCont) = 0 then
code = code || nn
else if pos(right(code, 1), m.rs.m.rExprCont) = 0 then
code = code || nn
else
code = code '||' nn
end
end
endProcedure vscRExpr
/*--- compile a substitution: '$'string ¨ '$('rExpr')'
¨ '$'name ¨ '${'sExpr'}' ---------------*/
vscSub: procedure expose m.
parse arg m
bx = m.scan.m.pos
if ^ scanLit(m, "$") then
return ''
else if scanLit(m, '{') then do
sub = vscSExpr(m, '}', 1)
if sub == '' then
call scanErr m, 'sExpr exptected'
if ^ scanLit(m, '}') then
call scanErr m, 'closing brace (}) missing'
return 'vsGet(' || sub || ')'
end
else if scanLit(m, '(') then do
sub = vscRExpr(m)
if ^scanLit(m, '$)') then
call scanErr m, 'closing $) missing'
return '(' || sub || ')'
end
else if scanString(m, "'") then do
return m.m.tok
end
else if scanString(m, '"') then do
return m.m.tok
end
else do
if ^ scanName(m) then do
m.scan.m.pos = bx
return ''
end
return 'vsGet(' || quote(m.m.tok) || ')'
end
endProcedure vscSub
/* copy vs end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanBegin(m,ln): set scan Source to ln
scanAtEnd(m) : returns whether we reached end of line already
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (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.m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line aSrc ------------------------------*/
scanBegin: procedure expose m.
parse arg m, m.scan.m.src, m.scan.m.reader
m.scan.m.pos = 1
m.scan.m.tok = ''
m.scan.m.val = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
end
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src) & m.scan.m.reader == ''
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- scan a word (space delimited or string)
put value into *.val, upercased if uc=1 and not string ---------*/
scanWord: procedure expose m.
parse arg m, uc
call scanVerify m, ' '
if scanString(m, "'") then return 1
else if scanString(m, """") then return 1
else
res = scanVerify(m, ' ', 'm')
m.m.val = m.m.tok
if uc ^== 0 then
upper m.m.val
return res
endProcedure scanWord
/*--- scan a key = word phrase
put key into *.key (uppercase if uk) and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, uk, uv
bx = m.scan.m.pos
call scanVerify m, ' '
if scanName(m) then do
m.m.key = m.m.tok
if uk ^== 0 then
upper m.m.key
call scanVerify m, ' '
if scanLit(m, '=') then do
call scanWord m, uv
return 1
end
end
m.scan.m.pos = bx
return 0
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.scan.m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
if symbol('m.scan.m.lineinfo') == 'VAR' then
interpret 'say " lineinfo:" ('m.scan.m.lineinfo')'
call err 'scanErr' txt
endProcedure scanErr
/*--- begin to scan all lines of stem st -----------------------------*/
scanStem: procedure expose m.
parse arg m, st
m.scan.m.liSt = st
m.scan.m.liX = 0
m.scan.m.lineInfo = "'stem m.' ||" quote(st) "|| '.'m.scan.m.liX"
return scanNextLine(m)
endProcedure scanStem
/*--- if at NL start next Line if possible otherwise return false ----*/
scanNL: procedure expose m.
parse arg m
if m.scan.m.reader == '' | m.scan.m.pos <= length(m.scan.m.src) then
return 0
return scanNextLine(m)
endProcedure scanNL
/*--- start next line, return false if no more lines -----------------*/
scanNextLine: procedure expose m.
parse arg m
st = m.scan.m.liSt
lx = m.scan.m.liX + 1
if lx > m.st.0 then do /* avoid scan errors | */
call scanBegin m, '<end of file, m.'st'.0 =' m.st.0'>'
m.scan.m.pos = 1+length(m.scan.m.src) /* ensure we are at eof */
return 0
end
m.scan.m.liX = lx
call scanBegin m, m.st.lx, 1
return 1
endProcedure scanNL
/*--- skip over space and NL (NewLines) ------------------------------*/
scanSpaceLn: procedure expose m.
parse arg m
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then return res
res = 1
end
endProcedure scanSpace Ln
/* copy scan end ****************************************************/
/* copy wr begin *****************************************************
out interface
define a current output destination (a writerDescriptor)
manage them in a stack
convenience function to write to current output
***********************************************************************/
/*--- write stem stem to current output ------------------------------*/
out: procedure expose m.
parse arg stem
call write m.wr.out, stem
return
endProcedure
/*--- write up to 3 strings to current output ------------------------*/
outLn: procedure expose m.
parse arg m.wr.outLn.1, m.wr.outLn.2, m.wr.outLn.3
m.wr.outLn.0 = arg()
call write m.wr.out, 'WR.OUTLN'
return
endProcedure
/*--- write to current output from datasetSpec dss -------------------*/
outDS: procedure expose m.
parse arg dss
call wrFromDS m.wr.out, dss
return
endProcedure outDS
/*--- redirect current output ----------------------------------------*/
outPush: procedure expose m.
parse arg o
x = m.wr.out.0 + 1
m.wr.out.0 = x
m.wr.out.x = m.wr.out
if o == '*' then
m.wr.out = m.wr.sysout
else
m.wr.out = o
return
endProcedure outPush
/*--- redirect current output to previous ----------------------------*/
outPop: procedure expose m.
parse arg o
x = m.wr.out.0
m.wr.out.0 = x - 1
m.wr.out = m.wr.out.x
return
endProcedure outPop
/**********************************************************************
writer interface
a writerDescriptor wx is allocated with wrNew
we can define the write and wrClose functionality arbitrarily
***********************************************************************/
/*--- create a new writeDescriptore ----------------------------------*/
wrNew: procedure expose m.
parse arg oo, atts
nn = m.wr.new + 1
m.wr.new = nn
return nn
endProcedure wrNew
/*--- for writeDescriptor m define write and close -------------------*/
wriClo: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, wr2
if wr2 ^== '' then
m.wr.write.m = "do ggLX=1 to m.stem.0; line = stem'.'ggLx;" ,
m.wr.write.m '; end;' wr2
return m
endProcedure wriClo
/*--- write stem m.stem. to writeDescriptor m ------------------------*/
write: procedure expose m.
parse arg m, stem
interpret m.wr.write.m
return
endProcedure write
/*--- write up to 3 strings to writeDescriptor m ---------------------*/
writeLn: procedure expose m.
parse arg m, m.wr.writeln.m.1, m.wr.writeln.m.2, m.wr.writeln.m.3
m.wr.writeln.m.0 = arg()-1
call write m, 'WR.WRITELN.'m
return
endProcedure writeLn
/*--- close writeDescriptor m ----------------------------------------*/
wrClose: procedure expose m.
parse arg m
interpret m.wr.close.m
return
endProcedure wrClose
/*--- initialisation writer and output -------------------------------*/
wrIni: procedure expose m.
parse arg tr
m.wr.trace = tr = 1
m.wr.new = 0
so = wrNew()
sy = 'say m.stem.ix'
if m.wr.trace then
sy = 'say "sysout:" quote(m.stem.ix)'
m.wr.sysOut = wriClo(wrNew(), 'do ix=1 to m.stem.0;' sy ';end')
m.wr.out = m.wr.sysOut
m.wr.out.0 = 0
return
endProcedure wrIni
/**** simple convience function for stems *****************************/
/*--- fill stem st from index dx with lines from stem src ------------*/
wrStem: procedure expose m.
parse arg dst, dx, src
if dx == '' then
dx = m.dst.0
do ix = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.ix
end
m.dst.0 = dx
return dst
endProcedure wrStem
/*--- strip trailing spaces from stem dst ----------------------------*/
wrStrip: procedure expose m.
parse arg dst
do ix=1 to m.dst.0
m.dst.ix = strip(m.dst.ix, 't')
end
return dst
endProcedure wrStrip
/*--- fill stem dst from index dx with arguments ---------------------*/
wrArgs: procedure expose m.
parse arg dst, dx
if dx == '' then
dx = m.dst.0
do ix = 3 to arg()
dx = dx + 1
m.dst.dx = arg(ix)
end
m.dst.0 = dx
return dst
endProcedure wrArgs
/***********************************************************************
Input-Ouput
transfer data betweeen stems and datasets
these are specified using a DataSetSpec DSS see wrAlloc:
***********************************************************************/
/*--- define writeDescriptor m to write to the datasetSpec dss */
wr2DS: procedure expose m.
parse arg m, dss, opt
if opt == '' then
opt = 'o'
ty = wrAlloc(m, opt, dss)
stmt = ''
if m.wr.allocStrip.m then
stmt = 'call wrStrip stem;'
if ty == 's' then do
call wriClo m,
, stmt 'call wrStem' quote(m.wr.allocStem.m) ', , stem',
, m.wr.allocFree.m
end
else if ty == 'd' then do
dd = m.wr.allocDD.m
call writeDDBegin dd
call wriClo m,
, stmt 'call writeDD' quote(dd) ', "M."'stem'"."',
, 'call writeDDEnd' quote(dd)';' m.wr.allocFree.m
end
else
call err 'wr2Ds bad allocType' ty 'from' dss
return m
endProcedure
/*--- write to writeDescriptor m from datasetSpec dss ----------------*/
wrFromDS: procedure expose m.
parse arg m, dss
if dss = '' then
call err 'wrFromDS empty datasetSpecification'
oSt = 'WR.FROMDS.'m
iTyp = wrAlloc(m, 'i', 'dd=fds'm dss)
if iTyp == 's' then do
call write m, m.wr.allocStem.m
end
else if iTyp = 'd' then do
st = 'WR.WRFROMDS.'m
dd = m.wr.allocDD.m
call readDDBegin dd
do while readDD(dd, 'M.'st'.')
call write m, st
end
call readDDEnd dd
interpret m.wr.AllocFree.m
end
else
call err 'wrFromDS: bad allocTyp' iTyp 'from' dss
return
endProcedure wrFromDS
/*--- using m, write datasetSpec frSp to datasetSpec toSp ------------*/
wrDSFromDS: procedure expose m.
parse arg m, toSP
call wr2DS m, toSp
do ax=3 to arg()
frSp = arg(ax)
if ax ^= '' then
call wrFromDs m, frSp
end
call wrClose m
return
endProcedure wrFromDS
/*----------------------------------------------------------------------
wrAlloc: allocate a file or stem from datasetSpecification dss
opt in i, o or a (input, output or append)
dss in key=value syntax, either tso alloc attributes or
dss in key=value syntax, either tso alloc attributes or
disp=...,
dsj= DatasetName in Jcl format (dsn= for tso format)
stem=xyz to allocate a stem m.xyz.*
strip=1 to strip trailing blanks before writing
----------------------------------------------------------------------*/
wrAlloc: procedure expose m.
parse arg m, opt, dss
s = 'WR.ALLOC'
m.wr.allocDD.m = ''
stem = ''
at = ''
disp = ''
m.wr.allocStrip.m = 0
m.wr.allocFree.m = ''
call scanBegin s, dss
do while scanKeyValue(s, 1, 0)
k = m.s.key
if k == 'DD' then m.wr.allocDD.m = m.s.val
else if k == 'DSJ' then at = at "dsn('"m.s.val"')"
else if k == 'STEM' then stem = m.s.val
else if k == 'DISP' then disp = m.s.val
else if k == 'STRIP' then m.wr.allocStrip.m = m.s.val
else if k == 'INTER' then inter = m.s.val
else if left(m.s.val, 1) = '(' then
at = at m.s.key || m.s.val
else at = at m.s.key"("m.s.val")"
end
call scanVerify s, ' '
if ^scanAtEOL(s) then
call scanErr s, 'wrAlloc bad clause'
if stem ^= '' then do
m.wr.allocStem.m = stem
if opt == 'o' then /* overrite existing lines */
m.stem.0 = 0
m.wr.allocType.m = 's'
end
else if at = '' then do
if m.wr.allocDD.m = '' then
call err 'dd or attribute must be specified:' dss
m.wr.allocType.m = 'd'
end
else do
m.wr.allocType.m = 'd'
if m.wr.allocDD.m = '' then
m.wr.allocDD.m = 'ALL'm
if disp ^= '' then nop
else if opt == 'a' then disp = 'mod'
else if opt == 'o' then disp = 'old'
else disp = 'shr'
if m.wr.allocApp.m = 1 then do
d3 = translate(strip(left(disp, 3)))
if d3 == 'OLD' | d3 == 'SHR' then
disp = 'mod' || substr(strip(disp), 4)
end
call adrTso "alloc dd("m.wr.allocDD.m")" disp at
m.wr.allocFree.m = 'call adrTso' ,
quote('free dd('m.wr.allocDD.m')')
end
return m.wr.allocType.m
endProcedure wrAlloc
/* copy wr end ****************************************************/
/* copy pos begin *****************************************************
StringHandling
posRep: return the index of rep'th occurrence of needle
posLev: return n'th level (separated by needle)
posCnt: count the occurrences of needle
***********************************************************************/
/*--- return the index of rep'th occurrence of needle
negativ rep are counted from right -------------------------*/
posRep: procedure
parse arg needle, hayStack, rep, start
if rep > 0 then do
if start = '' then
start = 1
do cc = 1 to rep
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return sx
end
else if rep < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -rep
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return sx
end
else
return 0
endProcedure posRep
/*--- return n'th level (separated by needle, negative from right) ---*/
posLev: procedure
parse arg needle, hayStack, rep, start
if rep > 1 then do
sx = posRep(needle, hayStack, rep-1, start)
if sx < 1 then
return 0
return 1+sx
end
else if rep < -1 then do
sx = posRep(needle, hayStack, rep+1, start)
if sx < 1 then
return 0
return 1+lastPos(needle, hayStack, sx-1)
end
else if rep ^= -1 then
return rep /* for 0 and 1 */
else if start == '' then /* pos fails with empty start| */
return 1 + lastPos(needle, hayStack)
else
return 1 + lastPos(needle, hayStack, start)
endProcedure posLev
/*--- 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)
cnt = 0
do forever
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
cnt = cnt + 1
start = start + length(needle)
end
endProcedure posCount
/*--- concatenate several parts to a dsn -----------------------------*/
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
/*--- set the membername mbr into dsn --------------------------------*/
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
endProcedure dsnSetMbr
/*--- get the membername from dsn ------------------------------------*/
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), 't', "'")
endProcedure dsnGetMbr
/*--- get the index of the lx'd level of dsn -------------------------*/
dsnPosLev: procedure
parse arg dsn, lx
sx = posLev('.', dsn, lx)
if sx ^= 1 then
return sx
else
return 1 + (left(dsn, 1) == "'")
endProcedure dsnPosLev
/*--- get the the lx'd level of dsn ----------------------------------*/
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
/* copy pos 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
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 showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readDD(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
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
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
***********************************************************************/
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 'for' ggIspCmd
endSubroutine adrIsp
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 adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
/**********************************************************************
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 */
/*--- 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 */
/* copy adr end ****************************************************/
/* copy err begin *****************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' 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 zIspfRc
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
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
/* copy err end ****************************************************/
}¢--- A540769.WK.REXX.O13(PVSLOG) cre= mod= ------------------------------------
call adrTso 'alloc dd(in) shr reuse dsn(WK.TEXTVB(PTAEXT)'
call adrTso 'alloc dd(out) shr reuse dsn(WK.TEXTVB(sum)'
call readDDBegin in
call writeDDBegin out
ox = 0
begCnt = 0
endCnt = 0
do while readDD(in, r.)
do r=1 to r.0
cx = pos("CURRENT DATE IS", r.r)
if cx > 0 then do
da = space(substr(r.r, cx + 15))
if right(word(da, 1), 1) == "," then do
da = word(da, 2) ,
translate(left(word(da, 3), 1)) ,
|| translate(substr(word(da, 3), 2) ,
, 'abcdefghijklmnopqrstuvwxyz' ,
, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'),
word(da, 4)
da = date('s', da, 'n')
end
else do
da = word(da, 1)
if length(da) == 10 then
da = left(da,6)right(da, 2)
da = date('s', da, 'e')
end
da = right(da, 2)'.'substr(da, 5, 2)'.'left(da, 4)
say 'date' da
iterate
end
ti = substr(r.r, 2, 8)
id = substr(r.r, 12, 8)
if id == 'PVS2021 ' then do
begCnt = begCnt + 1
end
else if id == 'PVS2022 ' then do
endCnt = endCnt + 1
if substr(r.r, 53, 6) ^= 'PVSR#=' then
call err 'bad end Rec': r.r
pvsR.endCnt = word(substr(r.r, 59), 1)
end
else if id == 'PVS2025 ' then do
endCnt = endCnt + 1
pvsR.endCnt = 00000000
end
else if id == ' DSN ' then do
dsn = word(substr(r.r, 23), 1)
if substr(dsn, 3, 1) == 'S' then
dsn = overlay('R', dsn, 3)
if symbol('m.beg.dsn') == 'VAR' then do
if endCnt <= 0 then do
say 'ignoring' r.r
end
else do
if endCnt > 1 then do
e1 = endCnt - 1
say 'endCnt' endCnt pvsR.endCnt pvsR.e1 dsn
end
ox = ox + 1
o.ox = m.beg.dsn','ti da','pvsR.endCnt','dsn
drop m.beg.dsn
endCnt = endCnt - 1
end
end
else if begCnt > 0 then do
m.beg.dsn = ti da
begCnt = begCnt - 1
end
end
end
if ox > 100 then do
call writeDD out, o., ox
ox = 0
end
end
if begCnt ^= 0 | endCnt ^= 0 then
call err 'at end begCnt' begCnt 'endCnt' endCnt
if ox > 0 then do
call writeDD out, o., ox
ox = 0
end
call readDDEnd in
call writeDDEnd out
exit
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
/* copy adr begin ****************************************************/
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
/**********************************************************************
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 */
/*--- 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 */
/* copy adr end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
x = x / 0
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' 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 zIspfRc
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
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX.O13(PVSRRMEM) cre= mod= ----------------------------------
/* rexx ****************************************************************
pvsrRmEm: remove empty datasets
kpco 4, pvs
arguments: a list of dd names (space separated)
function: for each ddName from arguments
if a dd with this name is preallocated
if this file is empty then delete it
***********************************************************************/
parse arg args
say 'pvsrRmEm begin' args
do i=1 to words(args)
dd = word(args, i)
ld = listDsi(dd 'file')
if ld <> 0 then
say 'rc' ld 'from listDsi('dd 'file):' sysMsgLvl2
else do
say 'dd' dd 'dsn' sysDsName ,
'used' sysUsed', alloc' sysAlloc sysUnits
if sysUsed = 0 then do
say 'deleting dd' dd 'dsn' sysDsName
address tso "delete '"sysDsName"'"
if rc <> 0 then
say "error rc" rc "in delete '"sysDsName"'"
end
end
end
say 'pvsrRmEm end' args
exit
}¢--- A540769.WK.REXX.O13(PVSRTEDA) cre= mod= ----------------------------------
/* rexx ***************************************************************
pvsrTeDa testData Generator für Maschinentest
TestDaten erzeugen mit verschiedenen Beilagen Kombinationen
und verschiedenen Seitenzahlen (zurzeit für C4)
1. Beilagen definieren: bis zu sechs Beilagen, jede Beilage
kann beigelegt oder ausgelassen werden
2 ** b BeilagenKombination
2. Limiten bestimmen
config C5 und C4 ==> wir brauchen was zugross für C5 ist
==> wir brauchen was zugross für C5 aber OK für C4
Limiten hängen von BeilagenKobination
3. Random Funktion bestimmen, die Seitenverteilung bestimmt
==> typisch min. und max. Seitenanzahl häufig
erzeugen, mittlere Seitenzahlen seltener
4. Skeleton Dokument einlesen
5. Output Dokumente erzeugen, Kopie ab Skeleton mit
Random erzeugter BeilagenKombination und SeitenZahl
Parameter: fun mach sz1 sz2
fun = Funktion
mach = 'EIN' für Einzelblatt oder '1UP' für 1 up
sz1 sz2: Grössen
fun = 'T1': drei Test Dokumente erzeugen
fun = 'LIM': Limiten testen sz1=Ra (default 2)
erzeugt bis zu 4*Ra Dokumente dies- und jenseits der C4 Grenze
Seiten: p5-Ra+1..p5, p5+1..p5+Ra, p4-Ra+1..p4, p4+1..p4+R1
mit p5 = maximal Seiten C5 und p4=maximale Seiten C4
d.h. je Ra Dokumente die gerade noch passen bzw. nicht
==> Zweck: im Output überprüfen, ob Dokumente im richtigen
Format landen (suche nach dokc5, dokc4 und dokcH)
fun = 'ran': Random verteilte Dokumente erzeugen für C4
maximal sz1 Dokumente und sz2 Seiten (was zuerst erreicht wird)
IO: im Foreground werden docIn und pvsOut dynamisch alloziert
im Batch müssen sie prealloziert werden
DD docIn: Skeleton Dokument (1 PVS-Dokument mit 1 Seite)
==> POSY.RZ1.T0.AKT.TESTFALL.DATA(VERAAA)
DD pvsOut: output Druckfile im PVS-Format
jede Seite enthält Infos über Beilagen, Dokument
und das (erwartete) Format (dokc5, dokc4 und dokcH)
Konfiguration Beilagen: durch call addBei in procedure config
Konfiguration der Couverts usw. durch addFor in config,
Achtung die aktuellen Zahlen stimmen für Einzelblatt in einigen
Fällen nicht (POSY rechnet dort aus unerfindlichen Gründen anders)
Definition VerteilungsFunktion durch Zuweisung an m.dis.src
der Zugewiesene Wert muss die Form
s1 w1 s2 w2 ..... * * t1 v1 t2 v2 .....
haben. s1, t1, s2, t2 usw sind Seiten Zahlen
w1, v2, w2, v2 usw. sind ProzentZahlen
s%, t% gelten von links, t%, v% von rechts
und * * markiert die Mitte
mit p5 = maximal Seiten C5, p4=maximale Seiten C4
und tx vx letztes Tupel also
SeitenZahl p5+1 - p5+s1 mit w1% Wahrsch.
SeitenZahl p5+1+s1 - p5+s1+s2 mit w2% Wahrsch.
....
SeitenZahl mittendrin mit Rest Wahrsch.
....
SeitenZahl p4+1-tx - p4 mit vx% Wahrsch.
History
2005.12.22 W.Keller KRDO 4: refactoring und Kommentare
2005.11.22 W.Keller KRDO 4: neu
**********************************************************************/
m.trace = 0
if 0 then random(1,100,1) /* seed definieren, für reproduzierbare
Folge, sonst zufälliger Seed */
if 0 then call randShow
parse upper arg fun mach sz1 sz2
if fun = '' then
parse upper value 'ran 1up 2000 ' with fun mach sz1 sz2
say 'start fun' fun 'machine' mach 'size1' sz1 'size2' sz2
m.dis.src = '1 15 5 25 * * 5 25 1 15'
say 'disrtibution' m.dis.src
call config mach
say m.bei.0 'Beilagen und' m.com.0 'Kobminationen'
if 0 then call show
if 0 then call randTest
foreground = sysvar(sysEnv) = 'FORE'
if foreGround then
call foregroundAlloc "'POSY.RZ1.T0.AKT.TESTFALL.DATA(VERAAA)'",
, "'A540769.TEST.OUT'"
call readDoc
m.docs = 0
m.pages = 0
call writeDDBegin pvsOut
if fun = 'T1' then do
call onedoc 60 3
call onedoc 48 1
call onedoc 16 2
end
else if fun = 'LIM' then do /* check limits */
call show
border = sz1
if border = '' then
border = 2
do c = 1 to m.com.0
do p=max(1, m.com.c.pagC5 + 1 - border) to m.com.c.pagC5
call oneDoc c p, m.for.1.name
end
do p=m.com.c.pagC5 + 1 to m.com.c.pagC5 + border
call oneDoc c p, m.for.2.name
end
do p=m.com.c.pagC4+1-border to m.com.c.pagC4
call oneDoc c p, m.for.2.name
end
do p=m.com.c.pagC4+1 to m.com.c.pagC4+border
call oneDoc c p, m.for.3.name
end
end
end
else if fun = 'RAN' then do
if sz1 = '' & sz2 = '' then
sz1 = 20
if sz1 = '' then
sz1 = 999999999
if sz2 = '' then
sz2 = 999999999
do i=1 to sz1 while sz2 > m.pages + m.docs
call onedoc rand()
/* say c m.com.c.name p 'Dis' d */
end
end
else
call err 'bad fun' fun
call writeDDEnd pvsOut
say m.docs 'Dokumente mit' m.pages 'Seiten (ohne Adressblätter)'
if foreGround then
call foregroundFree
exit
/* print one Document with
BeilagenCombination c, number of pages p ----------------------*/
oneDoc: procedure expose m.
parse arg c p ., dokMrk
m.docs = m.docs + 1
m.pages = m.pages + p
call trc oneDoc 'comb' c m.com.c.name 'pages' p 'mark' dokMrk
/*---- beilagen */
beiStr = m.com.c.name
m.dt.1 = overlay(' ', m.dt.1, 93, 48)
bx = 0
do b=1 to m.bei.0
if substr(beiStr, 2*b - 1, 2) ^== m.bei.b.naSh then
iterate
bx = bx + 1 /* PVSBEIL(bx) */
m.dt.1 = overlay(m.bei.b.name, m.dt.1, 83 + 8*bx, 8)
end
m.dt.1 = overlay(d2c(bx,2), m.dt.1, 89, 2) /* PVSBEIL# */
/*---- pvsHeader */
m.dh.1 = overlay('Dok' || dokMrk || right(m.docs, 6)'Ti'm.time,
, m.dh.1, 51, 20) /* pvsUser2 */
m.dh.1 = overlay(m.pvsIdent, m.dh.1, 163, 8) /* pvsIdent */
m.dh.1 = overlay('1', m.dh.1, 208, 1) /* pvsFormH */
/*---- pvsAdress */
m.dh.2 = overlay('3', m.dh.2, 7, 1) /* pvsARule */
m.dh.2 = overlay(left('Seiten Anzahl', 18)right(p, 7),
, m.dh.2, 70, 35) /* pvsAdrL2 */
m.dh.2 = overlay(left('Dokument' dokMrk 'Nr.', 18)right(m.docs, 7),
, m.dh.2, 105, 35) /* pvsAdrL3 */
m.dh.2 = overlay('Beilagen' bx ':' beiStr , m.dh.2, 140, 35)
/*---- pvsTrailer */
m.dt.1 = overlay(d2c(p, 2), m.dt.1, 7, 2) /* PVSPAGE */
/*---- Daten */
q = m.ddx
if m.ddx.0 >= 2 & m.ddx.2 > 0 then
m.dd.q = overlay('DokNr.' right(m.docs, 6),
, m.dd.q, m.ddx.2, m.ddl.2)
if m.ddx.0 >= 3 & m.ddx.3 > 0 then
m.dd.q = overlay('Bei.' beiStr,
, m.dd.q, m.ddx.3, m.ddl.3)
call writeDD pvsOut, m.dh.
do px=1 to p
if m.ddx.0 >= 1 & m.ddx.1 > 0 then
m.dd.q = overlay('Seite'right(px,6)'/'right(p,5),
, m.dd.q, m.ddx.1, m.ddl.1)
call writeDD pvsOut, m.dd.
end
call writeDD pvsOut, m.dt.
return
endProcedure oneDoc
/*--- read and analyse the skeleton document
for later use by oneDoc ----------------------------------------*/
readDoc: procedure expose m.
call readDDBegin docIn
call readDD docIn, m.d., '*'
call readDDEnd docIn
dWrds = "$x1x$ $x2x$ $x3x$"
do x=1 to m.d.0
if left(m.d.x, 5) == '@#H04' then
hx = x
else if left(m.d.x, 5) == '@#A04' then
ax = x
else if left(m.d.x, 5) == '@#T04' then
tx = x
else if pos(word(dWrds, 1), m.d.x) > 0 then
dx = x
end
if hx ^== 1 | ax ^== 2 then
call err 'bad header' hx 'or address ' ax
if tx ^== m.d.0 then
call err 'bad trailer' tx ' ^= last' m.d.0
m.dh.0 = 2
m.dh.1 = m.d.1
m.dh.2 = m.d.2
m.dt.0 = 1
m.dt.1 = m.d.tx
y = 0
m.dd.0 = tx - 3
do x=ax+1 to tx-1
y = y+1
m.dd.y = m.d.x
end
m.ddx = dx - ax
m.ddx.0 = words(dWrds)
do v=1 to words(dWrds)
m.ddx.v = pos(word(dWrds, v), m.d.dx)
m.ddl.v = 20
end
say 'docIn docLines' m.dd.0
return
endProcedure readDoc
/*--- configure machine: c5, c4, cH and Beilagen ---------------------*/
config: procedure expose m.
parse arg m.machine
say 'Maschine' m.machine
m.for.0 = 0
m.bei.0 = 0
m.com.0 = 0
t = time()
m.time = left(t,2)substr(t, 4,2)right(t, 2)
if m.machine == '1UP' then do
m.pvsIdent = 'ZV06'
call addFor 'c5', 15, 3, 55-5
end
else if m.machine == 'EIN' then do
m.pvsIdent = 'HY21'
call addFor 'c5', 15, 3, 55-5 + 2
end
else
call err 'unbekannter Maschinen typ' m.machine
call addFor 'c4', 79, 1, 86-5-1 /* AdressBlatt abgezählt */
call addFor 'cH'
call addBei 'WK-BEI01', 10, 10
call addBei 'WK-BEI02', 12, 12
call addBei 'WK-BEI03', 999, 09
call addBei 'WK-BEI04', 14, 14
call addBei 'WK-BEI05', 5, 5
call addBei 'WK-BEI06', 999, 6
call combine 1, "", 0, 0
return
endProcedure config
/*--- add a envelop format: name, maximal Sheets,
thickness of one sheet, inside thickness of envelope -------*/
addFor: procedure expose m.
x = m.for.0 + 1
m.for.0 = x
parse arg m.for.x.name, m.for.x.shMax, m.for.x.shThick,
, m.for.x.thick
return
endProcedure addFor
/*--- add a Beilage: name, thickness C5, thickness C4 ----------------*/
addBei: procedure expose m.
x = m.bei.0 + 1
m.bei.0 = x
parse arg m.bei.x.name, m.bei.x.1, m.bei.x.2
sh = strip(m.bei.x.name)
m.bei.x.naSh = left(sh,1)right(sh,1) /* short name */
return
endProcedure addFor
/*--- for each combinatition of Beilagen calculate limits recursively
x = number of beilagen
nm = name of combination so far (concat of beilagen names
t1, t2 = total thickness of Beilagen in C5, respectively C4
----------------------------------------------------------------------*/
combine: procedure expose m.
parse arg x, nm, t1, t2
if x <= m.bei.0 then do
/* recursively do rest with and without Beilage x+1 */
call combine x+1, nm || left('',length(m.bei.x.naSh)), t1, t2
call combine x+1, nm || m.bei.x.naSh,
, t1 + m.bei.x.1, t2 + m.bei.x.2
return
end
/* all Beilagen: add combination */
y = m.com.0 + 1
m.com.0 = y
m.com.y.name = nm
m.com.y.thick1 = t1
m.com.y.thick2 = t2
p5 = min(m.for.1.shMax, /* max sheets C5 */
, max(0, (m.for.1.thick - t1) % m.for.1.shThick))
p4 = min(m.for.2.shMax, /* max sheets C4 */
, max(0, (m.for.2.thick - t2) % m.for.2.shThick))
if p5 >= p4 then
call err 'pagC5 > pagC4'
m.com.y.pagC5 = p5
m.com.y.pagC4 = p4
weTo = 0
ml = ''
p4 = p4 + 1
p5 = p5 + 1
mr = p4
if wordPos('*',m.dis.src)//2 ^=1 | words(m.dis.src) // 2 ^= 0 then
call err 'bad distribution src' m.dis.src
lx = 1
rx = words(m.dis.src)
do forever
if cl ^== '*' then do
cl = word(m.dis.src, lx)
wl = word(m.dis.src, lx+1)
lx = lx + 2
end
if cl ^== '*' then do
ml = ml p5 wl
p5 = p5 + cl
weTo = weTo + wl
if p5 >= p4 then do
m.com.y.pageDist = ml mr
leave
end
end
if cr ^== '*' then do
cr = word(m.dis.src, rx-1)
wr = word(m.dis.src, rx)
rx = rx - 2
end
if cr ^== '*' then do
p4 = p4 - cr
if p5 >= p4 then do
m.com.y.pageDist = ml p5 wr mr
leave
end
mr = p4 wr mr
weTo = weTo + wr
end
else if wr == '*' then do
if cr == '*' then
cr = 100-weTo
m.com.y.pageDist = ml p5 cr mr
leave
end
end
if weTo > 100 then
call err 'wei > 100 map' map
return
endProcedure combine
primes: procedure
parse arg p, lim
if p = '' then
p = 0
else
p = p - 1
do while p <= lim
p = prime(p+1)
say p
end
return
endProcedure primes
prime: procedure
parse arg s
if s // 2 = 0 then
s = s + 1
do forever
do d=3 by 1
if d * d > s then
return s
if s // d = 0 then
leave
end
s = s + 2
end
endProcedure prime
/*--- random next combination pages pair -----------------------------*/
rand: procedure expose m.
do ix=1 to 10000
c = random(1, m.com.0)
if c = '' then
call err 'emtpy combination in rand'
p = randDist(m.com.c.pageDist)
if p ^== '' then
return c p
end
call err 'all maps empty?'
endProcedure rand
/*--- test rand ------------------------------------------------------*/
randTest: procedure expose m.
mxPg = 100
do c=1 to m.com.0
do p=1 to mxPg
c.c.p = 0
c.c = 0
p.p = 0
end
end
do ix=1 to 10000
parse value rand() with c p
c.c.p = c.c.p + 1
c.c = c.c + 1
p.p = p.p + 1
end
do c=1 to m.com.0
say right(c.c, 6) 'comb' c left(m.com.c.name, 12),
"maxPages" right(m.com.c.pagC5, 5)right(m.com.c.pagC4, 5)
m = ''
do l=1 to mxPg while c.c.l = 0
end
do r=mxPg by -1 to 1 while c.c.r = 0
end
m=l'>'
do p=l to r
m = m c.c.p
end
m = m '<'r
say ' ' m
end
return
endProcedure randTest
/*--- get the next random value of random distribution map
map must be a list of numbers f1 w1 f2 w2 f3 w3.... meaning
f1 to f2-1 with with w1 percent probability
f2 to f3-1 with with w2 percent probability
----------------------------------------------------------------------*/
randDist: procedure expose m.
parse arg map
max = 1237-1 /* big prime - 1 ==> modulo is a prime */
if symbol('m.randDist.mapIndex.map') == 'VAR' then do
m = m.randDist.mapIndex.map
end
else do
if symbol('m.randDist.0') == 'VAR' then
m = m.randDist.0 + 1
else
m = 1
m.randDist.0 = m
m.randDist.mapIndex.map = m
fact = (max+1) / 100
rNx = 0
we = 0
do wx = 1 by 2 to words(map) - 1
fr = word(map, wx)+0
we = we + word(map, wx+1)
nx = word(map, wx+2)+0
if nx = '' then
nx = fr + 1
else if fr >= nx then
call err 'map not increasing at' wx'='fr 'map' map
rLa = rNx
rNx = we * fact
if rNx ^= trunc(rNx) then
rNx = trunc(rNx)+1
do r=rLa to rNx - 1
m.randDist.m.r = fr + ((r-rLa) % ((rNx-rLa)/(nx - fr)))
end
end
if rNx - 1 > max then
call err 'overflow' r 'in map' map
do r=rNx by 1 to max
m.randDist.m.r = ''
end
end
r = random(0, max)
return m.randDist.m.r
endProcedure randDist
randDistTest: procedure expose m.
parse arg map
say 'map' map
x = randDist(map)
m = m.randDist.mapIndex.map
do r=0 to 22
/* say right(r, 2) 'map' m.randDist.m.r */
c.r=0
end
ll = ''
c.ll = 0
do q=1 to 2000
c.x = c.x + 1
x = randDist(map)
end
say "'' dst" c.ll
do r=0 to 22
say right(r, 2) 'dst' c.r
c.r=0
end
return
endProcedure randDistTest
/*--- show configuration with limits --------------------------------*/
show: procedure expose m.
say 'distribution' m.diss.rc
l = length(m.com.1.name)
if l < 6 then
l = 6
say m.for.0 'formats'
do x=1 to m.for.0
say " " left(m.for.x.name, l),
"sheet max" right(m.for.x.shMax, 6) ,
"thickness sheet" right(m.for.x.shThick, 6) ,
"envelope inside" right(m.for.x.thick, 6)
end
say m.bei.0 'Beilagen'
do x=1 to m.bei.0
say " " left(m.bei.x.naSh, l) "thickC5C4",
|| right(m.bei.x.1, 5)right(m.bei.x.2, 5)
end
say m.com.0 'combinations'
do x=1 to m.com.0
if 1 then
say " " left(m.com.x.name, l),
"Beilagen" right(m.com.x.thick1,5)right(m.com.x.thick2,5),
"maxPages" right(m.com.x.pagC5, 5)right(m.com.x.pagC4, 5)
if 0 then
say ' pageDist' m.com.x.pageDist
end
return
endProcedure show
/*--- dyn alloc input and output ------------------------------------*/
foregroundAlloc: procedure
parse arg docIn, pvsOut
say "dynAlloc docIn " docIn
call adrTso "alloc dd(docIn) shr dsn("docIn")"
say "dynAlloc pvsOut" pvsOut
call adrTso "alloc dd(pvsOut) old dsn("pvsOut")"
return
endProcedure foregroundAlloc
/*--- dyn free input and output --------------------------------------*/
foregroundFree: procedure
call adrTso "free dd(docIn pvsOut)"
return
endProcedure foregroundFree
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
/* copy adr begin ****************************************************/
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
/**********************************************************************
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 */
/*--- 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 */
/* copy adr end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
x = x / 0
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' 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 zIspfRc
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
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX.O13(PVSRTRAC) cre= mod= ----------------------------------
/* rexx ***************************************************************
pvsRTrac: Einschreiben_Nummern konsolidieren und versenden
dd parm in: parm file
key = value Syntax von scanKeyValPC(.,1,1,'*')
dd phase io: restart Information
filelist io: Liste der in der Write Phase verarbeiteten Files
Funktion:
Vorbereitung: parm File lesen, compilieren, ausführen
phase File einlesen und Restart Aktionen
PW: phaseWrite: die Track2 files aus dem Catalog lesen
(Maske $mask) und konkatinieren in temp BU-Files
PN: phaseRneame: die Track2 Files auf Track3 umbenennen
und die temp BU-Files auf den definitiven Namen
PS: phaseSend: die BU-Files mit Connect Direct verschicken
History
2005.12.22 W. Keller KRDO 4, Acc BU nur falls BU A.... definiert
2005.12.16 W. Keller KRDO 4, Acceptance: 6.Stelle FileNa = 'S'
2005.12.14 W. Keller KRDO 4, vereinfachte Syntax
2005.11.22 W. Keller KRDO 4, neu
***********************************************************************/
parse upper arg m.env
/* Konstanten abfüllen */
/* attribute (DSS) der BU-FIles */
m.attributes = 'space="(1,10) tracks" recfm=v,b lrecl=32756' ,
'mgmtClas=S005Y000'
/* Initialisierung */
m.trace = 0
call wrIni 0
m.foreground = sysvar(sysenv) == 'FORE'
if m.foreground then
call foregroundStart
call startCheckRestart
/* die 3 Phasen durchführen */
if m.phase == '' | m.phase == 'PE' | m.phase == 'PW' then do
call phaseWrite
m.phase = 'PR'
end
if m.phase == 'PR' then do
call phaseRename
m.phase = 'PS'
end
if m.phase == 'PS' then do
call phaseSend
call writePhaseFile 'PE', m.dateTime
say '--- Ende OK all Phasen'
end
if m.foreground then
call finishForeground
exit
/*--- read parm and phase file, check restart ------------------------*/
startCheckRestart: procedure expose m.
node = sysvar(sysnode)
say "--- Beginn PVSTRACK env" m.env 'im RZ' node
call readParm /* parameter analysieren */
call readPhaseFile /* letzte Aktion herausfinden */
if m.phase == '' then /* restart Aktionen */
say 'Start ohne Informationen über vorherigen Job Lauf'
else if m.phase == 'PE' then
say 'Start nach normal beendeten Job Lauf'
else if m.phase == 'PW' then do
say 'restart WRITE phase: cleanup old BU DSNs'
call cleanupPhaseWrite
end
else if m.phase == 'PR' then
say 'restart in RENAME phase'
else if m.phase == 'PS' then
say 'restart in SEND phase'
else
call err 'ungültige phase' m.phase
return
endProcedure startCheckRestart
/*--- catalog read und BU Files schreiben ----------------------------*/
phaseWrite: procedure expose m.
/* dateTime Suffix bestimmen */
daTi = time('n')
daTi = left(daTi, 2)substr(daTi, 4, 2)right(daTi,2)
daTi = 'D'date('j')'.T'daTi
/* phase file schreiben */
say 'phaseWrite mit DateTime Suffix' daTi ,
'jetzt ist' time('n') date()
call writePhaseFile 'PW', daTi
say '--- Beginn Phase Write'
/* rexx source erstellen, um für jeden TrackFile record
mit dem rexx aus dem Parmfile die BU zu finden
und dann Record in das richtige BU File schreiben */
wx = wrNew()
/* Files öffnen und Catalog lesen */
call openBUFiles
csiKey = m.mask
call readCat
liCnt = 0
/* jeden Catalog Eintrag verarbeiten */
do cx=1 to csiDsn.0
dsn = csiDsn.cx
/* in die FileListe eintragen */
call writeLn m.fileList, 'TRACK' dsn
/* file Lesen und verarbeiten */
call readDS wx, 'dsj='dsn
do while read(wx, trIn)
do rx=1 to m.trIn.0
call writeBuRec trIn.rx
end
end
/* file Lesen und mit wx verarbeiten */
say m.wr.readSX.wx 'Zeilen von' dsn
liCnt = liCnt + m.wr.readSX.wx
end
/* Zähler anzeigen */
say csiDsn.0 'DSNs mit total' liCnt 'Zeilen gelesen'
/* Files schliessen */
call closeBUFiles
say m.cnt.noWr 'Zeilen von unterdrückten BUs'
say m.cnt.undef 'Zeilen von nicht definierten BUs:' m.cnt.undefIds
return
endProcedure phaseWrite
/*--- rename der Track Files -----------------------------------------*/
phaseRename: procedure expose m.
trNew = m.renameLLQ
call writePhaseFile 'PR', m.dateTime
say '--- Beginn Phase Rename'
do retry=1 by 1
call readDS rFl, 'dd=filelist'
cnt = 0
cntTr = 0
cntRe = 0
m.disappeared = 0
do while readLn(rFl, rec)
cnt = cnt + 1
say cnt 'fileList' m.rec
parse var m.rec flTy old .
if flTy == 'BU' then
iterate
else if flTy ^== 'TRACK' then
call err 'bad type in fileList:' flTy
cntTr = cntTr + 1
new = left(old, dsnPosLev(old, -1)-1) || trNew
cntRe = cntRe + rename(old, new, 'trackfile')
end
say cntTr "TRACK-DSNs und" (cnt -cntTr) "BU-DSNs"
say cntRe 'rename''t' m.disappeared 'verschwunden'
cntEr = cntTr - cntRe -m.disappeared
if cntEr = 0 then
return
say '****** Fehler in' cntEr 'renames'
if retry > 3 then
call err 'nicht alle Datasets rename''t oder verschwunden'
say '--- retry' retry 'für Phase Rename'
end
endProcedure phaseRename
/*--- rename eines Datasets ------------------------------------------*/
rename: procedure expose m.
parse arg old, new, msg
if msg ^== '' then
say 'rename trackfile' old '==>' new
if adrTso("rename '"old"' '"new"'", '*') = 0 then
return 1
else if sysdsn("'"old"'") == 'DATASET NOT FOUND' then
m.disappeared = m.disappeared + 1
else
say 'dsn' old 'konnte nicht rename''t werden'
return 0
endProcedure rename
/*--- send and rename BU-Files ---------------------------------------*/
phaseSend: procedure expose m.
call writePhaseFile 'PS', m.dateTime
say '--- Beginn Phase Send'
call readDS rFL, 'dd=fileList'
m.disappeared = 0
cnt = 0
cntBu = 0
cntRe = 0
cntDi = 0
do while readLn(rFl, rec)
cnt = cnt + 1
parse var m.rec flTy old .
if flTy == 'TRACK' then
iterate
else if flTy ^= 'BU' then
call err 'bad type in fileList:' flTy
cntBu = cntBu + 1
buId = dsnGetLev(old, -1)
if symbol('m.bu.index.buId') ^== 'VAR' then
call err 'buId' buId 'nicht definiert, buFile' old
bx = m.bu.index.buId
rena = left(old, dsnPosLev(old, -2)-1) ,
|| buId || '.' || m.dateTime
if sysDsn("'"old"'") == 'DATASET NOT FOUND' then do
say 'dsn' old 'gibt es nicht'
cntDi = cntDi + 1
iterate
end
buFu = m.bu.bx.func
say 'send buId' buId 'typ' buFu 'dsn' old
if buFu == 'CD' then do
say 'connectDirect to node' m.bu.bx.node 'atts' m.bu.bx.atts
call cd old, m.bu.bx.node, m.bu.bx.atts
end
else if buFu ^== 'WR' then
call err 'bad buFunc' buFu
cntRe = cntRe + rename(old, rena, 'BU-File')
end
call readDDEnd fileList
say cntBu "BU- und" (cnt- cntBu) "TRACK-DSNs"
say cntRe 'gesendet und' cntDi 'verschwunden'
cntEr = cntBu - cntRe - cntDi
if cntEr ^= 0 then
call err 'Fehler in' cntEr 'DSNs'
return
endProcedure phaseSend
/*--- restart in phaseWrite:
alle erstellten DS löschen und neu anfangen ----------------*/
cleanupPhaseWrite: procedure expose m.
csiKey = m.prefix'.ATM.**'
call readCat
rmCnt = 0
diCnt = 0
do cx=1 to csiDsn.0
dsn = dsnFromJcl(csidsn.cx)
say 'cleanup' dsn
if adrTso("delete" dsn, '*') = 0 then
rmCnt = rmCnt + 1
else if sysdsn(dsn) == 'DATASET NOT FOUND' then
diCnt = diCnt + 1
else
say '****** Fehler beim Loeschen:' dsn':' sysdsn(dsn)
end
say rmCnt 'DSNs gelöscht' diCnt 'bereits verschwunden von' csiDsn.0
if rmCnt + diCnt ^== csiDsn.0 then
call err 'nicht alle DSNs gelöscht'
return
endProcedure cleanUpPhaseWrite
/*--- BU-Files neu erstellen -----------------------------------------*/
openBUfiles: procedure expose m.
m.fileList = wr2DS(wrNew(), "dd=filelist")
atts = "disp=new,catalog" m.attributes
m.cnt.undef = 0
m.cnt.undefIds = ''
do bx=1 to m.bu.0
id = m.bu.bx.buId
m.bu.bx.wd = ''
m.bu.bx.cnt = 0
if wordpos(m.bu.bx.func, 'CD WR') < 1 then
iterate
dsn = dsnApp(m.prefix '.ATM.'id)
call writeLn m.fileList, 'BU' dsn
say 'allocating BU' id 'dsn' dsn
m.bu.bx.wd = wr2DS(wrNew(), 'dsj='dsn atts)
end
return
endProcedure openBUFiles
/*--- BU-Files schliessen --------------------------------------------*/
closeBUfiles: procedure expose m.
m.cnt.noWr = 0
do bx=1 to m.bu.0
id = m.bu.bx.buId
if m.bu.bx.wd == '' then do
m.cnt.noWr = m.cnt.noWr + m.bu.bx.cnt
if m.bu.bx.cnt ^== 0 then
say 'close BU' id 'mit' m.bu.bx.cnt 'ignorierten Zeilen'
end
else do
call wrClose m.bu.bx.wd
say 'close BU' id 'mit' m.bu.bx.cnt 'geschriebenen Zeilen'
end
end
say 'closing fileList'
call wrClose m.fileList
return
endProcedure closeBUFiles
/*--- read Phase file, fill m.phase and m.dateTime -------------------*/
readPhaseFile: procedure expose m.
call ScanDS ps, 'dd=phase'
vars = phase dateTime
do kx=0 by 1 while scanKeyValPC(ps, 1, 1, '*')
k = m.ps.key
say 'phase' k 'val' m.ps.val
if wordPos(k, vars) < 1 then
call scanErr ps, 'key' k 'ungültig, erlaubt' vars
m.k = m.ps.val
end
if ^scanAtEnd(ps) then
call scanErr ps, 'key = value erwartet'
if kx = 0 then
say 'phase file ist leer oder enthält nur Kommentar'
call disp phase, 0, 'angefangene Phase'
call disp dateTime, 0, 'Datum Zeit file Suffix'
return
endProcedure readPhaseFile
/*--- write PhaseFile mit phase und dateTime aus Parameter -----------*/
writePhaseFile: procedure expose m.
parse arg m.phase, m.dateTime
say 'schreiben phase file mit phase='m.phase 'dateTime='m.dateTime
call wrDSFromDS 'dd=phase', 'stem='wrArgs('abc', 0,
, '*** restart file für pvsTrack Job PVT760* ***', '',
, ' * phase = letzte angefangene Phase' ,
, ' * PW = Write' ,
, ' * PR = Rename' ,
, ' * PS = Send' ,
, ' * PE = Erfolgreich beendet', ' ' ,
, ' * dateTime = Datum Zeit Suffix für Filenamen', ' ',
, 'phase = ' m.phase,
, 'dateTime = 'm.dateTime)
say 'geschrieben phase file mit phase='m.phase 'dateTime='m.dateTime
return
endProcedure writePhaseFile
/*--- compile und ausführen dd parm, Konfig anzeigen -----------------*/
readParm: procedure expose m.
say 'analysing parm file dd=parm'
call scanDS s, "dd=parm"
bx = 0
vars = mask renameLlq prefix
varBu = buId func node atts
do while scanKeyValPC(s, 1, 1, '*')
k = m.s.key
if wordPos(k, vars) > 0 then
m.k = m.s.val
else if k == defineBu then do
bx = bx + 1
call scanBegin bs, m.s.val
do ax=1 to 3
call scanWord bs, 1
w = word(varBu,ax)
m.bu.bx.w = m.bs.val
end
call scanChar bs
m.bu.bx.atts = m.bs.tok
end
else do
call scanErr s, 'ungültiger key' k 'gültig' vars
end
end
m.bu.0 = bx
if ^scanAtEnd(s) then
call scanErr s, 'key=value erwartet'
say ' '
call disp mask, 1, 'Maske der Input Trackfiles'
call disp renameLLQ, 1,"LLQ auf den die Trackfile umbenannt werden"
call disp prefix, 1,"Präfix der lokalen BU-Files"
say ''
do bx=1 to m.bu.0
say '--- BU-File' bx
call disp 'BU.'bx'.BUID', 1, 'BU Identifikation'
n = m.bu.bx.buId
m.bu.index.n = bx
call disp 'BU.'bx'.FUNC', 1, 'Funktion'
if wordPos(m.bu.bx.func, 'CD WR NN') < 1 then
call err 'ungültige BU Funktion' m.bu.bx.func
call disp 'BU.'bx'.NODE', 1, 'Empfänger Node'
call disp 'BU.'bx'.ATTS', 0, 'Empfänger Attribute'
end
return
endProcedure readParm
/*--- den Namen na, Wert einer Variabeln und msg anzeigen
falls obl Fehlermeldung falls leer oder undefiniert ------------*/
disp: procedure expose m.
parse arg na, obl, msg
if symbol("m.na") ^== 'VAR' | m.na = '' then
if obl then
call err 'variable' na 'leer oder nicht definiert'
else
m.na = ''
say left(na, 10) '=' m.na
say left('', 10) '*' msg
return
endProcedure disp
/*--- einen Track Record in die richtig BU schreiben -----------------*/
writeBURec: procedure expose m.
parse arg line
/* BU bestimmen */
buId = substr(m.line, 27, 4)
if buId = '' then
buId = '0011'
buId = 'U' || buId /* normaler prefix */
if substr(m.line, 56, 1) == 'S' then do
bb = overlay('A', buId) /* Acceptance prefix */
if symbol("m.bu.index.bb") == VAR then
buId = bb /* Acceptance is defined */
end
if symbol("m.bu.index.buId") ^== 'VAR' then do /* undefinierte BU */
m.cnt.undef = m.cnt.undef + 1
if wordPos(buId, m.cnt.undefIds) < 1 then
m.cnt.undefIds = m.cnt.undefIds buId
return
end
bx = m.bu.index.buId
m.bu.bx.cnt = m.bu.bx.cnt + 1 /* record zählen */
if m.bu.bx.wd ^== '' then
call writeLn m.bu.bx.wd, m.line /* record schreiben */
return
endProcedure writeBURec
/*--- set up test environment when started foreground ----------------*/
foregroundStart:
say 'start in foreground mode'
if env = '' then
env = 'WAK'
ph = "TEST.PVSTRACK.PHASE"
fl = "TEST.PVSTRACK.FILELIST"
pa = "'WGR.RZ1.T0.AKT.PARMLIB(PVT7600R)'"
pa = "wk.rexx(pvsrTraM)"
say 'allocating phase dd('phase') dsn('ph')'
call adrTso 'alloc dd(phase) old dsn('ph')'
say 'allocating filelist dd('filelist') dsn('fl')'
call adrTso 'alloc dd(filelist) old dsn('fl')'
say 'allocating parm dd('parm') dsn('pa')'
call adrTso 'alloc dd(parm) shr dsn('pa')'
return
endSubroutine foregroundStart
/*--- finish and cleanup in teset mode -------------------------------*/
finishForeground: procedure expose m.
say 'finish in foreground mode'
say 'freeing phase, filelist and parm'
call adrTso 'free dd(phase filelist parm)'
return
endProcedure finishForeground
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
/* copy csi begin ****************************************************/
/*===================================================================*/
READCAT:
/*===================================================================*/
/*********************************************************************/
/* */
/* PVS CATALOG SEARCHE INTERFACE */
/* */
/* DESCRIPTION: THIS REXX EXEC IS USED TO CALL THE CATALOG */
/* SEARCH INTERFACE IGGCSI00 */
/* (REPLACEMENT FOR THE IDCAMS LISTC) */
/* */
/* INPUT: CSIKEY DSLEVEL TO LOOK FOR */
/* */
/* OUTPUT: CSIDSN.0: NUMBER OF DSN'S RETURNED */
/* CSIDSN.: ARRAY WITH DSN'S */
/* */
/*********************************************************************/
/*********************************************************************/
/* */
/* INITIALIZE THE PARM LIST PASSED TO IGGCSI00 */
/* */
/*********************************************************************/
MODRSNRC = SUBSTR(' ',1,4) /* CLEAR MODULE/RETURN/REASON */
CSIFILTK = SUBSTR(CSIKEY,1,44) /* MOVE FILTER KEY INTO LIST */
CSICATNM = SUBSTR(' ',1,44) /* SET CATALOG NAME */
CSIRESNM = SUBSTR(' ',1,44) /* CLEAR RESUME NAME */
CSIDTYPS = SUBSTR(' ',1,16) /* CLEAR ENTRY TYPES */
CSICLDI = SUBSTR(' ',1,1) /* NO DATA AND INDEX */
CSIRESUM = SUBSTR(' ',1,1) /* CLEAR RESUME FLAG */
CSIS1CAT = SUBSTR(' ',1,1) /* SEARCH THIS CATALOG ONLY */
CSIRESRV = SUBSTR(' ',1,1) /* CLEAR RESERVE CHARACTER */
/*********************************************************************/
/* */
/* BUILD THE SELECTION CRITERIA FIELDS PART OF PARAMETER LIST */
/* */
/*********************************************************************/
CSIOPTS = CSICLDI || CSIRESUM || CSIS1CAT || CSIRESRV
CSIFIELD = CSIFILTK || CSICATNM || CSIRESNM || CSIDTYPS || CSIOPTS
/*********************************************************************/
/* */
/* INITIALIZE AND BUILD WORK ARE OUTPUT PART OF PARAMETER LIST */
/* */
/*********************************************************************/
WORKLEN = 1024
DWORK = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
/*********************************************************************/
/* */
/* INITIALIZE WORK VARIABLES */
/* */
/*********************************************************************/
RESUME = 'Y' /* SET RESUME FLAG */
CSIDSN.0 = 0 /* A COUNT OF DSNAMES FILLED */
/*********************************************************************/
/* */
/* SET UP LOOP FOR RESUME (IF A RESUME IS NECESSARY) */
/* */
/*********************************************************************/
DO WHILE RESUME = 'Y' /* UNTIL EOF OF CATALOG READ */
ADDRESS LINKPGM 'IGGCSI00 MODRSNRC CSIFIELD DWORK'
RESUME = SUBSTR(CSIFIELD,150,1) /* GET RESUME FLAG FOR NEXT LOOP */
USEDLEN = C2D(SUBSTR(DWORK,9,4)) /* GET AMOUNT OF WORK AREA USED */
POS1=15 /* STARTING POSITION */
/********************************************************************/
/* */
/* PROCESS DATA RETURNED IN WORK AREA */
/* */
/********************************************************************/
DO WHILE POS1 < USEDLEN /* UNTIL ALL DATA IS PROCESSED */
IF SUBSTR(DWORK,POS1+1,1) = '0' THEN /* IF ITS THE CATALOG */
DO
POS1 = POS1 + 50 /* SKIP TO THE END OF IT */
END
ELSE DO /* IF NOT CATALOG */
IF SUBSTR(DWORK,POS1+1,1) = 'A' THEN /* ONLY PROCESS NVSAM */
DO
CSIDSN.0 = CSIDSN.0 + 1 /* COUNT DSNAMES FILLED */
DSN = SUBSTR(DWORK,POS1+2,44) /* GET THE DSNAME */
I = CSIDSN.0
CSIDSN.I = DSN /* AND FILL INTO TABLE */
END
POS1 = POS1 + 46 /* SKIP TO RECORD END */
POS1 = POS1 + C2D(SUBSTR(DWORK,POS1,2)) /* ADD CSITOTLN */
END
END
END
RETURN /* RETURN TO INVOKER */
/* copy csi end *******************************************************/
/* copy cd begin **************************************************
send the file frDsn from the current not
to the node toNode as toDsn if not empty
using connect direct
default attributes may be overridden (inDISP=(OLD))
or additional connect direct attributes may be specified
in argument 4 with syntax a=b c = d etc.
***********************************************************************/
cd: procedure expose m.
parse upper arg frDsn, toNode, args
if toNode == 'RZ1' | toNode == 'RZ2' then
toNode = 'SKA.'toNode
toDsn = 'outDsn...fehlt'
as = wrArgs("CD.AS", 0 ,
, "SIGNON" ,
, " SUBMIT PROC=MVS03DSN - " ,
, "NEWNAME=PVT760MP - " ,
, "MAXDELAY=UNLIMITED - " ,
, "&DEST="toNode "- " ,
, "&INDSN="frDsn "- " ,
, "&INDISP=(SHR,KEEP,KEEP) - " ,
, "&OUTDSN="toDsn "- " ,
, "&OUTDISP=(NEW,CATLG,DELETE) - " )
call scanBegin s, args
call trc 'scanBegin' args
ax = 0
do while scanKeyValue(s, 1, 1)
k = m.s.key
if k = 'DSN' | k == 'OUTDSN' then do
k = 'OUTDSN'
toDsn = m.s.val
end
do y=2 to m.as.0
px = pos(k'=', m.as.y)
if px > 0 then
leave
end
if px > 0 then do
m.as.y= left(m.as.y, px-1)k'='m.s.val '-'
end
else do
ax = ax + 1
call wrArgs as, , "&OPARM" || ax || "="k"="m.s.val "-"
end
end
call scanVerify s, ' '
if ^scanAtEol(s) then
call scanErr s, 'key = value expected'
if pos('..', toDsn) > 0 then
call err 'no dsn specified in' args
say 'sending' frDsn 'to' toNode toDsn 'with connect direct'
hx = m.as.0
m.as.hx = left(m.as.hx, length(m.as.hx) - 1)
call wrArgs as, , 'SIGNOFF'
if m.trace == 1 then do
call trc 'connectDirect sysin'
call out as
end
if m.foreground then
if listdsi('dmpublib FILE') = 0 then
call err 'dmPublib already allocated, cdadm running?'
doAlloc = m.foreground
call adrTso "alloc new delete dd(sysIN) recfm(f,b) lrecl(80)"
call writeDDBegin sysin
call wrDSfromDS 'dd=sysIn', 'stem='as
if doAlloc then do
say 'dynamically allocating connectDirect files'
call adrTso "alloc dd(DMPUBLIB) shr" ,
"dsn('JOBP.FT1A.PRCS' 'SFT.DIV.X0.CD.PRCS')"
call adrTso "alloc dd(DMNETMAP) shr dsn('SFT.SKA.P0.CD.NETMAP')"
call adrTso "alloc dd(DMMSGFIL) shr dsn('SFT.DIV.X0.CD.MSG')"
call adrTso "alloc dd(DMPRINT) sysout(T)"
end
call trc "everything allocated callin dmBatch"
cdRc = adrTso("CALL *(DMBATCH) 'YYSLYNN'", '*')
call trc 'dmBatch rc' cdRc
call adrTso "free dd(sysin)"
if doAlloc then
call adrTso "free dd(DMPUBLIB DMPRINT DMNETMAP DMMSGFIL)"
if cdRc ^= 0 then
call err 'rc' cdRc 'in connectDirect'
return
endProcedure cd
/* copy cd end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanBegin(m,ln): set scan Source to ln
scanAtEnd(m) : returns whether we reached end of line already
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (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.m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line aSrc ------------------------------*/
scanBegin: procedure expose m.
parse arg m, m.scan.m.src, m.scan.m.reader
m.scan.m.pos = 1
m.scan.m.tok = ''
m.scan.m.val = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
end
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.reader == '' then
return m.scan.m.pos > length(m.scan.m.src)
s = m.scan.m.reader
return m.wr.readEof.s
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- scan a word
either delimited by space or stopper
or a string (with single or double quotes
put value into *.val, upercased if uc=1 and not string ---------*/
scanWord: procedure expose m.
parse arg m, uc, stopper
call scanVerify m, ' '
if scanString(m, "'") then return 1
else if scanString(m, """") then return 1
else
res = scanVerify(m, ' 'stopper, 'm')
m.m.val = m.m.tok
if uc ^== 0 then
upper m.m.val
return res
endProcedure scanWord
/*--- scan a key = word phrase
put key into *.key (uppercase if uk) and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, uk, uv
call scanVerify m, ' '
bx = m.scan.m.pos
if scanName(m) then do
m.m.key = m.m.tok
if uk ^== 0 then
upper m.m.key
call scanVerify m, ' '
if scanLit(m, '=') then do
call scanWord m, uv
return 1
end
end
m.scan.m.pos = bx
return 0
endProcedure scanKeyValue
/*--- scan a key = word (multi line) phrase with comment and +
comment starts with cc up to NL
+ and ++ are concatenation ops (++ strict, + with 1 space)
words are delimeted by nl, ' ', '+' or cc
put key into m.m.key (uppercase if uk) and
put word into m.m.val (uppercase if uv) val --------------------*/
scanKeyValPC: procedure expose m.
parse arg m, uk, uv, cc
call scanSpaceNl m, cc
if ^ scanName(m) then
return 0
m.m.key = m.m.tok
if uk ^== 0 then
upper m.m.key
call scanSpaceNl m, cc
if ^ scanLit(m, '=') then do
m.m.val = ''
return 1
end
call scanSpaceNl m, cc
call scanWord m, uv, cc'+'
vv = m.m.val
do forever
call scanSpaceNl m, cc
if ^ scanLit(m, "+") then do
m.m.val = vv
return 1
end
strict = scanLit(m, "+")
call scanSpaceNl m, cc
call scanWord m, uv, cc'+'
if strict then
vv = vv || m.m.val
else
vv = vv m.m.val
end
endProcedure scanKeyValPC
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.scan.m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
if m.scan.m.reader ^== '' then
say readInfo(m.scan.m.reader, '*')
call err 'scanErr' txt
endProcedure scanErr
/*--- begin to scan all lines from readDescriptor rx -----------------*/
scanReader: procedure expose m.
parse arg m, rx
m.scan.m.reader = rx
return scanNL(m, 1)
endProcedure scanReader
scanDS: procedure expose m.
parse arg m, dss
return scanReader(m, readDS(m, dss))
endProcedure scanDS
/*--- if lx == '' and notScanning or not atEOL return false
if lx=='' or lx=='+' then lx = nextLineIndex
if lx > lastLine return false otherwise start scan line lx -----*/
scanNL: procedure expose m.
parse arg m, lx
if lx == '' then
if m.scan.m.reader=='' | m.scan.m.pos<=length(m.scan.m.src) then
return 0
if ^ readLn(m.scan.m.reader, scan.m.liCu) then do
m.scan.m.pos = 1 + length(m.scan.m.src)
return 0
end
call scanBegin m, m.scan.m.liCu, m.scan.m.reader
return 1
endProcedure scanNL
/*--- skip over space and NL (NewLines) and comments -----------------*/
scanSpaceNL: procedure expose m.
parse arg m, cc
res = scanVerify(m, ' ')
do forever
if scanNL(m) then nop
else if cc == '' then
return res
else if ^ scanLit(m, cc) then
return res
else if ^scanNL(m, 1) then
return 1
res = 1
call scanVerify m, ' '
end
endProcedure scanSpaceNL
/* copy scan end ****************************************************/
/* copy wr begin *****************************************************
out interface
define a current output destination (a writerDescriptor)
manage them in a stack
convenience function to write to current output
***********************************************************************/
/*--- write stem stem to current output ------------------------------*/
out: procedure expose m.
parse arg stem
call write m.wr.out, stem
return
endProcedure
/*--- write up to 3 strings to current output ------------------------*/
outLn: procedure expose m.
m = m.wr.out
ox=m.wr.wrBuf.m.0
do ax=1 to arg()
ox = ox + 1
m.wr.wrBuf.m.ox = arg(ax)
end
m.wr.wrBuf.m.0 = ox
if ox > 100 then
call write m
return
endProcedure
/*--- write to current output from datasetSpec dss -------------------*/
outDS: procedure expose m.
parse arg dss
call wrFromDS m.wr.out, dss
return
endProcedure outDS
/*--- write reader rx to out -----------------------------------------*/
outReader: procedure expose m.
parse arg rx
call wrReader m.wr.out, rx
return
endProcedure outReader
/*--- redirect current output ----------------------------------------*/
outPush: procedure expose m.
parse arg o, p
x = m.wr.out.0 + 1
m.wr.out.0 = x
m.wr.out.x = m.wr.out
m.wr.prc.x = m.wr.prc
if o ^== '' then
m.wr.out = o
if p ^== '' then
m.wr.prc = p
return
endProcedure outPush
/*--- redirect current output to previous ----------------------------*/
outPop: procedure expose m.
parse arg o
x = m.wr.out.0
m.wr.out.0 = x - 1
m.wr.out = m.wr.out.x
m.wr.prc = m.wr.prc.x
return
endProcedure outPop
/**********************************************************************
writer interface
a writerDescriptor wx is allocated with wrNew
we can define the write and wrClose functionality arbitrarily
***********************************************************************/
/*--- create a new writeDescriptore ----------------------------------*/
wrNew: procedure expose m.
parse arg typ, reuseOK
if m.wr.free.0 < 1 | reuseOK == 0 then do
nn = m.wr.new + 1
m.wr.new = nn
end
else do
fx = m.wr.free.0
m.wr.free.0 = fx - 1
nn = m.wr.free.fx
end
m.wr.prcTyp.nn = typ
m.wr.prcSta.nn = ''
m.wr.wrBuf.nn.0 = 0
return nn
endProcedure wrNew
/*--- free the writeDescriptors arg(1)... ----------------------------*/
wrFree: procedure expose m.
fx = m.wr.free.0
do i = 1 to arg()
fx = fx + 1
m.wr.free.fx = arg(i)
end
m.wr.free.0 = fx
return
endProcedure wrFree
/*--- for writeDescriptor m define write and close -------------------*/
wrDefine: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, wr2, wr3
if wr2 ^== '' then
m.wr.write.m = 'do;' m.wr.write.m'; end;',
'do ggLX=1 to m.stem.0;',
'line = stem"."ggLx;' wr2,
'; end; do;' wr3'; end'
else if wr3 ^== '' then
m.wr.write.m = 'do;' m.wr.write.m'; end; do;' wr3'; end'
return m
endProcedure wrDefine
/*--- write stem m.stem. to writeDescriptor m ------------------------*/
write: procedure expose m.
parse arg m, stem
if m.wr.write.m == 'b' then do
if stem ^== '' then
call wrStem 'WR.WRBUF.'m, , stem
return
end
if m.wr.wrBuf.m.0 ^== 0 then do
ggOrigStem = stem
stem = 'WR.WRBUF.'m
interpret m.wr.write.m
m.wr.wrBuf.m.0 = 0
stem = ggOrigStem
end
if stem ^== '' then
interpret m.wr.write.m
return
endProcedure write
/*--- write up to 3 strings to writeDescriptor m ---------------------*/
writeLn: procedure expose m.
parse arg m
ox=m.wr.wrBuf.m.0
do ax=2 to arg()
ox = ox + 1
m.wr.wrBuf.m.ox = arg(ax)
end
m.wr.wrBuf.m.0 = ox
if ox > 100 then
call write m
return
endProcedure writeLn
/*--- close writeDescriptor m ----------------------------------------*/
wrClose: procedure expose m.
parse arg m
if m.wr.wrBuf.m.0 ^== 0 then
call write m
m.wr.wrbuf.pp.0 = 0 /* in case it was buffering */
interpret m.wr.close.m
return
endProcedure wrClose
/*--- initialisation writer and output -------------------------------*/
wrIni: procedure expose m.
parse arg tr
m.wr.trace = tr = 1
m.wr.new = 0
m.wr.free.0 = 0
m.wr.out = wrNew()
m.wr.sysout = m.wr.out
m.wr.prc = wrNew()
m.wr.rootPrc = m.wr.prc
if m.wr.trace then
m.wr.sysOut = wrDefine(m.wr.out,,,'say "sysout:" quote(m.line)')
else
m.wr.sysOut = wrDefine(m.wr.out,,, 'say m.line')
m.wr.out.0 = 0
return
endProcedure wrIni
/**** simple convience function for stems *****************************/
/*--- fill stem st from index dx with lines from stem src ------------*/
wrStem: procedure expose m.
parse arg dst, dx, src
if dx == '' then
dx = m.dst.0
do ix = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.ix
end
m.dst.0 = dx
return dst
endProcedure wrStem
/*--- strip trailing spaces from stem dst ----------------------------*/
wrStrip: procedure expose m.
parse arg dst
do ix=1 to m.dst.0
m.dst.ix = strip(m.dst.ix, 't')
end
return dst
endProcedure wrStrip
/*--- fill stem dst from index dx with arguments ---------------------*/
wrArgs: procedure expose m.
parse arg dst, dx
if dx == '' then
dx = m.dst.0
do ix = 3 to arg()
dx = dx + 1
m.dst.dx = arg(ix)
end
m.dst.0 = dx
return dst
endProcedure wrArgs
/***********************************************************************
reader interface
define, read and close
***********************************************************************/
/*--- define read function -------------------------------------------*/
reDefine: procedure expose m.
parse arg m, m.wr.read.m, m.wr.readCLose.m, m.wr.readInfo.m
m.wr.readLX.m = ''
m.wr.readSX.m = 0
m.wr.readEOF.m = 0
return m
endProcedure reDefine
/*--- read from readDescriptor into stem stem
return true if data read, false at eof --------------------*/
read: procedure expose m.
parse arg m, stem
if m.wr.readEOF.m then
return 0
do forever
interpret m.wr.read.m
if ^ res then
return reClose(m)
if m.stem.0 > 0 then do
m.wr.readSX.m = m.wr.readSX.m + m.stem.0
return 1
end
end
endProcedure write
/*--- close readDescriptor m, if not already done --------------------*/
reClose: procedure expose m.
parse arg m
if ^ m.wr.readEOF.m then do
m.wr.readEOF.m = 1
interpret m.wr.readClose.m
end
return 0
endProcedure reClose
/*--- put next line into m.line, return false at eof -----------------*/
readLn: procedure expose m.
parse arg m, line
if m.wr.readLx.m == '' | m.wr.readLx.m >= m.wr.readStem.m.0 then do
if ^ read(m, 'WR.READSTEM.'m) then
return 0
lx = 1
end
else do
lx = 1 + m.wr.readLx.m
end
m.wr.readLx.m = lx
m.line = m.wr.readStem.m.lx
return 1
endProcedure readLn
/*--- return readInfo for line lx ------------------------------------*/
readInfo: procedure expose m.
parse arg m, lx
if m.wr.readEof.m then
txt = 'eof after line' m.wr.readSx.m
else if lx == '' then
txt = 'last line of stem' m.wr.readSx.m
else if lx == '*' then
txt = 'line' (m.wr.readSx.m - m.wr.readStem.m.0 + m.wr.readLX.m)
else
txt = 'line' (m.wr.readSx.m + lx)
return txt 'from dss' m.wr.readInfo.m
endProcedure readInfo
/***********************************************************************
Input-Ouput
transfer data betweeen stems and datasets
these are specified using a DataSetSpec DSS see wrAlloc:
***********************************************************************/
/*--- define writeDescriptor m to write to the datasetSpec dss */
wr2DS: procedure expose m.
parse arg m, dss
ty = wrAlloc(m, 'o', dss)
stmt = ''
if m.wr.allocStrip.m then
stmt = 'call wrStrip stem;'
if ty == 's' then do
call wrDefine m,
, stmt 'call wrStem' quote(m.wr.allocStem.m) ', , stem',
, m.wr.allocFree.m
end
else if ty == 'd' then do
dd = m.wr.allocDD.m
call writeDDBegin dd
call wrDefine m,
, stmt 'call writeDD' quote(dd) ', "M."'stem'"."',
, 'call writeDDEnd' quote(dd)';' m.wr.allocFree.m
end
else
call err 'wr2Ds bad allocType' ty 'from' dss
return m
endProcedure
/*--- define m as reader to read from datasetSpec dss ---------------*/
readDS: procedure expose m.
parse arg m, dss
if dss = '' then
call err 'wrFromDS empty datasetSpecification'
iTyp = wrAlloc(m, 'i', dss)
strp = ''
if m.wr.allocStrip.m then
strp = 'if res then call wrStrip stem;'
if iTyp == 's' then do
m.wr.readDone.m = 0
call reDefine m,
, 'if m.wr.readSX.m ^== 0 then res = 0;else do;' ,
'call wrStem stem, 0,' quote(m.wr.allocStem.m)';' ,
'res = m.stem.0 > 0;' strp 'end', , dss
end
else if iTyp = 'd' then do
dd = quote(m.wr.allocDD.m)
call reDefine m, 'res = readDD('dd', "m."stem".");' strp,
, 'call readDDEnd' dd';' m.wr.AllocFree.m, dss
end
else
call err 'readDS: bad allocTyp' iTyp 'from' dss
return m
endProcedure readDS
/*--- write to writeDescriptor m from readDescriptor r ---------------*/
wrReader: procedure expose m.
parse arg m, r
st = 'WR.FROMREAD.'m
do while read(r, st)
call write m, st
end
return
endProcedure wrReader
/*--- write to writeDescriptor m from datasetSpec dss ----------------*/
wrFromDS: procedure expose m.
parse arg m, dss
rx = wrNew('wrFromDS')
call wrReader m, readDS(rx, dss)
call wrFree rx
return
endProcedure wrFromDS
/*--- write to datasetSpec toSp from datasetSpec arg(2)... -----------*/
wrDSFromDS: procedure expose m.
parse arg toSP
m = wrNew('wrDSFromDS')
call wr2DS m, toSp
do ax=2 to arg()
frSp = arg(ax)
if ax ^= '' then
call wrFromDs m, frSp
end
call wrClose m
call wrFree m
return
endProcedure wrFromDS
/*----------------------------------------------------------------------
wrAlloc: allocate a file or stem withe default ioa
from datasetSpecification dss
dss in key=value syntax, either tso alloc attributes or
disp=...,
dsj= DatasetName in Jcl format (dsn= for tso format)
stem=xyz to allocate a stem m.xyz.*
strip=1 to strip trailing blanks before writing
ioa= i, o or a (input, output or append)
----------------------------------------------------------------------*/
wrAlloc: procedure expose m.
parse arg m, ioa, dss
s = 'WR.ALLOC'
m.wr.allocDD.m = ''
stem = ''
at = ''
disp = ''
m.wr.allocStrip.m = 0
m.wr.allocFree.m = ''
call scanBegin s, dss
do while scanKeyValue(s, 1, 0)
k = m.s.key
if k == 'DD' then m.wr.allocDD.m = m.s.val
else if k == 'DSJ' then at = at "dsn('"m.s.val"')"
else if k == 'STEM' then stem = m.s.val
else if k == 'DISP' then disp = m.s.val
else if k == 'STRIP' then m.wr.allocStrip.m = m.s.val
else if k == 'IOA' then ioa = m.s.val
else if left(m.s.val, 1) = '(' then
at = at m.s.key || m.s.val
else at = at m.s.key"("m.s.val")"
end
if ^scanAtEOL(s) then
call scanErr s, 'wrAlloc bad clause'
upper ioa
if stem ^= '' then do
m.wr.allocStem.m = stem
if ioa == 'O' then /* overrite existing lines */
m.stem.0 = 0
m.wr.allocType.m = 's'
end
else if at = '' then do
if m.wr.allocDD.m = '' then
call err 'dd or attribute must be specified:' dss
m.wr.allocType.m = 'd'
end
else do
m.wr.allocType.m = 'd'
if m.wr.allocDD.m = '' then
m.wr.allocDD.m = 'ALL'm
if disp ^= '' then nop
else if ioa == 'A' then disp = 'mod'
else if ioa == 'O' then disp = 'old'
else disp = 'shr'
if m.wr.allocApp.m = 1 then do
d3 = translate(strip(left(disp, 3)))
if d3 == 'OLD' | d3 == 'SHR' then
disp = 'mod' || substr(strip(disp), 4)
end
call adrTso "alloc dd("m.wr.allocDD.m")" disp at
m.wr.allocFree.m = 'call adrTso' ,
quote('free dd('m.wr.allocDD.m')')
end
return m.wr.allocType.m
endProcedure wrAlloc
/* copy wr end ****************************************************/
/* copy pos begin *****************************************************
StringHandling
pos*: several repetitions of pos (from left or right)
dsn*: convenience functions using pos* for dataset names
***********************************************************************/
/*--- return the index of rep'th occurrence of needle
negativ rep are counted from right -------------------------*/
posRep: procedure
parse arg needle, hayStack, rep, start
if rep > 0 then do
if start = '' then
start = 1
do cc = 1 to rep
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return sx
end
else if rep < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -rep
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return sx
end
else
return 0
endProcedure posRep
/*--- return n'th level (separated by needle, negative from right) ---*/
posLev: procedure
parse arg needle, hayStack, rep, start
if rep > 1 then do
sx = posRep(needle, hayStack, rep-1, start)
if sx < 1 then
return 0
return 1+sx
end
else if rep < -1 then do
sx = posRep(needle, hayStack, rep+1, start)
if sx < 1 then
return 0
return 1+lastPos(needle, hayStack, sx-1)
end
else if rep ^= -1 then
return rep /* for 0 and 1 */
else if start == '' then /* pos fails with empty start| */
return 1 + lastPos(needle, hayStack)
else
return 1 + lastPos(needle, hayStack, start)
endProcedure posLev
/*--- 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)
cnt = 0
do forever
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
cnt = cnt + 1
start = start + length(needle)
end
endProcedure posCount
/*--- concatenate several parts to a dsn -----------------------------*/
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
/*--- set the membername mbr into dsn --------------------------------*/
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
endProcedure dsnSetMbr
/*--- get the membername from dsn ------------------------------------*/
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), 't', "'")
endProcedure dsnGetMbr
/*--- get the index of the lx'd level of dsn -------------------------*/
dsnPosLev: procedure
parse arg dsn, lx
sx = posLev('.', dsn, lx)
if sx ^= 1 then
return sx
else
return 1 + (left(dsn, 1) == "'")
endProcedure dsnPosLev
/*--- get the the lx'd level of dsn ----------------------------------*/
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
/* copy pos end ****************************************************/
/* copy adr begin ****************************************************/
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
/**********************************************************************
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 */
/*--- 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 */
/* copy adr end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' 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 zIspfRc
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
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX.O13(PVSRTRAM) cre= mod= ----------------------------------
***** parm file pvt7600 *****
***** rz1 Test Version *****
***** Rückmeldung Einschreibenummern an BU *****
mask = 'PVSO.RZ1.T0.**.TRACK5' * maske zum Suchen der Trackfiles
renameLLQ= TRACK6 * auf diesen llq werden die
* gemeldeten Trackfiles umbenannt
prefix = A540769.TEST.PVSTRACK * Präfix für lokale BU-Datasets
* jede Zuweisung an defineBU
* definiert eine BU
* die ersten drei Wörter des
* Wertes müssen
* buId, func, node
* der Rest sind Attribute für CD
* (entweder intern bekannte
* oder für OPARM?=...=...)
*
* unterstützte Funktionen
* cd = send mit connect direct
* wr = file nur schreiben
* nn = file nicht schreiben
* WGR Test
defineBU = "U0034 cd RZ2" +
"mgmtClas=S005Y000 dsn=A540769.TEST.PVSTRACD.U0034(+1)" +
"lrecl=32756 maxDelay=00:10:00"
* WGR Acceptance läuft
* vorläufig im RZ1
*efineBU = "A0034 wr RZ2" +
* "mgmtClas=S005Y000 dsn=A540769.TEST.PVSTRACA.U0034(+1)" +
* "lrecl=32756"
}¢--- A540769.WK.REXX.O13(PVSRTRAO) cre= mod= ----------------------------------
$=renameLLQ = TRACK3
$=attributes= space="(1,10) tracks" recfm=v,b lrecl=32756
$>stem=buId $<<abc
id=substr(m.line,27,4)
if id = '' then id = '0011'
pta = 'U'
if id == '0034' & substr(m.line,58,1) == 'A' then
pta = "A"
$=buId=$( pta || id $)$;
abc $;
if $env == 'PROD' then do
/* die Maske um das File zu suchen */
$=mask = PVSO.RZ2.P0.**.TRACK2
call addBu 'def' , '', RZ2, S005Y000, , ,
, PVSP.RZ2.P0.PVSTRACK
call addBu 'U0034', 'cd', PROD, MCGDG, DCVFILE, ,
, 'P1DAT.DOCSYS.FTSCS.PVSTRACK(+1)'
end
else if $env == 'TEST' then do
$=mask = PVSO.RZ1.P0.**.TRACK2
call addBu 'def' , '', RZ1, S005Y000, , ,
, PVSP.RZ1.P0.PVSTRACK
call addBu 'U0034', 'cd', TEST, MCGDG, DCVFILE, ,
, 'T1DAT.DOCSYS.FTSCS.PVSTRACK(+1)'
call addBu 'A0034', 'wr', ACC, MCGDG, DCVFILE, ,
, 'P1DAT.DOCSYS.FTSCS.PVSTRACK(+1)'
end
else do
call err 'unbekannte Umgebung env='$env
end
}¢--- A540769.WK.REXX.O13(PVSRTRA1) cre= mod= ----------------------------------
***** parm file pvt7600 *****
***** RZ1 it ('prod') : PVT7600T *****
***** Rückmeldung Einschreibenummern an BU *****
mask = 'PVSO.RZ1.P0.**.TRACK2' * maske zum Suchen der Trackfiles
renameLLQ= TRACK3 * auf diesen llq werden die
* gemeldeten Trackfiles umbenannt
prefix = PVSP.RZ1.P0.PVSTRACK * Präfix für lokale BU-Datasets
* jede Zuweisung an defineBU
* definiert eine BU
* die ersten drei Wörter des
* Wertes müssen
* buId, func, node
* der Rest sind Attribute für CD
* (entweder intern bekannte
* oder für OPARM?=...=...)
*
* unterstützte Funktionen
* cd = send mit connect direct
* wr = file nur schreiben
* nn = file nicht schreiben
* WGR Test
defineBU = "U0034 cd TEST" +
"dsn=T1DAT.DOCSYS.FTSCS.PVSTRACK(+1)" +
"mgmtClas=MCGDG dataClas=DCVFILE" +
"lrecl=32756 maxDelay=00:10:00"
* WGR Acceptance läuft
* vorläufig im RZ1
defineBU = "A0034 wr ACC" +
"dsn=P1DAT.DOCSYS.FTSCS.PVSTRACK(+1)" +
"mgmtClas=MCGDG dataClas=DCVFILE" +
"lrecl=32756 maxDelay=00:10:00"
}¢--- A540769.WK.REXX.O13(PVSRWGRD) cre= mod= ----------------------------------
/* rexx ***************************************************************
pvsrWgrD: Leistungsverrechnung Detailnachweis WGR
synopsis: pvsrWgrD -OPTION ...
This Rexx writes Leistungsverrechnung Detailnachweis WGR for one month
from the PVS-Job Table vpv013a1a
to 2 output file
The sql select statement to execute is read in from a file
and the variables ($XX odr ${XX}) are substitued by their value
Then the SQL is executed and all rows fetched and written
to the output file CSV
The fetched rows must consist of single string.
Files
The following files must be preallocated:
SQLIN: the sql to execute (after variable substitution)
JESIN: the log file from jesOutput (internal output)
CSV: the output csv file, containing the data for the month
HTMLIN: the input html file, (skeleton for variable expansion)
HTML: the output html file with a link to the csv file
MAILIN: the input mail file, (skeleton for variable expansion)
MAIL: the output mail file with a link to the html file
Options
Each Option has the form
-<char><value> (without intervening spaces)
the following Options are supported (case insensitive) and
stored in the variable name indicated after the option
-D DBSYS Db2Subsystem, must be DBTF (RZ1) or DBOF (RZ2)
-M MONTH format yyyymm, month to evaluate
-O DBOWNER Db2 Owner, must be OA1T (RZ1) or OA1P (RZ2)
-T trace
-? this help
Variable substitution in sqlIn, htmlIn and mailIn see copy rs
Variable Names
DBOWNER, DBSYS, MONTH as specified in options
HTML the DSN allocated to DD HTML (by listDsi)
MAIL the DSN allocated to DD MAIL (by listDsi)
MONTHDISP the MONTH in display format mm.yyyy
RZ the current sysNode
Foreground or Test Modus
if no options are specified and rexx runs in foreground
or option -F is specified then
for the unspecified options reasonable defaults are selected
the DD SQLIN, JESIN, CSV, HTML* and MAIL* are alloc'd and free'd
additional options in Testmode
-F FILEPRE Foreground mode.
FilePrefix default CESA.DETAIL.$RZ.$MONTH
gives the outputfiles $FILEPRE.CSV and $FILEPRE.HTML
-S SQLIN PDS for SQLIN,HTMLIN, MAILIN
Membername will be suffixed by S, H, M respectively
default 'WGR.RZ1.P0.AKT.PARMLIB(PVM7700)'
History
27.07.2005 W. Keller KPCO4 jesLog implemented
12.05.2005 W. Keller KPCO4 created
**********************************************************************/
/*---------------------------------------------------------------------
main: analyse arguments and do the work
---------------------------------------------------------------------*/
parse arg args
m.trace = 0
if 0 then
do; call rsTest ; call rsTestFC; exit; end;
call analyseArgs translate(args), '-D=DBSYS -MnMONTH -O=DBOWNER' ,
'-F*FILEPRE -S=SQLIN'
if rsGet(filePre) = '*' & ^(args = '' & sysvar('SYSENV') = 'FORE') then
call work 'd sqlIn', 'd jesIn', 'd htmlIn', 'd mailIn'
else
call foregroundWork
exit 0
/*---------------------------------------------------------------------
work:
(1) massage and check variables
(2) sql select and write detailnachweis to DD CSV
(3) write HTML page and MAIL message
---------------------------------------------------------------------*/
work: procedure expose m.
parse arg sqlIn, jesIn, htmlIn, mailIn
call checkNotEmpty 'DBSYS DBOWNER MONTH'
say 'db='rsGet(dbSys) 'own='rsGet(dbOwner) 'month='rsGet(month)
/* put fileNames */
lRc = listDsi('HTML FILE')
if lRc <> 0 then
call err 'rc' lRc 'listDsi(HTML FILE)'
call rsPut HTML, sysDsName
lRc = listDsi('CSV FILE')
if lRc <> 0 then
call err 'rc' lRc 'listDsi(CSV FILE)'
call rsPut CSV, sysDsName
call rsPut rz, sysvar('SYSNODE')
call rsPut monthDisp, right(rsGet(month), 2)'.'left(rsGet(month),4)
/* tailor sql and execute it */
call rs m, sqlIn, 's'
call sqlDetail m.out.m.1
/* analyse jesIn */
call jesLog jesIn
/* sort the data from wgrTree */
m.wgrSeq.0 = 0
call treeSeq wgrTree, wgrSeq
/* write data to dd csv */
call outBegin o, 'd CSV'
da = date('s')
call outLine o, 'Detailnachweis WGR;;'rsGet(rz)';',
|| 'erstellt;'time('n')';',
|| right(da, 2)'.'substr(da,5,2)'.'left(da,4)';'
call outLine o, 'Monat;Instradierung; PVS Seiten; PVS Dokumente;' ,
'JES Seiten; JES Stapel;'
do xx=1 to m.wgrSeq.0
yy = m.wgrSeq.xx
call outLine o, m.wgrMon.yy';'m.wgrInst.yy';' ,
|| m.wgrPvsPag.yy';'m.wgrPvsDoc.yy';' ,
|| m.wgrJesPag.yy';'m.wgrJesStap.yy';'
call trc 'xx' xx 'yy' yy 'mon' m.wgrMon.yy 'instr' m.wgrInst.yy,
'pvsPages' m.wgrPvsPag.yy 'pvsDoc' m.wgrPvsDoc.yy,
'jesPages' m.wgrJesPag.yy 'jesStap' m.wgrJesStap.yy
end
/* finish and cleanup */
call outEnd o
say outInfo(o)
call rs m, htmlIn, 'd HTML'
call rs m, mailIn, 'd MAIL'
return
endProcedure work;
/*---------------------------------------------------------------------
(1) set default arguments for foreground tests
(2) allocate datasets
(3) call work
(4) free datasets
---------------------------------------------------------------------*/
foregroundWork: procedure expose m.
rz = sysvar('SYSNODE')
if rsGet(dbsys) <> '' then nop
else if rz= 'RZ1' then call rsPut dbsys, 'DBTF'
else if rz= 'RZ2' then call rsPut dbsys, 'DBOF'
if rsGet(dbOwner) <> '' then nop
else if rz= 'RZ1' then call rsPut dbOwner, 'OA1T'
else if rz= 'RZ2' then call tsPut dbOwner, 'OA1P'
if rsGet(month) = '' then do
mon = left(date('s'), 6)
if substr(mon, 5) > 1 then
call rsPut month, mon - 1
else
call rsPut month, mon - 89
end
filePre = rsGet(filePre)
if filePre = '' | filePre = '*' then
filePre = "CESA."rz".D"rsGet(month)
sqlIn = rsGet(sqlIn)
if sqlIn = '' then
sqlIn = "wk.sql(PVM7700)"
msk = 'f' dsnApp(dsnSetMbr(sqlIn, dsnGetMbr(sqlIn)'?'))
allocNewV = 'new catalog dataclas(VB0256S0) mgmtclas(D035Y000)'
allocNewF = 'new catalog dataclas(FB0080S0) mgmtclas(D035Y000)'
if sysDsn(filePre".csv") = 'OK' then
call adrTso 'alloc dd(csv) old dsn('filePre'.csv)'
else
call adrTso 'alloc dd(csv) dsn('filePre'.csv)' allocNewV
if sysDsn(filePre".html") = 'OK' then
call adrTso 'alloc dd(html) old dsn('filePre'.html)'
else
call adrTso 'alloc dd(html) dsn('filePre'.html)' allocNewV
if sysDsn(filePre".mail") = 'OK' then
call adrTso 'alloc dd(mail) old dsn('filePre'.mail)'
else
call adrTso 'alloc dd(mail) dsn('filePre'.mail)' allocNewF
call work translate(msk, 'S', '?'),
, 'f' dsnApp(filePre '.jesLog'),
, translate(msk, 'H', '?'),
, translate(msk, 'M', '?')
call adrTso 'free dd(csv html mail)'
return
endProcedure foregroundWork
/*---------------------------------------------------------------------
(1) execute sql query
(2) fetch result into stem m.wgr*
---------------------------------------------------------------------*/
sqlDetail: procedure expose m.
parse arg sql
/* read sql source */
call trc 'sqlDetail sql' sql
/* execute sql query */
call adrSqlConnect rsGet(dbSys)
call adrSql "prepare s1 from :sql"
call adrSql "declare c1 cursor for s1"
call adrSql "open c1"
do ox = 1 by 1 /* fetch rows loop */
if adrSqlRc("fetch c1 into" ,
':m.wgrMon.ox,',
':m.wgrInst.ox,',
':m.wgrPvsPag.ox,',
':m.wgrPvsDoc.ox') <> 0 then do
if sqlCode = 100 then
leave
else
call err sqlMsg()
end
call trc 'sql fetch mon' m.wgrMon.ox 'instr' m.wgrInst.ox,
'pages' m.wgrPvsPag.ox 'sendungen' m.wgrPvsDoc.ox
call treeAdd wgrTree, m.wgrInst.ox, ox
m.wgrJesPag.ox = 0
m.wgrJesStap.ox = 0
end
m.wgr.0 = ox-1
if m.trace == 1 then do
call trc 'wgrTree in sqlDetail ********* begin'
m.wgrSeq.0 = 0
call treeSeq wgrTree, wgrSeq
do xx=1 to m.wgrSeq.0
yy = m.wgrSeq.xx
call trc 'xx' xx 'yy' yy ,
'mon' m.wgrMon.yy 'instr' m.wgrInst.yy,
'pvsPag' m.wgrPvsPag.yy 'pvsDoc' m.wgrPvsDoc.yy,
'jesPag' m.wgrJesPag.yy 'jesSta' m.wgrJesStap.yy
end
call trc 'wgrTree in sqlDetail ********* end'
end
call adrSql "close c1" /* cleanup */
call adrSqlDisconnect rsGet(dbSys)
say 'fetched' m.wgr.0 'rows'
return
endProcedure sqlDetail
/*---------------------------------------------------------------------
read jeslog from dd dd
analyse each log entry for current month and add it to m.wgr*
---------------------------------------------------------------------*/
jesLog: procedure expose m.
parse arg jesIn
mon = rsGet(month)
ox = m.wgr.0
say 'jesLog month' mon 'jesIn' jesIn
call inBegin j, jesIn
call scanBegin j, j, 'n'
cLi = 0
cMo = 0
/* analyse each log line */
do while scanNextLine(j)
cLi = cLi + 1
if ^ scanNum(j) then
call scanErrBack j,'jesLog does not start with numeric date'
dat = m.j.tok
if left(dat, 6) ^== mon then
iterate
if ^scanChar(j, 0) | ^scanUntil(j, ' ') then
call scanErrBack j, 'jesLog does have time'
WGR2CSLST = ''
if ^scanKeyValue(j) | m.j.key ^== 'WGR2CSLST' then
iterate
vers = m.j.val
if vers ^== '01' & vers ^== '??' then
call scanErrBack j, 'unsupported version wgr2csLst='vers
cMo = cMo + 1
inst = ''
pag = 0
cop = 1
/* extract values from keys */
do while scanKeyValue(j)
if m.j.key == 'VERRECHNUNG' then
inst = m.j.val
else if m.j.key == 'PAGES' then
pag = m.j.val
else if m.j.key == 'COPIES' then
cop = m.j.val
end
/* compute pages and stapel */
paCo = pag * cop
stap = (paCo + 799) % 800
call trc 'inst' inst 'pag' pag 'cop' cop '==>' paCo stap
if paCo = 0 then
nop /* ignore empty file */
else if symbol('m.wgrTree.inst.v') == 'VAR' then do
/* update existing tree node */
qq = m.wgrTree.inst.v
if m.wgrMon.qq ^== mon then
call err 'month mismatch tree='m.wgrMon.qq 'cur='mon
if m.wgrInst.qq ^== inst then
call err 'inst mismatch'
m.wgrJesPag.qq = m.wgrJesPag.qq + paCo
m.wgrJesStap.qq = m.wgrJesStap.qq + stap
end
else do
/* insert new tree node */
ox = ox + 1
call treeAdd wgrTree, inst, ox
m.wgrMon.ox = mon
m.wgrInst.ox = inst
m.wgrPvsPag.ox = 0
m.wgrPvsDoc.ox = 0
m.wgrJesPag.ox = paCo
m.wgrJesStap.ox = stap
end
end /* analyse each log line */
say 'jesLog selected' cMo 'from' cLi 'lines, added to',
ox 'nodes (' || (ox-m.wgr.0) 'new ones)'
m.wgr.0 = ox
call scanEnd j
call inEnd j
return
endProcedure jesLog
/*---------------------------------------------------------------------
in the tree m.m add or update a node (m.m.key.v = val)
and update the children path (character by character sorted)
---------------------------------------------------------------------*/
treeAdd: procedure expose m.
parse arg m, key, val
m.m.key.v = val
do while key ^== ''
ch = right(key, 1)
key = left(key, length(key) - 1)
if symbol('m.m.key.c') ^== 'VAR' then
m.m.key.c = ''
if pos(ch, m.m.key.c) > 0 then
return
do x=1 to length(m.m.key.c) while ch >> substr(m.m.key.c, x, 1)
end
m.m.key.c = left(m.m.key.c, x-1) || ch || substr(m.m.key.c, x)
end
return
end treeAdd
/*---------------------------------------------------------------------
add he subtree t at key key ordered
to the stem o
---------------------------------------------------------------------*/
treeSeq: procedure expose m.
parse arg t, o, key
if symbol('m.t.key.v') == 'VAR' then do
x = m.o.0 + 1
m.o.0 = x
m.o.x = m.t.key.v
end
if symbol('m.t.key.c') == 'VAR' then do
do x=1 to length(m.t.key.c)
call treeSeq t, o, key || substr(m.t.key.c, x, 1)
end
end
return
endProcedure treeSeq
/*----------------------------------------------------------------------
(1) fill the $ variables with default values
(2) fill the arguments specified in args in the $ variables
the valid arguments and variables are specified in infos,
each word in infos describes one argument as follows:
* substr(1,2) must match substr(1,2) of the word in args
* substr(3,1) type:
'=' initial value ''
'*' initial value '*'
'n' initial value '', value must be a number
* substr(4) variable name
----------------------------------------------------------------------*/
analyseArgs: procedure expose m.
parse arg args, infos
do i=1 to words(infos)
w = word(infos, i)
nam = substr(w, 4)
if substr(w, 3, 1) = '*' then
call rsPut nam, '*'
else
call rsPut nam, ''
end
do i=1 to words(args)
w = word(args, i)
if w = '?' | w = '-?' then do
call help
exit
end
else if w = '-T' then do
m.trace = 1
end
else do
cx = pos(left(w, 2), infos)
if cx < 1 then
call errHelp 'bad Option' op 'in' subWord(args, i)
ty = substr(infos, cx+2, 1)
nam = word(substr(infos, cx+3), 1)
val = substr(w, 3)
if ty = 'n' then
if verify(val, '0123456789') > 0 THEN
call err nam ' not numeric:' w
call rsPut nam, val
end
end
return
endProcedure analyseArgs
/*----------------------------------------------------------------------
for each word w in names assert $w <> ''
issue an error if any the variables is empty
----------------------------------------------------------------------*/
checkNotEmpty: procedure expose m.
parse arg names
do i=1 to words(names)
n = word(names, i)
if rsGet(n) = '' then
call err 'variable' n 'is empty'
end
return
endProcede checkNotEmpty
err:
parse arg ggMsg
call errA ggMsg
exit 12
/* copy rs begin ****************************************************/
/**********************************************************************
RS = Rexx Shell: produce output from input (rexx and Data)
Synopsis rs m, iTyp iOpt, oTyp oOpt
rsFC m, iTyp iOpt, oTyp oOpt
m: the this address (m.m. ...)
iTyp iOpt: input option for scanBegin (see there)
oTyp oOpt: output option 's'=say 'd'= dd oOpt
each input line has one of five types:
'*' comment is ignored
';' Rexx line (a trailing comma works as continuation marker)
'|' a RexxOuput line
'>' an output line
The two functions support two different concrete Syntaxes:
rsFC: first nonblank character marks line type *;|>
rs: stateSwitch lines allow nested blocks of
Rexx and RexxOutput lines
${; and $}; surround Rexx lines
${> and $}> surround RexxOutput lines
$> preceedes a single RexxOutput line
$* preceedes a comment line
the rest are output lines
each rexx and rexxOutput line is compiled (into rexx)
if an output line is encountered (or at EOF),
the previously compiled rexx is interpreted
then, the output line is written after variable substitution
the following substitutions are supported
$name, ${name} ${quotedString}
no space between $ and name or $ and { is allowed
spaces are allowed after the { and before the }
the names are case sensitive
these substituions are expanded in Rexx, RexxOutput and Output lines
and may be assigned in rexxLines
within a called rexx function rsGet and rsPut access these variables
warning: in rexxLines neither use semicolons
nor use $ not even in strings, except for ${'$'} etc.,
the results are unpredictable |
example: write a table of the squares and cubes from 1 to 10:
syntax for rsFC:
* title line
| n n**2 n**3 | titel squares and cubes
; do i=1 to 10
* fill one line into a $- variable
; $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)
* output the line
| | $txt |
; end
| n n**2 n**3 | trailer squares and cubes
syntax for rs:
$* title line
| n n**2 n**3 | titel squares and cubes
${; --- start of rexx lines
do i=1 to 10
$* fill one line into $variable
$txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)
$* comment
$>| $txt |
$* comment
; end '
$}; --- end of rexx lines
| n n**2 n**3 | trailer squares and cubes
**********************************************************************/
rsTest: procedure
m.trace = 0
m.s.1 = 'first line m.s.1'
m.s.2 = ' ${; erster rexx block'
m.s.3 = ' $eins = "einsValue1"'
m.s.4 = ' if $eins = ${eins} then'
m.s.5 = ' say wie geht es ,'
m.s.6 = ' dir auch so ?'
m.s.7 = ' $}; ende erster rexx block'
m.s.8 = ' aha soso $eins und ${ ''$'' }eins = ${ eins } '
m.s.9 = ' ${; zweiter rexx block'
m.s.10= ' $x = a'
m.s.11= ' do i=1 to 3'
m.s.12= ' $x = , '
m.s.13= ' $x || "-"i"-" , '
m.s.14= ' || ${ x } '
m.s.15= ' ${> embedded output block begin'
m.s.16= ' jetzt ist x $x'
m.s.17= ' $}> embedded output block end '
m.s.18= ' end'
m.s.19= ' '
m.s.20= ' ${ q } = quote($x)'
m.s.21= ' $}; zweiter rexx block'
m.s.22 = 'und jetzt ${"$x="} $x q=${ q } '
m.s.0 = 22
call rs c, 'b' s, '*'
say 'end rsTest eins'
m.t.1 = '$* title line '
m.t.2 = '| n n**2 n**3 | titel squares and cubes '
m.t.3 = ' ${;'
m.t.4 = ' do i=1 to 10 '
m.t.5 = '$* fill one line into $variable '
m.t.6 = ' $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)'
m.t.7 = '$* comment '
m.t.8 = ' $>| $txt |'
m.t.9 = ' $* comment '
m.t.10= '; end '
m.t.11= '$};'
m.t.12= '| n n**2 n**3 | trailer squares and cubes '
m.t.0 = 12
call rs c, 'b' t, '*'
say 'end rsTest cube'
return
endProcedure rsTest
rsTestFC: procedure
m.trace = 0
call rsPut 'eins', 'valueEins'
m.s.1 = '; $eins = "einsValue1"'
m.s.2 = '; if $eins = ${eins} then'
m.s.3 = '; say wie geht es '
m.s.4 = '> aha soso $eins und ${ ''$'' }eins = ${ eins } '
m.s.5 = '; $x = a'
m.s.6 = '; do i=1 to 3'
m.s.7 = '; $x = , '
m.s.8 = '; $x || "-"i"-" , '
m.s.9 = '; || ${ x } '
m.s.10= ' | jetzt ist x $x'
m.s.11= '; end'
m.s.12= ' '
m.s.13= '; ${ q } = quote($x)'
m.s.14 = ' |und jetzt ${"$x="} $x q=${ q } '
m.s.0 = 14
call rsFC c, 'b' s, '*'
say 'end rsTest eins'
m.t.1 = '* title line '
m.t.2 = '| | n n**2 n**3 | titel squares and cubes '
m.t.3 = '; do i=1 to 10 '
m.t.4 = '* fill one line into $variable '
m.t.5 = '; $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)'
m.t.6 = '* output the variable '
m.t.7 = '| | $txt |'
m.t.8 = '; end '
m.t.9 = '| | n n**2 n**3 | trailer squares and cubes '
m.t.0 = 9
call rsFC c, 'b' t, '*'
say 'end rsTest cube'
return
endProcedure rsTestFC
/*----------------------------------------------------------------------
get the value of a $-variable, fail if undefined
----------------------------------------------------------------------*/
rsGet: procedure expose m.
parse arg name, s
if symbol('m.var.name') = 'VAR' then
return m.var.name
else if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure rsGet
/*----------------------------------------------------------------------
put (store) the value of a $-variable
----------------------------------------------------------------------*/
rsPut: procedure expose m.
parse arg name, value
m.var.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure rsPut
/*----------------------------------------------------------------------
read input and write output with nested syntax
todo: convert to a pipe
input: inTO as specified by inBegin
output:outTO as specified by outBegin
----------------------------------------------------------------------*/
rs: procedure expose m.
parse arg m, inTO, outTO
s = m
call outBegin s, outTO
call inBegin s, inTO
call scanBegin s, s, 'n'
call rsLine m, s, 'b'
sta = '0'
states = ''
do while scanNextLine(s)
if scanChar(s, 1) & m.s.tok == '$' then do
swi = scanRight(s, 2)
if swi == '{;' | swi == '{>' then do
states = sta || states
sta = right(swi, 1)
iterate
end
if swi == '};' | swi == '}>' then do
if sta ^== right(swi, 1) then
call scanErrBack s, 'blockClose $'swi ,
'but in ${'sta 'block, history' sta||states
sta = left(states, 1)
states = substr(states, 2)
iterate
end
if left(swi, 1) == '>' then do
call scanChar s, 1
call rsLine m, s, translate(sta, '>||', '0;>')
iterate
end
if left(swi, 1) == '*' then
iterate
end
call scanRestartLine m
call rsLine m, s, translate(sta, '>;|', '0;>')
end
if states ^== '' then
call scanErr s, 'input ends in block, history' sta||states
call inEnd s
call outEnd s
say outInfo(s)
return
endProcedure rs
/*----------------------------------------------------------------------
read input and write output with FC syntax, arguments see rs
----------------------------------------------------------------------*/
rsFC: procedure expose m.
parse arg m, inTO, outTO
s = m
call outBegin s, outTO
call inBegin s, inTO
call scanBegin s, s, 'n'
call rsLine m, s, 'b'
do while scanNextLine(s)
if ^scanChar(s, 1) | m.s.tok == '*' then
nop /* empty or comment line */
else if pos(m.s.tok, ';|>') > 0 then
call rsLine m, s, m.s.tok
else
call scanErrBack s, 'bad line, should start with one of ;|>'
end
call rsLine m, s, 'e'
call inEnd s
call outEnd s
say outInfo(s)
return
endProcedure rsFC
/*----------------------------------------------------------------------
compile/interpret/execute one line
arguments: m = this
s = scanner
typ = ';', '|', '>' for lineType or b(egin), e(nd)
----------------------------------------------------------------------*/
rsLine: procedure expose m.
parse arg m, s, typ
if typ == ';' then do
m.rs.m.rx = m.rs.m.rx ,
strip(rsRexxCompile(m, s, m.rs.m.rx == ''), t)
if right(m.rs.m.rx, 1) == ',' then do
typ = ','
m.rs.m.rx = ,
strip(left(m.rs.m.rx, length(m.rs.m.rx) - 1), 't')
end
else do
yy = m.rs.m.rx.0 + 1
m.rs.m.rx.0 = yy
m.rs.m.rx.yy = strip(m.rs.m.rx, 't')
m.rs.m.rx = ''
end
m.rs.m.state = typ
end
else if typ == 'b' then do
m.rs.m.rx.0 = 0
m.rs.m.state = ';'
m.rs.m.rx = ''
end
else if m.rs.m.state ^== ';' then
call scanErr s, 'continuation expected'
else if typ == '|' then do
yy = m.rs.m.rx.0 + 1
m.rs.m.rx.0 = yy
m.rs.m.rx.yy = rsOutCompile(m, s)
end
else if typ == '>' then do
if m.rs.m.rx.0 > 0 then do
call rsRexxRun rs'.'m'.'rx
m.rs.m.rx.0 = 0
end
call rsOutInter m, s
end
else if typ == 'e' then do
if m.rs.m.rx.0 > 0 then do
call rsRexxRun rs'.'m'.'rx
m.rs.m.rx.0 = 0
end
end
else
call scanErr s, 'rsLine bad typ' typ
return
endProcedure rsLine
/*----------------------------------------------------------------------
compile one rexxLine ( ; line):
scan until endOfLine, substitue $ clauses
and return resulting rexxClause
lineBegin=0 says, we are on a continuation line
----------------------------------------------------------------------*/
rsRexxCompile: procedure expose m.
parse arg m, rs, lineBegin
rx = ''
do while rsScanDollar(rs)
if m.rs.type == 's' then
rx = rx || m.rs.before || quote(m.rs.val)
else if m.rs.type ^== 'n' then
call err 'rsOutInter bad m.rs.type' m.rs.type
else if lineBegin & rx = '' & m.rs.before = '' then do
rx = rx || m.rs.before || 'call rsPut' quote(m.rs.name) ','
if ^ scanChar(rs, 1) | m.rs.tok ^== '=' then
call scanErr rs, 'assignment operator = expected'
end
else
rx = rx || m.rs.before || 'rsGet('quote(m.rs.name)')'
end
call trc 'rsRexxComp:' rx || m.rs.before
return rx || m.rs.before
endProcedure rsRexxCompile
/*----------------------------------------------------------------------
compile one rexxOutputLine ( | line):
scan until endOfLine, substitue $ variables
and return resulting rexx prefixed by 'call rsOut'
----------------------------------------------------------------------*/
rsOutCompile: procedure expose m.
parse arg m, rs
rx = ''
do while rsScanDollar(rs)
if m.rs.type == 's' then
rx = rx '||' quote(m.rs.before || m.rs.val)
else if m.rs.type ^== 'n' then
call err 'rsOutInter bad m.rs.type' m.rs.type
else
rx = rx '||' quote(m.rs.before) ,
'|| rsGet('quote(m.rs.name)')'
end
if rx == '' then
rx = 'call outLine' quote(rs) ',' quote(m.rs.before)
else
rx = 'call outLine' quote(rs) ',' ,
substr(rx, 5) '||' quote(m.rs.before)
call trc 'rsOutCompile:' rx
return rx
endProcedure rsOutCompile
/*----------------------------------------------------------------------
interpret a compiled rexx
----------------------------------------------------------------------*/
rsRexxRun: procedure expose m.
parse arg ggM
ggSrc = ''
do x=1 to m.ggM.0
ggSrc = ggSrc m.ggM.x ';'
end
call trc 'rsRexxRun interpreting' ggSrc
interpret ggSrc
call trc 'interpreted'
return
endProcedure rsRexxComp
rsOutInter: procedure expose m.
/*----------------------------------------------------------------------
interpret one outputLine ( > line):
scan until endOfLine, substitue $ variables by its current vale
and output resulting string
----------------------------------------------------------------------*/
parse arg m, rs
msg = ''
do while rsScanDollar(rs)
if m.rs.type == 'n' then
msg = msg || m.rs.before || rsGet(m.rs.name)
else if m.rs.type == 's' then
msg = msg || m.rs.before || m.rs.val
else
call err 'rsOutInter bad m.rs.type' m.rs.type
end
call outLine rs, msg || m.rs.before
return
endProcedure rsOutInter
/*----------------------------------------------------------------------
scan a Dollar-clause
scan until next $, put text before into m.rs.before
analyse $-clause set the variables m.rs.type as follows
'n' name of variable is in m.rs.name
's' value of string is in m.rs.val
position scanner at first character after clause
return 1 if clause scanned, 0 if no $ found (until endOfLine)
faile if invalid or incomplete clause
----------------------------------------------------------------------*/
rsScanDollar: procedure expose m.
parse arg rs
call scanUntil rs, '$'
m.rs.before = m.rs.tok
if ^ scanChar(rs, 1) then
return 0
if m.rs.tok ^== '$' then
call scanErr rs 'internal: should be $'
c1 = scanRight(rs, 1)
if c1 = ' ' then
call scanErrBack rs, 'illegal $ clause'
else if c1 == '{' then do
call scanChar rs, 1
if scanName(rs) then do
m.rs.name = m.rs.tok
m.rs.type = 'n'
end
else if scanString(rs, '''') then
m.rs.type = 's'
else if scanString(rs, '"') then
m.rs.type = 's'
else
call scanErr rs, 'bad ${...} clause'
if ^scanChar(rs, 1) | m.rs.tok ^== '}' then
call scanErr rs, 'ending } missing'
end
else if scanName(rs) then do
m.rs.name = m.rs.tok
m.rs.type = 'n'
end
else
call scanErr rs, 'bad $ clause'
return 1
endProcedure rsScanDollar
/* copy rs end ****************************************************/
/* copy scan begin ****************************************************/
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034,Und hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = {*('ers' || 'tn' || '''s')"
m.q.4 = " drei;+H{>a'}123{>sdf'R}aha} '' end "
m.q.0 = 4
call scanTestDo q, 0
call scanTestDo q, 1
return
endProcedure scanTest
scanTestDo: procedure expose m.
parse arg q, scCo
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
m.s.scanComment = scCo
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTestDo
scanBegin: procedure expose m.
parse arg m, s, pOpt, sc1, sc2
m.m.skipComment = pos('c', pOpt) > 0
m.m.skipNext = pos('n', pOpt) < 1
m.m.scanReader = s
m.m.cx = 999
m.m.curLi = m'.'cx
m.m.eof = 0
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
return
endProcedure scanEnd
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanSkip: procedure expose m.
parse arg m, nxt, cmm
m.m.tok = ''
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then do
m.m.bx = vx
m.m.cx = vx
if ^ cmm then
return 1
else if ^ scanComment(m) then
return 1
m.m.tok = ''
end
else if ^ nxt then
return 0
else if ^ scanNextLine(m) then do
m.m.eof = 1
return 0
end
end
endProcedure scanSkip
scanNextLine: procedure expose m.
parse arg m
s = m.m.scanReader
if inLine(s) then do
m.m.curLi = m.in.s.line
m.m.cx = 1
return 1
end
else do
m.m.eof = 1
return 0
end
endProcedure scanNextLine
scanRestartLine: procedure expose m.
parse arg m, p
if p == '' then
m.m.cx = 1
else
m.m.cx = p
m.m.bx = m.m.cx
return
endProcedure sanRestartLine
scanChar: procedure expose m.
parse arg m, len
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
l = m.m.curLi
if length(m.l) >= m.m.bx + len then
m.m.tok = substr(m.l, m.m.bx, len)
else
m.m.tok = substr(m.l, m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
m.m.val = ''
if qu = '' then
qu = "'"
l = m.m.curLi
if substr(m.l, m.m.cx, 1) ^== qu then
return 0
qx = m.m.cx + 1
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
l = m.m.curLi
if alpha == '' then do
if pos(substr(m.l, m.m.bx, 1), '012345678') > 0 then
return 0
vx = verify(m.l,
, '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ' ,
, 'n', m.m.bx)
end
else do
vx = verify(m.l, alpha, 'n', m.m.bx)
end
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else if vx <= m.m.bx then
return 0
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
if ^ scanName(m, '0123456789') then
return 0
else if datatype(scanRight(m, 1), 'A') then
call scanErrBack m, 'illegal number end'
return 1
endProcedure scanNum
scanKeyValue: procedure expose m.
parse arg m
if ^scanName(m) then
return 0
m.m.key = translate(m.m.tok)
if ^scanChar(m, 1) | m.m.tok <> '=' then
call scanErr m, 'assignment operator (=) expected'
if scanName(m) then
m.m.val = translate(m.m.tok)
else if scanNum(m) then do
m.m.val = m.m.tok
end
else if scanString(m) then
nop
else
call scanErr m, "value (name or string '...') expected"
return 1
endProcedure scanKeyValue
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx':' substr(m.l, m.m.cx)
say inLineInfo(m.m.scanReader)
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* copy scan end ****************************************************/
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
inAll: procedure expose m.
parse arg m, inTO, out
call inBegin m, inTO
if out == '' then do
call inBlock m, '*'
if inBlock(m) | m ^== m.in.m.block then
call err 'not eof after inBlock *'
end
else do
rx = 0
do while inBlock(m)
bl = m.in.m.block
do ix=1 to m.bl.0
rx = rx + 1
m.out.rx = m.bl.ix
end
end
m.out.0 = rx
end
call inEnd m
return
endSubroutine inAll
inBegin: procedure expose m.
parse arg m, pTyp pOpt
m.in.m.type = pTyp
m.in.m.rNo = 0
m.in.m.bNo = 0
m.in.m.0 = 0
m.in.m.eof = 0
m.in.m.block = in'.'m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = in'.'m'.'string
m.in.m.type = 'b'
end
else if pTyp == 'b' then do
m.in.m.block = pOpt
end
else if pTyp == 'd' then do
m.in.m.dd = pOpt
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.in.m.type = 'd'
m.in.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.in.m.dd = 'in'm
else
m.in.m.dd = m
inf = 'dd' m.in.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.in.m.dd') shr dsn('pOpt')'
end
else
call err 'inBegin bad type' pTyp
m.in.m.info = pTyp'-'m.in.m.type inf
return
endProcedure inBegin
inLine: procedure expose m.
parse arg m
r = m.in.m.rNo + 1
if r > m.in.m.0 then do
if ^ inBlock(m) then
return 0
r = 1
end
m.in.m.line = m.in.m.block'.'r
m.in.m.rNo = r
return 1
endProcedure inLine
inBlock: procedure expose m.
parse arg m, cnt
if m.in.m.type == 'd' then do
m.in.m.bNo = m.in.m.bNo + m.in.m.0
m.in.m.eof = ^ readNext(m.in.m.dd, 'm.in.'m'.', cnt)
return ^ m.in.m.eof
end
else if m.in.m.type == 'b' then do
if m.in.m.bNo > 0 then do
m.eof = 1
return 0
end
m.in.m.bNo = 1
b = m.in.m.block
m.in.m.0 = m.b.0
return 1
end
else
call err 'inBlock bad m.in.'m'.type' m.in.m.type
endProcedure inBlock
inLineInfo: procedure expose m.
parse arg m, lx
if lx = '' then
lx = m.in.m.rNo
cl = m.in.m.block'.'lx
xx = m.in.m.rNo
if m.in.m.type == 'd' then
xx = xx + m.in.m.bNo
return 'record' xx '(m.'cl 'type' strip(m.in.m.info)'):' m.cl
endProcedure inLineInfo
inEnd: procedure expose m.
parse arg m
if m.in.m.type == 'd' then do
call readDDEnd m.in.m.dd
if left(m.in.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
outBegin: procedure expose m.
parse arg m, pTyp pOpt
m.out.m.type = pTyp
m.out.m.max = 0
m.out.m.bNo = 0
m.out.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.out.m.max = 999999999
end
else if pTyp == 'd' then do
m.out.m.dd = pOpt
m.out.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.out.m.type = 'd'
m.out.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.out.m.dd = 'out'm
else
m.out.m.dd = m
m.out.m.max = 100
inf = 'dd' m.out.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.out.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.out.m.0 = 1
m.out.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.out.m.info = pTyp'-'m.out.m.type inf
return
endProcedure outBegin
outLine: procedure expose m.
parse arg m, data
if m.out.m.0 < m.out.m.max then do
r = m.out.m.0 + 1
m.out.m.0 = r
m.out.m.r = strip(data, 't')
end
else if m.out.m.type = '*' then do
m.out.m.bNo = m.out.m.bNo + 1
say 'out:' data
end
else if m.out.m.type = 's' then do
m.out.m.bNo = m.out.m.bNo + 1
m.out.m.1 = m.out.m.1 strip(data)
end
else do
call outBlock s
m.out.m.0 = 1
m.out.m.1 = data
end
return
endProcedure outLine
outBlock: procedure expose m.
parse arg m, pp
if pp == '' then
oo = out'.'m
else
oo = pp
if m.out.m.type = '*' then do
do r = 1 to m.oo.0
say 'out:' m.oo.r
end
end
else if m.out.m.type = 's' then do
do r = 1 to m.oo.0
m.out.m.1 = m.out.m.1 strip(m.oo.r)
end
end
else if m.out.m.type = 'b' then do
if pp ^== '' then do
q = m.out.m.0
do r = 1 to m.oo.0
q = q + 1
m.out.m.q = m.oo.r
end
m.out.m.0 = q
end
end
else if m.out.m.type == 'd' then do
m.out.m.bNo = m.out.m.bNo + m.oo.0
call writeNext m.out.m.dd, 'M.'oo'.'
if pp == '' then
m.out.m.0 = 0
end
return
return 1
endProcedure outBlock
outEnd: procedure expose m.
parse arg m
if m.out.m.type == 'd' then do
call outBlock m
call writeDDEnd m.out.m.dd
if left(m.out.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure outEnd
outInfo: procedure expose m.
parse arg m
if m.out.m.type = 'b' then
m.out.m.bNo = m.out.m.0
return m.out.m.bNo 'records written to' m 'type' m.out.m.info
endProcedure outInfo
/* copy mem end *****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDDBegin: procedure
return /* end readDDBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg ggTsoCmd
address tso ggTsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg ggTsoCmd
address tso ggTsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
adrIspRc:
parse arg ggIspCmd
address ispexec ggIspCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ggIspCmd
address ispexec ggIspCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ggIspCmd
return /* end adrIsp */
adrEdit:
parse arg ggEditCmd, ret
address isrEdit ggEditCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' ggEditCmd
return /* end adrEdit */
adrEditRc:
parse arg ggEditCmd
address isrEdit ggEditCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(PVSRWGRJ) cre= mod= ----------------------------------
/* REXX ****************************************************************
PVSRWGRJ JES-Output WGR project PRIMO
synopsis: PVSRWGRJ ¢-?! ¢-T! ¢env oldDsn!
-? this help
-T with trace
env Environment (TEST or PROD used in Skeleton Expansion)
oldDsn DSN of original Dataset
Function: analyse input AFP file (DD AFP),
write a variMember, a Mail text and a log Message
from skeletons and
write an IMM Record (if variable COPYGROUP is not empty)
Test: In foreground if oldDsn is empty,
the necessary files are allocated
Files (must be preallocated)
DD AFP AFP Input file (if analyseAFP is called from skeleton)
DD VARIIN input Skeleton for VariMember
DD VARI output VariMember
DD MAILIN input Skeleton for Mail
DD MAIL output Mail
DD LOGIN input Skeleton for Log
DD LOG output Log
DD IMM output file for IMM-AFP-Record
The skeletons are processed by shellDataDD, see description there.
The first Skeleton VARIIN should contain a statement
analyseAFP('afp', ....)
to call the following procedure
procedure analyseAFP(afpDD, firstKey, firstVal, keys)
the datasetname allocated to dd afpDD is put to variable DSNNEW
the variable EMPTY is set to whether afpDD is empty
the first record of apfDD must be an AFP nop record with
key=value pairs in the data part
the first pair must be firstKey=firstVal
the following keys must be contained in keys (uppercased) and
the values are put to the corresponding variable
at the end all variable names in keys must be defined
the ddAfp file is read and pages, records and characters are
counted and put to the variables of these names (uppercased)
history
03.05.05 W.Keller, KPCO 4, created
***********************************************************************/
parse upper arg args
say 'pvsrWgrJ begin' args
env = ''
oldDsn = ''
m.opt.trace = 0
do i=1 to words(args)
w = word(args, i)
if w = '?' | w= '-?' then
call help
else if left(w, 1) <> '-' then do
if env == '' then
env = w
else if oldDsn == '' then
oldDsn = w
else
call err 'oldDSN' w 'specified twice in args' args
end
else if w = '-T' then
m.opt.trace = 1
else
call err 'bad option' w 'in args' args
end
if oldDsn ^== '' then
call createList env, oldDsn
else if sysvar(sysenv) = 'FORE' then
call forgroundWork env, 'WGR.ORIG.DSN.D234.T789'
else
call err 'oldDsn not specified in args' args
say 'pvsrWgrJ end ' args
exit
forgroundWork: procedure expose m.
parse arg env, oldDsn
if env = '' then
env = 'TEST'
say 'forgroundWork test begin' env oldDsn
afpDsn = 'TEST.JESOUT.T9empty'
variIn = "'WGR.RZ1.T0.AKT.PARMLIB(PVS140VA)'"
mailIn = "'WGR.RZ1.T0.AKT.PARMLIB(PVS140MA)'"
logIn = "'WGR.RZ1.T0.AKT.PARMLIB(PVS140LG)'"
call adrTso 'alloc dd(afp) shr dsn('afpDsn')'
if env = 1 then do
call analyseAfp afp, 'WGR2CSLST', 01
end
else do
call adrTso 'alloc dd(variIn) shr dsn('variIn')'
call adrTso 'alloc dd(mailIn) shr dsn('mailIn')'
call adrTso 'alloc dd(logIn) shr dsn('logIn')'
call adrTso 'alloc dd(vari) dsn(*)'
call adrTso 'alloc dd(mail) dsn(*)'
call adrTso 'alloc dd(log) dsn(wk.out(log))'
call adrTso 'alloc dd(imm) dsn(*)'
call createList env, oldDsn
call adrTso 'free dd(vari variIn mail mailIn log logIn imm)'
end
call adrTso 'free dd(afp)'
say 'forgroundWork test end'
return
endProcedure forgroundWork
createList: procedure expose m.
parse arg env, oldDsn
say 'createList env' env 'oldDsn' oldDsn
call shellPut 'ENV', env
call shellPut dsn, oldDsn
/* write vari Member */
call shellDataDD 'variIn', 'vari'
/* write mail */
call shellDataDD 'mailIn', 'mail'
say 'write imm begin' /* write imm */
call writeDDBegin 'imm'
xx = 0
if shellGet(copyGroup) <> '' then do
xx = xx + 1
x.xx = makeAfp('D3ABCC'x, /* imm identifier for afp */
, left(shellGet(copyGroup), 8))
call trc 'imm' length(x.xx) "'"c2x(x.xx)"'x" x.xx
end
/* x.xx = makeAfp('D3AF5F'x, ips = invoke page segment
, left(shellGet(pageSegment), 14, '00'x)) */
x.0 = xx
call writeNext 'imm', x.
call writeDDEnd 'imm'
call trc '*** imm end' x.0
/* write log */
call shellDataDD 'logIn', 'log'
return
endProcedure createList
analyseAfp: procedure expose m.
parse arg afpDD, firstKey, firstVal, keys
/* afp constants */
afp = '5A'x
bpg = 'D3A8AF'x
epg = 'D3A9AF'x
nop = 'D3EEEE'x
n.bpg = 'bpg BeginPaGe'
n.epg = 'epg EndPage'
n.nop = 'nop'
c='D3ABCC'x; n.c = 'imm InvokeMediumMap'
c='D3AF5F'x; n.c = 'ips IncludePageSegment'
c='D3A6AF'x; n.c = 'pgd PaGeDescriptor'
c='D3A69B'x; n.c = 'PTD-1 Presentation Text Descriptor Format-1'
c='D3A79B'x; n.c = 'ctc ComposeTextControl'
c='D3A8C9'x; n.c = 'bag BeginActiveEnvironment'
c='D3A89B'x; n.c = 'bpt BeginPresentationText object'
c='D3EE9B'x; n.c = 'ptx PresentationTextData'
/* get file name */
if 0 <> listDsi(afpDD 'FILE') then
call err 'bad rc in listDsi('afpDD 'FILE)'
call shellPut dsnNew, sysDsName
call readDDBegin afpDD
empty = ^ (readNext(afpDD, r.) & r.0 >= 1)
call shellPut 'EMPTY', empty
if ^ empty then do /* analyse first record */
if ^ (left(r.1, 1) == afp & substr(r.1, 4, 3) == nop) then
call err "record 1 does not start with x'"c2x(afp)"????",
|| c2x(nop)"'"
len = c2d(substr(r.1, 2, 2))
if len + 1 <> length(r.1) then
call err 'record 1 lengthField' len ,
'but record length' length(r.1)
data = substr(r.1, 10)
say 'nop data' length(data)':' data
call shellKeyValue data, firstKey, firstVal, keys
end
/* init counters */
ax = 0
recs = 0
chars = 0
cntLi = 0
cntAFP = 0
do forever /* count all lines */
recs = recs + r.0
do i = 1 to r.0
chars = chars + length(r.i)
id = left(r.i, 1)
if id == '!' then
id = substr(r.i, 4, 3)
if symbol('a.id') = 'VAR' then do
a.id = a.id + 1
end
else do
ax = ax + 1
ax.ax = id
a.id = 1
end
end
if ^ readNext(afpDD, r.) then
leave
end
call readDDEnd afpDD
do ix = 1 to ax /* cumulate counters */
c = ax.ix
IF length(c) = 1 then
cntLi = cntLi + a.c
else
cntAFP = cntAFP + a.c
call trc 'a.'c c2x(c) a.c n.c
end
/* zero undefined counters*/
if symbol('a.1') <> 'VAR' then a.1 = 0
if symbol('a.bpg') <> 'VAR' then a.bpg = 0
if symbol('a.epg') <> 'VAR' then a.epg = 0
if symbol('a.nop') <> 'VAR' then a.nop = 0
say 'afpDD' afpDD ',recs ' recs ', chars' chars
say ' linemode' cntLi 'Zeilen davon' a.1 'channel1'
if a.bpg <> a.epg then
say 'count bpg='a.bpg ' mismatches epg='a.epg
say ' afp' cntAfp 'Records, davon' a.bpg 'BPG und' a.nop 'nop'
call shellPut records, recs
call shellPut characters, chars
call shellPut pages, a.bpg + a.1
return
endProcedure analyseAFP
makeImm: procedure expose m.
parse arg imm .
return '5A'x || d2c(16, 2) || 'D3ABCC000000'x || left(imm, 8)
makeAfp: procedure expose m.
parse arg ident, data
return '5A'x || d2c(length(data)+8, 2) || left(ident, 6, '00'x) || data
return '5A'x || d2c(16, 2) || left(ident,'D3ABCC000000'x || left(imm, 8)
trc: procedure expose m.
parse arg msg
if m.opt.trace >= 1 then
say 'trc:' msg
return
endProcedure trc
err:
parse arg ggMsg;
call errA ggMsg;
exit 12;
/**********************************************************************
Shell: scan and do variable expansions etc.
shellBegin(m,..): set scan Source to a string, a stem or a dd
block = '{>' data '} ¨ '{;' stmts '}'
comment = '{*' (¢^{}! ¨ block)* '}'
data = (¢^{}$! ¨'$$' ¨ '$'name ¨ '{' name '}' ¨ block ¨ comment)*
stmts = stmt? ( ';' stmt? )*
stmt = name '=' expr ¨ name args ¨ if ¨ 'out' expr ¨ block
if = 'if' ets ('elif' ets)* ('else' stmts?)? 'endIf'
ets = expr ('then' stmts?)?
expr = ( num ¨ string ¨ name args? ¨ block ¨ '('expr')' ) (op expr)?
args = '(' expr? (',' expr?)* ')'
lexical tokens:
¢^abc! any single character except 'a', 'b' or 'c'
'???' sinqle quoted strings designate constants, case insensitive
string string in single apostrophs, e.g. 'ab' 'a''b'"
name start with an alphabetic, consists of alphanums, case sensitive
num a number consisting only of digits
op most rexx operands are supported
in stmts spaces, newLines and comments are allowed around any token
***********************************************************************/
shellTest: procedure
parse arg op
if op = '' | pos('s', op) then do
m.q.1 = " abc = ('erstn''s' = 'ers' || 'tn' || '''s')"
m.q.2 = " * 2 "
m.q.3 = ";;;;; e123 = (abc * 3) + ('ab' = abc) ;;;;"
m.q.4 = "if abc = 1 then v='eins' elif abc = 2 then ;; v ='zwei';; "
m.q.5 = "else v ='??' || abc endIf; "
m.q.6 = "shellSay('abc='||abc,,'e123=' "
m.q.7 = " || e123,'v=' || v,,,'?') "
m.q.8 = ";; shellSay(shellSay(shellSay('shellSay**3')))"
m.q.9 = ";; endif ; ; "
m.q.0 = 8
say 'shellTest with' m.q.0 'stmts'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
call shellBegin c, s
call shellStmts(c)
call shellInterpret c
end
if op = '' | pos('d', op) then do
m.v.eins ='valEins'
m.v.zwei ='valZwei'
m.l.1='zeile eins geht unverändert'
m.l.2='$EINS auf zeile $ZWEI'
m.l.3='...$EINS?auf zeile {ZWEI}und a{EINS}b{ ZWEI }c'
m.l.4='{EINS}$ZWEI$EINS{ZWEI}'
m.l.5='...$EINS,uf zeile {ZWEI}und $EINS$$'
m.l.6="{;eins = 'neuEins hier'; zwei=neuZwei}und wei"
m.l.7='$EINS nach änderung $ZWEI'
m.l.0=7
say 'shellTest with' m.l.0 'data'
call scanBegin s, 'm', l
call shellBegin c, s
call shellData c
do y=1 to m.l.0
say 'old' y m.l.y
say 'new' y m.c.out.y
end
end
return
endProcedure shellTest
shellTestUfgh: procedure
parse arg a.1,a.2,a.3,a.4,a.5, a.6, a.7, a.8, a.9
s = 'call shellTestUfgh('
do x=1 to 9
if a.x <> '' then
s = s 'a.' || x || '=' || a.x
end
say s ')'
return 'shellTestUfgh('a.1')'
endProcedure shellTestUfgh
shellSay: procedure
parse arg a, b, c
say 'shellSay('a',' b',' c')'
return 'shellSay('a',' b',' c')'
shellBlockStart: procedure
parse arg st
return (left(st, 1) == '{' & length(st) == 2 ,
& pos(st, '{;{>{*') > 0)
endProcedure shellBlockStart
shellBlock: procedure expose m.
parse arg m
s = m.m.scan
if ^scanChar(s, 2) then
return 0
bl = m.s.tok
if bl = '{;' then do
rexxOld = m.m.rexx
m.m.rexx = ''
call shellStmts m
call shellInterpret m
m.m.rexx = rexxOld
end
else if bl = '{>' then do
call shellData m, 1
end
else if bl = '{*' then do
call shellComment m, 0
end
else do
call scanBack s
return 0
end
if ^ (scanChar(s, 1) & m.s.tok = '}') then
call scanErrBack s, 'closing brace (}) for' bl 'block missing'
return 1
end shellBlock
shellStmts: procedure expose m.
parse arg m
s = m.m.scan
semi = 1
do forever
do while scanChar(s, 1) & m.s.tok = ';'
semi = 1
end;
if m.s.eof then
return
call scanBack s
if ^ semi then
return
semi = 0
if shellBlock(m) then
nop
else if ^ scanName(s) then
return
else do
st = m.s.tok
stUp = translate(st)
if stUp = 'IF' then
call shellIf m
else if stUp = 'WHILE' then
call shellWhile m
else if stUp = 'OUT' then
call shellRexx m,
, "call shellOutLn '"m"'," shellExpr(m)";"
else if shellReserved(stUp) then do
call scanBack s
return
end
else if scanChar(s, 1) & m.s.tok = '=' then
call shellRexx m,
, "call shellPut '"st"'," shellExpr(m)";"
else if m.s.tok = '(' then
call shellRexx m, 'call' st shellGetArgs(m)';'
else
call scanErrBack s, 'stmt expected'
end
end /* do forever */
endProcedure shellStmts
shellBegin: procedure expose m.
parse arg m, s
m.m.scan = s
m.m.lv = 0
m.m.rexxNr = 0
m.m.rexx = ''
m.m.out.0 = 0
m.m.out.line = ''
return
endProcedure shellBegin
shellKeyValue: procedure expose m.
parse arg data, firstKey, firstVal, keys
upper firstKey keys
call scanBegin aNop, 's', data
firstTime = 1
do forever
if ^scanName(aNop) then do
if m.aNop.eof then
leave
else
call scanErr aNop, 'variableName expected'
end
name = translate(m.aNop.tok)
if ^scanChar(aNop, 1) | m.aNop.tok <> '=' then
call scanErr aNop, 'assignment operator (=) expected'
if scanName(aNop) then
value = translate(m.aNop.tok)
else if scanNum(aNop) then
value = m.aNop.tok
else if scanString(aNop) then
value = m.aNop.val
else
call scanErr aNop, "value (name or string '...') expected"
if scanRight(aNop, 1) <> '' then
call scanErr aNop, 'space expected'
if firstTime & firstKey <> '' then do
if name <> firstKey then
call scanErr aNop, 'first key is not' firstKey
if firstVal <> '' & value <> firstVal then
call scanErr aNop, 'first value is not' firstVal
end
else if wordPos(name, keys) < 1 then
call scanErr aNop, 'key' name 'not supported'
firstTime = 0
call shellPut name, value
end
all = firstKey keys
do ix=1 to words(all)
x = shellGet(word(all, ix), aNop)
end
call trc 'end analyseAfp loop'
return
endProcedure shellKeyValue
shellDataDD: procedure expose m.
parse arg readDD, writeDD
say 'shellDataDD begin' readDD writeDD
call scanBegin s, 'dd', readDD
call shellBegin c, s
call shellData c, 0
call trc 'shellData out.0' m.c.out.0
call writeDDBegin writeDD
call writeNext writeDD, 'm.c.out.'
call writeDDEnd writeDD
call scanEnd s
call trc '*** shellDataDD end' readDD writeDD
return
end shellDataDD
shellGet: procedure expose m.
parse arg name, s
if symbol('m.v.name') = 'VAR' then
return m.v.name
else if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure shellGet
shellPut: procedure expose m.
parse arg name, value
m.v.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure shellPut
shellData: procedure expose m.
parse arg m, partial
s = m.m.scan
ol = ''
if partial = 1 then
if scanRight(s) = '' then
call scanNextLine s /* skip empty partial line */
do forever
call scanUntil s, '{}$'
call shellOut m, m.s.tok
stop = scanRight(s, 2)
if stop = '' then do
call shellOutLn m
if ^ scanNextLine(s) then
return
end
else if left(stop, 1) = '}' then do
if partial <> 1 then
call scanErr s, 'unpaired closing brace (})'
/* forget partial empty line */
call shellOutLn m, , ( scanLeft(s) = '')
return
end
else if shellBlockStart(stop) then do
call shellOutLn m, , (scanLeft(s) = '')
call shellBlock m
if scanRight(s) = '' then
if ^ scanNextLine(s) then /* skip empty partial line */
return
end
else if left(stop, 1) = '$' then do
call scanChar s, 1
if ri = '' then
call shellOut m, '$'
else if ^ scanName(s) then
call shellOut m, '$'
else
call shellOutVar m, m.s.tok
end
else do
call scanChar s, 1
call scanUntil s, '}'
if scanRight(s, 1) ^== '}' then
call scanErrBack s, 'closing } for {name missing'
call shellOutVar m, strip(m.s.tok), s
call scanChar s, 1
end
end;
endProcedure shellData
shellComment: procedure expose m.
parse arg m, strings
s = m.m.scan
do while ^ m.s.eof
if strings then
call scanUntil s, "{}'"
else
call scanUntil s, "{}"
st = scanRight(s, 2)
if st = '' then
call scanNextLine s
else if left(st, 1) = '}' then
return
else if left(st, 1) = "'" then
call scanString s
else do
call scanChar s, 1
call shellComment m, st = '{;'
if ^ (scanChar(s, 1) | m.s.tok ^== '}' then
call scanErrBack 'comment not terminated by }'
end
end
call scanErr s, 'non terminated comment'
endProcedure shellComment
shellOutLn: procedure expose m.
parse arg m, txt, forget
if forget <> 1 then do
ox = m.m.out.0 + 1
m.m.out.0 = ox
m.m.out.ox = strip(m.m.out.line || txt, 't')
call trc 'shellOutLn' ox':' m.m.out.ox
end
m.m.out.line = ''
return
endProcedure shellOut
shellOut: procedure expose m.
parse arg m, txt
m.m.out.line = m.m.out.line || txt
return
endProcedure shellOut
shellOutVar: procedure expose m.
parse arg m, name, scn
m.m.out.line = m.m.out.line || shellGet(name, scn)
return
endProcedure shellOutVar
shellRexx: procedure expose m.
parse arg m, line
m.m.rexxNr = m.m.rexxNr + 1
m.m.rexx = m.m.rexx line
call trc 'shellRexx'right(m.m.rexxNr, 4)':' left('', m.m.lv * 2)line
return
endProcedure shellRexx
shellInterpret: procedure expose m.
parse arg m
call trc 'shellInterpret' m 'src:' m.m.rexx
interpret m.m.rexx
call trc 'interpret rc' rc 'result' result
return
end shellInterpret
shellExpr: procedure expose m.
parse arg m
s = m.m.scan
if scanName(s) then do
nm = m.s.tok
if shellReserved(nm) then
call scanErrBack s, 'reserved word in expression'
else if scanChar(s, 1) & m.s.tok = '(' then
res = nm'('shellGetArgs(m)')'
else do
call scanBack s
res = "shellGet('"nm"')"
end
end
else if scanNum(s) then
res = m.s.tok
else if scanString(s) then
res = m.s.tok
else if scanChar(s, 1) & m.s.tok = '(' then do
res = shellExpr(m)
if ^ (scanChar(s, 1) & m.s.tok = ')') then
call scanErrBack s, "closing bracket ')' missing"
res = '('res')'
end
else
call scanErrBack s, "expression expected"
if ^ scanChar(s, 2) then
return res
op = strip(m.s.tok)
if ^ (length(op) = 2 & pos(op, '== || <> <= >=') > 0) then do
op = left(op, 1)
call scanBack s
if pos(op, '+-*/%=') = 0 then
return res
call scanChar s, 1
end
return res op shellExpr(m)
endProcedure shellExpr
shellGetArgs: procedure expose m.
parse arg m
s = m.m.scan
ex = ''
do forever
if scanChar(s, 1) & m.s.tok = ')' then
return ex
else if m.s.tok = ',' then
ex = ex ','
else do
call scanBack s
if ^( ex = '' | right(ex, 1) = ',') then
call scanErr s, ', or ) expected'
ex = ex shellExpr(m)
end
end
endProcedure getArgs
shellReserved: procedure expose m.
parse upper arg wrd, s
if wordPos(wrd, 'IF THEN ELIF ELSE ENDIF WHILE DO ENDWHILE OUT')< 1 then
return 0
else if s = '' then
return 1
else
call scanErr s, 'reservered word' wrd 'in bad place'
endProcedure shellReserved
shellIf: procedure expose m.
parse arg m
s = m.m.scan
st = 'if'
do forever
ex = shellExpr(m)
call scanName s
na = translate(m.s.tok)
if na = 'THEN' then do
call shellRexx m, st "1 = ("ex") then do;"
m.m.lv = m.m.lv + 1
call shellStmts(m)
call shellRexx m, 'end;'
m.m.lv = m.m.lv - 1
call scanName s
na = translate(m.s.tok)
end
else
call shellRexx m, st "1 = ("ex") then nop;"
if na <> 'ELIF' then
leave
st = 'else if'
end;
if na = 'ELSE' then do
call shellRexx m, 'else do;'
m.m.lv = m.m.lv + 1
call shellStmts m
call shellRexx m, 'end;'
m.m.lv = m.m.lv - 1
call scanName s
na = translate(m.s.tok)
end
if na <> 'ENDIF' then
call scanErrBack s, 'endif expected'
return
endProcedure shellIf
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034uUnd hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = ('ers' || 'tn' || '''s')"
m.q.4 = " drei;+HHhier123sdfER?? '''' "
m.q.0 = 4
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTest
scanBegin: procedure expose m.
parse arg m, pTyp, pOpt
m.m.typ = pTyp
if pTyp = 'm' then do
m.m.lines = pOpt
end
else if pTyp = 's' then do
m.m.lines = m
m.m.0 = 1
m.m.1 = pOpt
end
else if pTyp = 'dd' then do
m.m.lines = m
m.m.0 = 0
m.m.dd = pOpt
call readDDBegin m.m.dd
end
else
call err 'bad scanBegin typ' pTyp
m.m.lx = 1
m.m.baseLx = 0
m.m.bx = 1
m.m.cx = 1
m.m.curLi = m.m.lines'.1'
m.m.eof = 0
if pTyp = 'dd' then
call scanNextLine m
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
if m.m.typ = 'dd' then
call readDDEnd m.m.dd
return
endProcedure scanEnd
scanNextLine: procedure expose m.
parse arg m
l = m.m.lines
m.m.lx = m.m.lx + 1
if m.m.lx > m.l.0 then do
if m.m.typ <> 'dd' then do
m.m.eof = 1
return 0
end
m.m.baseLx = m.m.baseLx + m.m.0
if ^ readNext(m.m.dd, 'm.'m'.') then do
m.m.eof = 1
return 0
end
m.m.lx = 1
end
m.m.curLi = l'.'m.m.lx
m.m.cx = 1
m.m.bx = 1
return 1
endProcedure scanNextLine
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanChar: procedure expose m.
parse arg m, len
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then
leave
if ^ scanNextLine(m) then do
m.m.tok = ''
return 0
end
end
if length(m.l) >= vx + len then
m.m.tok = substr(m.l, vx, len)
else
m.m.tok = substr(m.l, vx)
m.m.bx = vx
m.m.cx = vx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
m.m.tok = ''
m.m.val = ''
if qu = '' then
qu = "'"
if ^ scanChar(m, 1) then
return 0
qx = m.m.cx
m.m.cx = m.m.bx
if m.m.tok <> qu then
return 0
l = m.m.curLi
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
m.m.tok = ''
if ^ scanChar(m, 1) then
return 0
m.m.cx = m.m.bx
if alpha = '' then do
alpha ,
= '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ'
if pos(m.m.tok, alpha) <= 10 then
return 0
end
l = m.m.curLi
vx = verify(m.l, alpha, 'n', m.m.bx)
if vx = m.m.bx then
return 0
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
return scanName(m, '0123456789')
end scanNum
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx substr(m.l, m.m.cx)
whe = 'typ' m.m.typ
if m.m.typ = 'dd' then
whe = whe m.m.dd (m.m.baseLx + m.m.lx)
say whe 'line' l m.l
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
readBegin, readNext*, readEnd read dsn in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(readDsn) shr dsn('ggdsn')'
call adrTso 'execio * diskr readDsn (stem' ggSt' finis)'
call adrTso 'free dd(readDsn)'
return
endSubroutine readDsn
readDDBegin: procedure
return /* end readDDBegin */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr dsn('dsn')'
return /* end readBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return 1
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
readEnd: procedure
parse arg dd
call readDDEnd dd
call adrTso 'free dd('dd')'
return /* end readEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/
}¢--- A540769.WK.REXX.O13(PVSRWGRV) cre= mod= ----------------------------------
/* rexx ****************************************************************
pvsRwgrV: Verrechnung Jes Output
synopsis: pvsRwgrV ¢-opt ...! rz ...
rz 1 oder mehre RZs (RZ1 RZ2 usw)
and -opt may be one of the following options (0 - n allowed)
-T trace
-H, -? this help
-V Verrechnungsfiles erstellen
-Lcla monatlichen/jährlich Loesch/Putzaktion
alte MonatsFiles mit SMS mgmtClass cla erstellen
-Snode,cla send the created monthly save Files to Node node
create them there with mgmtClass cla
-PpFr,pTo add prefix mapping from pFr to pTo (additive)
-P clear all prefix mappings
Funktion -V:
schreibe alle nicht verrechneten JesOut Records
vor dem aktuellen Datum aus dem JesOut Logfiles
auf das File DD VERR für DWS
append ans verrLog einen Logeintrag (fun=verr),
der besagt, bis wohin jetzt für welche RZ verrechet wurde
aus verrLog wird auch bestimmt, was schon verrechnet wurde
Funktion -L:
falls JesOut Logfile Records aus mehr als einem Monat enthält,
schiebe alte Monate in Monatsfiles
Achtung: falls auch -V gesetzt nur das erste rz
falls -V gesetzt und verrLog Einträge aus Vorjahren enthält,
schiebe alte Jahre in Jahresfiles
Option -P:
definieren eine Liste von Prefix Übersetzungen, Default
WGR.RZ1.P0.AKT.LST. ==> WGR.U0034.P0.VERR.LST.RZ1.
WGR.RZ2.P0.AKT.LST. ==> WGR.U0034.P0.VERR.LST.RZ2.
die monatlichen/jährlichen SaveFiles für <pFr><Rest> heissen
<pTo><Rest>yy <pTo><Rest>yymm
<pFr><Rest>yy <pFr><Rest>yymm
je nachdem ob <pFr> ==> <pTo> in der Uebers.Liste ist
und ob der save jährliches oder monatlich ist
Files
DD VERRLOG: logfile der gelieferten verrechnungsFile
wird gelesen um aufsetzpunkt zu finden
und einträge für aktuell gelieferte Files append'd
Achtung: muss mit disp=mod alloziert sein,
damit append funktioniert
DD LOG<rz>: JesOuput Logfile für jedes gewählte RZ
DD VERR: das output File
DD SYSPRT: Meldungen und Trace
Inhalt dd VERR: Ein Record pro output File
(damit Stapel richtig aus Seiten berechnet werden können)
Record Layout (total länge 60 Byte)
pos len typ Inhalt
Feld len offs Inhalt
JOB 8 0 gguuXXXX gg=Gebietspointer
uu=UmsetzungsCode
XXXX=Filler (zurzeit 'XXXX')
MACHINE 4 8 RZ1 oder RZ2
OUCLASS 1 12 Output Class
SMFDATE 9 13 ddMonyyyy PrintDatum, z.B. 04JUL2005
PAGECNT 8 22 Anzahl Seiten, z.B. 00000123
TOLINES 8 30 Anzahl Zeilen, immer 00000000
FORM 8 38 Printer immer '2240'
pvsPrintTst 14 46 yyyymmddHHMMSS Print Timestamp
60
************************************************************************
History
30.08.2005 W. Keller, -p option for prefix translation
30.08.2005 W. Keller, -s option to send monthly files to other node
30.08.2005 W. Keller, monthly/yearly save: create also empty files
29.08.2005 W. Keller, Stapelgroesse = 2000 gemäss Mail Malnati
23.08.2005 W. Keller, yearly cleanup of verrLog
22.08.2005 W. Keller, erlaube leere LogFiles
24.06.2005 W. Keller, neu
***********************************************************************/
parse arg args
/* analyse arguments */
m.trace = 0
rz = ''
verr = 0
lOpt = ''
sNode = ''
sClass = ''
m.prefix.1.from = 'WGR.RZ1.P0.AKT.LST.'
m.prefix.1.to = 'WGR.U0034.P0.VERR.LST.RZ1.'
m.prefix.2.from = 'WGR.RZ2.P0.AKT.LST.'
m.prefix.2.to = 'WGR.U0034.P0.VERR.LST.RZ2.'
m.prefix.0 = 2
do wx=1 to words(args)
w = translate(word(args, wx))
if w='?' | w ='-?' | w= '-H' then
return help()
else if w = '-T' then
m.trace = 1
else if w = '-V' then
verr = 1
else if left(w, 2) = '-L' then
lOpt = substr(w, 3)
else if left(w, 2) = '-S' then
parse var w 3 sNode "," sClass
else if left(w, 2) = '-P' then do
if w = '-P' then do
m.prefix.0 = 0
end
else do
px = m.prefix.0 + 1
m.prefix.0 = px
parse var w 3 m.prefix.px.from "," m.prefix.px.to
end
end
else
rz = rz w
end
dat = date('s')
tim = time('n')
/* test in foreground */
testFree = ''
if rz == '' then do
if sysvar(sysenv) ^== 'FORE' then
call errHelp 'rz not specified'
say 'forground mode ==> test'
sNode = 'RZ2'
sClass = 'S005Y011'
if lOpt = '' & ^ verr then do
verr = 1
lOpt = A008Y000
end
call adrTso "alloc dd(verrLog) mod dsn(lst.vrLog)"
call adrTso "alloc dd(logRZ1) old dsn(lst.log)"
call adrTso "alloc dd(logRZ2) old dsn(lst.rz2.log)"
call adrTso "alloc shr dd(verr) old dsn(lst.verr)"
rz = 'RZ1 RZ2'
testFree = 'verrLog logRZ1 logRZ2 verr'
end
say 'pvsRwgrV analysed: RZs='rz 'verr='verr 'trace=' m.trace
say ' loesch='lOpt 'send='sNode 'cla='sClass
say ' runTimestamp='dat tim
do px=1 to m.prefix.0
say ' prefix' m.prefix.px.from '==>' m.prefix.px.to
end
m.oldFiles = ''
if verr then /* tägliche Verrechnung */
call logVerr 'verrLog', 'verr', dat, tim, rz
if lOpt ^== '' then do /* monthly/yearly cleanup*/
if ^ verr then do
do x=1 to words(rz)
call logCleanupMon lOpt, left(dat, 6), word(rz, x)
end
end
else if logCleanupMon(lOpt, left(dat, 6), word(rz, 1)) then do
call logCleanupYear left(dat, 4), 'verrLog', rz
end
end
if sNode ^== '' then do
if sClass ^== '' then
sClass = mgmtClas sClass
do fx=1 to words(m.oldFiles)
fi = dsnFromJcl(word(m.oldFiles, fx))
call connectDirect fi, sNode, ,disp new, wait yes, sClass
end
end
if testFree ^== '' then
call adrTso 'free dd('testFree')'
say 'pvsRwgrV end' rz dat tim
exit
logVerr: procedure expose m.
parse upper arg ddVerrLog, ddOut, ruDa, ruTi, argRz
/*----------------------------------------------------------------------
schreibe alle nicht verrechneten Records
vor dem Datum ruDa
append ein fun=verr Record ans log, der nachweist,
bis wohin wir verrechnet haben
Parameter
ddLog: dd des Logfile, muss disp=mod alloziert sein,
damit append funktioniert
ddOut: dd für das output Verrechnungs file
ruDa, ruTi: run = liefer Datum und Zeit
argEnv: Ziel Umgebung (TEST oder PROD)
----------------------------------------------------------------------*/
/* search verrLog */
call readDDBegin ddVerrLog
m.vl.first = 999999
cnt = 0
do while readNext(ddVerrLog, vl.)
cnt = cnt + vl.0
do r=1 to vl.0
call trc 'vl.'r vl.r
rz = translate(word(vl.r, 3))
if left(rz, 5) = 'VERR=' then do
rz = substr(rz, 6)
if symbol("rz.rz") ^== "VAR" then do
t1 = getTo(vl.r, rz, 'erste Verrechnung rz' rz)
if t1 << m.vl.first then
m.vl.first = t1
end
rz.rz = vl.r
end
end
end
call readDDEnd ddVerrLog
call trc 'm.vl.first' m.vl.first
say 'read' cnt 'records from dd' ddVerrLog
call writeDDBegin ddOut
logX = 0
m.logOut.0 = 0
/* verrechnung for each rz */
do wx = 1 to words(argRZ)
rz = word(argRZ, wx)
if symbol('rz.rz') ^== 'VAR' then
call err 'rz' rz 'not found in dd' ddVerrLog
call trc 'letzte Verrechnung rz' rz':' rz.rz
tst = getTo(rz.rz, rz, 'letzte Verrechnung rz' rz)
m.logOut.pref = ruDa ruTi 'verr='rz
call logRz 'log'rz, ddOut, rz, word(tst,1) word(tst,2), ruDa
end
call writeDDEnd ddOut
/* append VerrLog Eintraege */
say 'append' m.logOut.0 'Eintraege auf dd' ddVerrLog
call writeDDBegin ddVerrLog
call writeNext ddVerRLog, m.logOut.
call writeDDEnd ddVerrLog
return
endProcedure logVerr
/*----------------------------------------------------------------------
analyse the log reccord passed as first argument
check rz if argument rz not empty
isssue a msg if argument msg not empty
set m.getTo.qRZ to rz
set m.getTo.qTo to toTimestamp
return toTimestamp
----------------------------------------------------------------------*/
getTo: procedure expose m.
parse arg lDat lTim contents, rz, msg
call scanBegin sLW, 's', contents
if ^scanKeyValue(sLW) | m.sLW.key ^== 'VERR' ,
| (rz ^== '' & m.sLW.val ^== rz) then
call scanErr sLw, 'rz' rz 'mismatch'
m.getTo.qRZ = m.sLW.val
if ^scanKeyValue(sLW) | m.sLW.key ^== 'TO' then
call err 'to missing in dd' ddVerrLog':' lDat lTim contents
m.getTo.qTo = strip(m.sLW.val)
if msg ^== '' then
say msg 'to' m.getTo.qTo 'Lieferung' lDat lTim
return m.getTo.qTo
endProcedure getTo
/*----------------------------------------------------------------------
store on verrLog record in stem m.logout.
----------------------------------------------------------------------*/
logOut: procedure expose m.
parse arg msg
x = m.logOut.0 + 1
m.logOut.0 = x
m.logOut.x = m.logOut.pref msg
say 'logOut.' || x m.logOut.x
return
endProcedure logOut
/*----------------------------------------------------------------------
process the log of one RZ
----------------------------------------------------------------------*/
logRZ: procedure expose m.
parse arg ddLog, ddOut, rz, frTst, toTst
say 'verrechnung rz' rz 'from' frTst 'to' toTst ,
'dd' ddLog '==>' ddOut
/* position log */
call readDDBegin ddLog /* at beginning */
rNr = 0
ro = 0
/* skip old records */
found = 0
do while readNext(ddLog, ri.)
if rNr = 0 then
m.log1.rz = ri.1
do r=1 to ri.0
rNr = rNr + 1
cDaTi = word(ri.r ,1) word(ri.r, 2)
if cDaTi << lDaTi then
call err 'dateTime decreasing dd' ddLog rNr ri.r
lDaTi = cDaTi
if lDaTi >> frTst then do
found = 1
call trc 'first after fromTst:' rNr ri.r
leave
end
end
if found then
leave
end
if ^ found then do
say 'alle Records schon verrechnet in' ddLog
call readDDEnd ddLog
m.logE.rz = cDaTi
return ''
end
/* process records */
qStapel = 2000
call logRzDayBegin cDaTi
do while cDaTi << toTst /* each record */
if lDa ^== word(cDaTi, 1) then do
if c.jobs > 0 then
call logRzDayEnd laDaTi /* finish old day */
lDa = word(cDaTi, 1)
call logRzDayBegin cDaTi /* start new day */
end
laDaTi = cDaTi
/* prepare output record */
da = left('', 8),
|| left(rz, 5),
|| right(translate(,
space(DATE('n', word(cDaTi, 1), 's'), 0)), 9, '0'),
|| left('', 16, '0'),
|| left('2240', 8),
|| space(translate(cDaTi, ' ', ':'), 0)
call trc 'da begin' length(da) da
call scanBegin s, 's', substr(ri.r, wordIndex(ri.r, 3))
pages = 0
recs = 0
chars = 0
copies = 1
cla = 5
/* analyse one log record */
do while scanKeyValue(s)
select;
when m.s.key = 'VERRECHNUNG' then
da = overlay(m.s.val, da, 1, 8, 'X')
when m.s.key = 'CLASS' then
cla = m.s.val
when m.s.key = 'COPIES' then
copies = m.s.val
when m.s.key = 'PAGES' then
pages = m.s.val
when m.s.key = 'RECORDS' then
recs = m.s.val
when m.s.key = 'CHARACTERS' then
chars = m.s.val
otherwise nop
end
end
if ^ m.s.eof then
call scanErr s, 'key=value expected'
call scanEnd s, 's' ri.r
/* write verrechnung */
da = overlay(cla, da, 13, 1)
paCo = pages * copies
da = overlay(right(paCo, 8, '0'), da, 23, 8)
c.jobs = c.jobs + 1
call trc 'da end ' length(da) da
ro = ro + 1
ro.ro = da
/* statistics */
if wordPos(cla, c.classes) < 1 then do
c.classes = c.classes cla
c.cla.jo = 0
c.cla.pa = 0
c.cla.re = 0
c.cla.ch = 0
c.cla.st = 0
end
c.cla.jo = c.cla.jo + 1
c.cla.pa = c.cla.pa + paCo
c.cla.re = c.cla.re + recs
c.cla.ch = c.cla.ch + chars
c.cla.st = c.cla.st + ((paCo + qStapel - 1) % qStapel)
/* get next record */
r = r + 1
if r > ri.0 then do
/* read rsp. write next block */
if ^ readNext(ddLog, ri.) then
leave
r = 1
ro.0 = ro
call writeNext ddOut, ro.
ro = 0
end
cDaTi = word(ri.r, 1) word(ri.r, 2)
end /* read ddLog */
/* finish */
m.logE.rz = cDaTi
call readDDEnd ddLog
if c.jobs > 0 then
call logRzDayEnd laDaTi
if ro > 0 then do
ro.0 = ro
call writeNext ddOut, ro.
ro = 0
end
if c.allJobs == 0 then
say 'alle Records schon verrechnet oder zu jung in' ddLog
return
endProcedure logRz
/*----------------------------------------------------------------------
initialise stem c. for a new day
----------------------------------------------------------------------*/
logRzDayBegin: procedure expose c. m.
parse arg cDaTi
if symbol('c.allJobs') == 'VAR' then
aj = c.allJobs
else
aj = 0
drop c.
c.allJobs = aj
c.classes = ''
c.fiDaTi = cDaTi
c.jobs = 0
return
endSubroutine logRzDayBegin
/*----------------------------------------------------------------------
create the verrLog Record for one day from stem c.
----------------------------------------------------------------------*/
logRzDayEnd: procedure expose c. m.
parse arg laDaTi
c.allJobs = c.allJobs + c.jobs
call trc rz':' c.jobs 'from' c.fiDaTi 'to' laDaTi 'total' c.allJobs
/* statistic per class */
names = jo pa st re ch
labels = 'jobs pages stapel records characters'
do nx=1 to words(names)
nm = word(names, nx)
c.nm = 0
end
res = ''
do cx=1 to words(c.classes) /* add statistics for each class */
cla = word(c.classes, cx)
txt = ''
do nx=1 to words(names)
nm = word(names, nx)
txt = txt c.cla.nm
c.nm = c.nm + c.cla.nm
end
call trc 'class' cla txt
res = res 'class'cla'='quote(strip(txt))
end
txt = ''
do nx=1 to words(names)
nm = word(names, nx)
txt = txt word(labels, nx)'='c.nm
end
call trc 'total' txt
call logOut 'to=' || quote(laDati) ,
'from=' || quote(c.fiDaTi) txt res
return
endProcedure logRzDayEnd
logSearchTest: procedure expose m. d.
parse arg ddIn
/*----------------------------------------------------------------------
test logSearch several times
with different read chunks
----------------------------------------------------------------------*/
ro = logSearch(ddIn, '*')
say 'ro' ro
do i=0 to 50
o.i = d.i
end
do cnt=1 by 1 to 20
drop d.
rn = logSearch(ddIn, cnt)
if rn ^== ro then
call err 'check cnt' cnt 'rn' rn '^== ro' ro
do i=0 to 50
if d.i ^== o.i then
call err 'check cnt' cnt 'd.'i d.i '^== o.'i o.i
end
call readDDBegin ddIN
rr = word(rn, 3)
if rr > 0 then do
call adrTso 'execio' (rr-1) 'diskr' ddIn '(skip stem q.)'
call readNext ddIn, q., 1
if q.1 ^== substr(rn, wordIndex(rn, 4)) then
call err 'restart err rec' rr q.1 '^==' rn
end
call readDDEnd ddIN
end
return ro
endProcedure logSearchTest
/*----------------------------------------------------------------------
move Reocrds aus Vormonaten in Monatsfile
----------------------------------------------------------------------*/
logCleanupMon: procedure expose m.
parse arg pClas, nextMon, rz
ddLog = 'log'rz
if right(nextMon, 2) >> '01' then
oldMon = nextMon - 1
else
oldMon = nextMon - 89
call trc 'logCleanupMon next' nextMon 'old' oldMon 'rz' rz ,
'dd' ddLog
if 0 ^== listDsi(ddLog 'file') then
call err 'listDsi('ddLog 'file)' sysmsglvl2
logName = sysDsName
oldPref = prefixChange(logName)
atts = "mgmtClas("pClas") like('"logName"')"
oldName = "'"oldPref || right(oldMon, 4)"'"
oldSys = sysDsn(oldName)
call trc 'oldName' oldName oldSys
if oldSys == 'OK' then do
if symbol('m.log1.rz') == 'VAR' then
if nextMon >> left(word(m.log1.rz ,1), 6) then
call err oldName 'exists but' logName ,
'contains old entry' m.log1.rz
say 'monthly cleanup already done for' ddLog logName
say ' to file' oldName
return 0
end
say 'monthly cleanup before' nextMon 'of' ddLog logName
lMo = ''
lFi = ''
cIn = 0
/* read ddLog */
call adrTso "alloc dd(logOld) old dsn('"logName"')"
call readDDBegin logOld
do while readNext(logOld, ri.)
rMax = ri.0
cIn = cIn + rMax
r = 0
do while r < rMax
r = r + 1
cMo = left(word(ri.r, 1), 6)
if cMo == lMo then
iterate
else if cMo << lMo then
call err "month decreses in file" logName "from" lMo,
"to" cMo "in" ri.r
/* Monatswechsel */
cFi = right(cMo, 4)
lMo = cMo
if cMo >>= nextMon then do
cFi = 'save'
if lFi == '' then do
say 'dd' ddLog 'enthaelt nur Recs >= Monat' nextMon
call readDDEnd logOld
call adrTso "free dd(logOld)"
/* write empty file */
cFi = right(oldMon, 4)
m.oldFiles = m.oldFiles oldPref || cFi
call writeEmpty ddMon, "'"oldPref || cFi"'", atts
return 1
end
end
if cFi == lFi then
iterate
if cFi ^== 'save' then
m.oldFiles = m.oldFiles oldPref || cFi
if lFi ^== '' then do
/* letzten Monat schreiben */
ri.0 = r-1
cOut = cOut + ri.0
call writeNext ddMon, ri.
call writeDDEnd ddMon
call adrTso 'free dd(ddMon)'
say cOut 'records written to' oldPref || lFI
/* neuen Monat nach vorne schieben */
t = 0
do r=r to rMax
t = t+1
ri.t = ri.r
end
rMax = t
r = 1
end
lFi = cFi
/* neues File erstellen */
cOut = 0
call allocNew ddMon, "'"oldPref || cFi"'", atts
end
if lFi ^== '' then do
/* nächsten Block schreiben */
ri.0 = rMax
cOut = cOut + rMax
call writeNext ddMon, ri.
end
end
if lFi ^== '' then do
call writeDDEnd ddMon
if lFi ^== 'save' then
call adrTso "free dd(ddMon)"
say cOut 'records written to' oldPref || lFI
end
call readDDEnd logOld
say cIn 'records read from' ddLog logName
if lFi == '' then do
/* write empty file */
cFi = right(oldMon, 4)
m.oldFiles = m.oldFiles oldPref || cFi
call writeEmpty ddMon, "'"oldPref || cFi"'", atts
return 1
end
/* save auf log überklatschen */
cIn = 0
call writeDDBegin logOld
if lFi == 'save' then do
call readDDBegin ddMon
do while readNext(ddMon, ri.)
cIn = cIn + ri.0
call writeNext logOld, ri.
end
call readDDEnd ddMon
say cIn 'records read from' oldPref || lFI
end
call writeDDEnd logOld
say cIn 'records written to' logName
call adrTso 'free dd(logOld)'
if lFi == 'save' then
call adrTso 'free dd(ddMon) delete'
return 1
endProcedure logCleanupMon
allocNew:procedure expose m.
parse arg dd, dsn, atts
call adrTso "alloc dd("dd") new catalog dsn("dsn")" atts
call writeDDBegin dd
return
endProcedure allocNew
writeEmpty: procedure expose m.
parse arg dd, dsn, atts
call allocNew dd, dsn, atts
call writeDDEnd dd
call adrTso "free dd("dd")"
say "written empty file" dsn
return
endProcedure writeEmpty
prefixChange: procedure expose m.
parse arg old
do px=1 to m.prefix.0
if abbrev(old, m.prefix.px.from) then
return m.prefix.px.to ,
|| substr(old, 1 + length(m.prefix.px.from))
end
return old
endProcedure prefixChange
/*----------------------------------------------------------------------
move Reocrds aus VorJahr in Jahresfile
----------------------------------------------------------------------*/
logCleanupYear: procedure expose m.
parse arg nextYear, ddLog, allRz
say 'logCleanup nextYear' nextYear 'verrLog' ddLog 'rz' allRz
if 0 ^== listDsi(ddLog 'file smsinfo') then
call err 'listDsi('ddLog 'file)' sysmsglvl2
logName = sysDsName
atts = "mgmtClas("sysMgmtClass") like('"logName"')"
say 'dd' ddlog 'atts' atts
oldPref = prefixChange(logName)
oldName = "'"oldPref || right(nextYear -1, 2)"'"
oldSys = sysDsn(oldName)
call trc 'oldName' oldName oldSys 'first' m.vl.first
if oldSys == 'OK' then do
if symbol('m.vl.first') == 'VAR' then
if nextYear >> m.vl.first then
call err oldName 'exists but' logName ,
'contains old entry to' m.vl.first
say 'yearly cleanup already done for' ddLog logName
say ' to file' oldName
return 0
end
say 'yearly cleanup before' nextYear 'for' ddLog logName
rz.nextYear = ''
yys = ''
call adrTso "alloc dd(ddOld) old dsn('"logName"')"
call readDDBegin ddOld
oc = 0
do while readNext(ddOld, o., 3)
oc = oc + o.0
do rx=1 to o.0
y = left(getTo(o.rx), 4)
if wordPos(y, yys) < 1 then do
if verify(y, '0123456789') ^== 0 | y >> nextYear then
call err "bad to year '"y"' in" o.rx
yys = yys y
call allocNew "dd"y, "'"oldPref || right(y, 2)"'", atts
say 'new year' y
w.y.0 = 0
w.y.aa = 0
rz.y = ''
end
wx = w.y.0 + 1
w.y.0 = wx
w.y.wx = o.rx
if wordPos(m.getto.qRZ, rz.y) < 1 then
rz.y = rz.y m.getTo.qRZ
end
call writeW 4
end
call readDDEnd ddOld
say oc 'records read from ddOld' logName
call writeW 1
do i=1 to words(yys)
y = word(yys, i)
call writeDDend 'dd'y
call adrTso 'free dd(dd'y')'
say w.y.aa 'records written to dd'y 'for' rz.y
end
if wordPos((nextYear -1), yys) < 1 then
call writeEmpty ddEmpty, oldName, atts
call writeDDBegin ddOld
if wordPos(nextYear, yys) > 0 then do
call adrTso "alloc dd(ddTmp) old",
"dsn('"oldPref || right(nextYear, 2)"')"
call readDDBegin ddTmp
cn = 0
do while readNext(ddTmp, n.)
cn = cn + n.0
call writeNext ddOld, n.
end
call readDDEnd ddTmp
say cn "records copied from" oldPref || nextYear "to" logName
end
else do
say cn "no records for year" nextYear "in" logName
end
logPr = subword(m.logOut.pref, 1, 2)
y = nextYear
nx = 0
do i=1 to words(allRz)
rz = word(allRz, i)
if wordPos(rz, rz.y) > 0 then do
say 'rz' rz 'already in' logName
end
else do
nx = nx + 1
n.nx = logPr 'verr='rz 'to='nextYear'0101 00:00:00'
say 'adding rz' rz 'to' logName':' n.nx
end
end
if nx > 0 then do
n.0 = nx
call writeNext ddOld, n., nx
say nx 'records appended to' logName
end
call writeDDEnd ddOld
call adrTso "free dd(ddOld)"
if wordPos(nextYear, yys) > 0 then
call adrTso "free dd(ddTmp) delete"
return
endProcedure logCleanupYear
/*----------------------------------------------------------------------
write blocks to each yearFile with a minimum of min records
----------------------------------------------------------------------*/
writeW:
parse arg min
do i=1 to words(yys)
y = word(yys, i)
if w.y.0 >= min then do
call writeNext 'dd'y, w.y.
w.y.aa = w.y.aa + w.y.0
w.y.0 = 0
end
end
return
endProcedure writeW
trc: procedure expose m.
parse arg msg
if m.trace = 1 then
say 'trc: ' msg
return
endProcedure trc
err:
parse arg ggMsg
call errA ggMsg
exit 12;
connectDirect: procedure
/*******************************************************************
send the file frDsn from the current not
to the node toNode as toDsn if not empty
using connect direct
additional connect direct attributes may be specified
by arguments 4... (with ,a b, or equifalently , a='b',
********************************************************************/
parse upper arg frDsn, toNode, toDsn
say 'sending' frDsn 'to' toNode toDsn 'with connect direct'
call adrTso "alloc shr dd(sysut1) reuse dsn("frDsn")"
call adrTso "alloc new delete dd(DDIN) dsn("dsnTemp(connDir)")" ,
"recfm(f,b) lrecl(80)"
call writeDDBegin ddIn
t.1 = "DEST='"toNode"'"
t.2 = "DSNCOPY='YES'"
x=2
if toDsn ^= '' then do
x = x + 1
t.x = "DSN='"dsn2Jcl(toDsn)"'"
end
do ax=4 to arg()
parse upper value arg(ax) with key val
val = strip(val)
call trc 'arg' ax':' arg(ax) 'key' key "val '"val"'"
if key = '' then
iterate
x = x+1
if pos("=", key) > 0 then
t.x = key val
else
t.x = key"='"val"'"
end
call writeNext ddIn, t., x
call writeDDEnd ddIn
if 1 then do
call trc 'connectDirect ddIn' x
do i=1 to x
call trc i t.i
end
end
call adrTso "call *(OS2900)"
call adrTsoRc 'free dd(sysut1)' /* a ghost freed it already */
call adrTso 'free dd(ddin) delete'
/* os2900 does not free it dd's, so we do it
otherwise the second run will fail... */
call adrTsoRc 'free dd(ddPrint work01 cmdout dmprint)'
say 'end connectDirect'
return /* end connectDirect */
/* copy scan begin ****************************************************/
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034uUnd hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = ('ers' || 'tn' || '''s')"
m.q.4 = " drei;+HHhier123sdfER?? '''' "
m.q.0 = 4
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTest
scanBegin: procedure expose m.
parse arg m, pTyp, pOpt
m.m.typ = pTyp
if pTyp = 'm' then do
m.m.lines = pOpt
end
else if pTyp = 's' then do
m.m.lines = m
m.m.0 = 1
m.m.1 = pOpt
end
else if pTyp = 'dd' then do
m.m.lines = m
m.m.0 = 0
m.m.dd = pOpt
call readDDBegin m.m.dd
end
else
call err 'bad scanBegin typ' pTyp
m.m.lx = 1
m.m.baseLx = 0
m.m.bx = 1
m.m.cx = 1
m.m.curLi = m.m.lines'.1'
m.m.eof = 0
if pTyp = 'dd' then
call scanNextLine m
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
if m.m.typ = 'dd' then
call readDDEnd m.m.dd
return
endProcedure scanEnd
scanNextLine: procedure expose m.
parse arg m
l = m.m.lines
m.m.lx = m.m.lx + 1
if m.m.lx > m.l.0 then do
if m.m.typ <> 'dd' then do
m.m.eof = 1
return 0
end
m.m.baseLx = m.m.baseLx + m.m.0
if ^ readNext(m.m.dd, 'm.'m'.') then do
m.m.eof = 1
return 0
end
m.m.lx = 1
end
m.m.curLi = l'.'m.m.lx
m.m.cx = 1
m.m.bx = 1
return 1
endProcedure scanNextLine
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanChar: procedure expose m.
parse arg m, len
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then
leave
if ^ scanNextLine(m) then do
m.m.tok = ''
return 0
end
end
if length(m.l) >= vx + len then
m.m.tok = substr(m.l, vx, len)
else
m.m.tok = substr(m.l, vx)
m.m.bx = vx
m.m.cx = vx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
m.m.tok = ''
m.m.val = ''
if qu = '' then
qu = "'"
if ^ scanChar(m, 1) then
return 0
qx = m.m.cx
m.m.cx = m.m.bx
if m.m.tok <> qu then
return 0
l = m.m.curLi
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
m.m.tok = ''
if ^ scanChar(m, 1) then
return 0
m.m.cx = m.m.bx
if alpha = '' then do
alpha ,
= '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ'
if pos(m.m.tok, alpha) <= 10 then
return 0
end
l = m.m.curLi
vx = verify(m.l, alpha, 'n', m.m.bx)
if vx = m.m.bx then
return 0
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
if ^ scanName(m, '0123456789') then
return 0
else if datatype(scanRight(m, 1), 'A') then
call scanErrBack m, 'illegal number'
return 1
endProcedure scanNum
scanKeyValue: procedure expose m.
parse arg m
if ^scanName(m) then
return 0
m.m.key = translate(m.m.tok)
if ^scanChar(m, 1) | m.m.tok <> '=' then
call scanErr m, 'assignment operator (=) expected'
if scanName(m) then
m.m.val = translate(m.m.tok)
else if scanNum(m) then do
m.m.val = m.m.tok
end
else if scanString(m) then
nop
else
call scanErr m, "value (name or string '...') expected"
return 1
endProcedure scanKeyValue
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx substr(m.l, m.m.cx)
whe = 'typ' m.m.typ
if m.m.typ = 'dd' then
whe = whe m.m.dd (m.m.baseLx + m.m.lx)
say whe 'line' l m.l
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* copy scan end ****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
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), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
readBegin, readNext*, readEnd read dsn in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(readDsn) shr dsn('ggdsn')'
call adrTso 'execio * diskr readDsn (stem' ggSt' finis)'
call adrTso 'free dd(readDsn)'
return
endSubroutine readDsn
readDDBegin: procedure
return /* end readDDBegin */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr dsn('dsn')'
return /* end readBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
readEnd: procedure
parse arg dd
call readDDEnd dd
call adrTso 'free dd('dd')'
return /* end readEnd */
writeDDBegin: procedure
parse arg dd /* explicit open, for (old) empty file */
call adrTso "execio 0 diskw" dd "(open)"
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt, ggLines
if ggLines == '' then
ggLines = value(ggst'0')
call adrTso 'execio' ggLines 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/