Another one, in your favourite language, originally written by Simon Brown of
Willis sometime in 1992:
*process macro langlvl(os,sprog) test(all,sym);
*process rules(laxif);
-steps: proc(param) options(main) reorder;
-dcl param char(100) var;
-
-/**********************************************************************
-* STEPS - Entry's, builtins & files *
-**********************************************************************/
-dcl (addr,
- heximage,
- index,
- length,
- plidump,
- ptradd,
- ptrvalue,
- stg,
- substr,
- unspec,
- verify) builtin;
-
-dcl sysprint file;
-
-dcl p1 ptr init (ptrvalue(16)) static;
-
-dcl 1 s1 based(p1),
- 2 p2 ptr;
-
-dcl 1 s2 based(p2),
- 2 p3 ptr;
-
-dcl 1 s3 based(p3),
- 2 * ptr,
- 2 tcb_ptr ptr;
-
-dcl 1 tcb based(tcb_ptr),
- 2 *(3) ptr,
- 2 tiot_ptr ptr,
- 2 *(41) ptr,
- 2 jscb_ptr ptr;
-
-dcl 1 tiot based(tiot_ptr),
- 2 jobname char (8),
- 2 stepname char (8);
-
-dcl 1 jscb based(jscb_ptr),
- 2 *(65) ptr,
- 2 jscbjct ptr,
- 2 *(13) ptr,
- 2 jscbssib ptr;
-
-dcl 1 jct based(jscbjct),
- 2 *(5) ptr,
- 2 * char,
- 2 jctjstat bit (8),
- 2 * char (2),
- 2 jctjname char (8), /* job name */
- 2 *(4) ptr,
- 2 jctsdkad char (3), /* sva of first sct */
- 2 * char,
- 2 jctjctx char (3), /* sva of jctx */
- 2 * char,
- 2 jctactad char (3), /* sva of first act */
- 2 * char,
- 2 *(26) ptr,
- 2 * char,
- 2 jmrjmrjd fixed dec(5,3), /* job start date (julian) */
- 2 *(2) ptr,
- 2 jctuser char (7), /* job user id */
- 2 * char,
- 2 jctacode char (4); /* job abend code */
-
-dcl 1 ssib based(jscbssib),
- 2 *(3) ptr,
- 2 ssibjbid char (8); /* subsystem job id */
-
-dcl act_ptr ptr;
-dcl 1 act based(act_ptr),
- 2 * char (24),
- 2 actprgnm char (20),
- 2 * char (3),
- 2 actjnfld char,
- 2 actaccnt char (144);
-
-dcl sct_ptr ptr;
-dcl 1 sct based(sct_ptr),
- 2 *(6) ptr,
- 2 sctsexec fixed bin (15),
- 2 *(2) char,
- 2 *(2) ptr,
- 2 sctansct char (3), /* sva of next sct */
- 2 * char,
- 2 *(5) ptr,
- 2 sctsclpc char (8), /* name of step that called procedure */
- 2 sctsname char (8), /* step name */
- 2 *(2) ptr,
- 2 sctx_pch char (3),
- 2 * char,
- 2 *(9) ptr,
- 2 sctpgmnm char (8), /* program name */
- 2 * char (2),
- 2 sctcdent(8) char (6),
- 2 * char (6),
- 2 sctstend bit (8); /* bits and pieces */
-
-dcl sctx_ptr ptr;
-dcl 1 sctx based(sctx_ptr),
- 2 *(5) ptr,
- 2 sctxparm char (100);
-
-dcl jctx_ptr ptr;
-dcl sctxparm_v char (100) var;
-dcl have_had_current bit (1) init ('0'b);
-dcl have_had_title bit (1) init ('0'b);
-dcl max_cc fixed bin (15) init (0);
-dcl flag_after bit (1) init ('0'b); /* A */
-dcl flag_before bit (1) init ('0'b); /* B */
-dcl flag_current bit (1) init ('0'b); /* C */
-dcl flag_desc bit (1) init ('0'b); /* D */
-dcl flag_flush bit (1) init ('0'b); /* F */
-dcl flag_nonzero bit (1) init ('0'b); /* N */
-dcl flag_parm bit (1) init ('0'b); /* P */
-dcl flag_zero bit (1) init ('0'b); /* Z */
-
-dcl desc_max fixed bin (31) static init (255);
-dcl desc_used fixed bin (31) init (0);
-dcl 1 desc_array(desc_max) ctl,
- 2 stepname char (8),
- 2 text char (64) var;
-
-flag_after = (index(param, 'A') ^= 0);
-flag_before = (index(param, 'B') ^= 0);
-flag_current = (index(param, 'C') ^= 0);
-flag_desc = (index(param, 'D') ^= 0);
-flag_flush = (index(param, 'F') ^= 0);
-flag_nonzero = (index(param, 'N') ^= 0);
-flag_parm = (index(param, 'P') ^= 0);
-flag_zero = (index(param, 'Z') ^= 0);
-
-if ^flag_after &
- ^flag_before &
- ^flag_current then
- flag_before = '1'b;
-
-if flag_desc then
- call load_desc_array();
-
-jctx_ptr = char3_to_ptr(jct.jctjctx);
-act_ptr = char3_to_ptr(jct.jctactad);
-
-put skip edit(ssib.ssibjbid,
- jct.jctjname, 'run on',
- jct.jmrjmrjd, 'by',
- jct.jctuser)
- (a, x(1),
- a, x(1), a, x(1),
- p'99v.999', x(1), a, x(1),
- a);
-
-call print_accounting();
-
-sct_ptr = char3_to_ptr(jct.jctsdkad);
-
-do while(sct_ptr ^= ptrvalue(0));
- sctx_ptr = char3_to_ptr(sct.sctx_pch);
- if unspec(substr(sctcdent(8), 1, 1)) & '04'bx then
- do;
- if ^have_had_title then
- call print_title();
-
- put skip edit(sctsclpc,
- sctsname,
- sctpgmnm)
- (a, x(1),
- a, x(1),
- a, x(1));
- put edit('ABENDed')
- (a, x(1));
-
- if flag_desc then
- call print_desc();
-
- if flag_parm then
- call print_parm();
- end;
- else
- if sctstend & '80'bx then /* started */
- if sctstend & '40'bx then /* ended */
- do;
- if flag_before then
- if (flag_zero & sctsexec = 0) |
- (flag_nonzero & sctsexec ^= 0) then
- do;
- if ^have_had_title then
- call print_title();
-
- put skip edit(sctsclpc, sctsname, sctpgmnm)
- (a, x(1), a, x(1), a, x(3));
- put edit(sctsexec)
- (p'zzzz9');
-
- if flag_desc then
- call print_desc();
-
- if flag_parm then
- call print_parm();
- end;
-
- if sctsexec > max_cc then
- max_cc = sctsexec;
- end;
- else
- do;
- if flag_current then
- do;
- if ^have_had_title then
- call print_title();
-
- put skip edit(sctsclpc, sctsname, sctpgmnm)
- (a, x(1), a, x(1), a, x(9));
-
- if flag_desc then
- call print_desc();
-
- if flag_parm then
- call print_parm();
- end;
-
- have_had_current = '1'b;
- end;
- else /* not started */
- if have_had_current then
- if flag_after then
- do;
- if ^have_had_title then
- call print_title();
-
- put skip edit(sctsclpc, sctsname, sctpgmnm)
- (a, x(1), a, x(1), a, x(9));
- if flag_desc then
- call print_desc();
-
- if flag_parm then
- call print_parm();
- end;
- else
- do;
- end;
- else
- if flag_flush then
- do;
- if ^have_had_title then
- call print_title();
-
- put skip edit(sctsclpc, sctsname, sctpgmnm)
- (a, x(1), a, x(1), a, x(1));
- put edit('Flushed') (a, x(1));
-
- if flag_desc then
- call print_desc();
-
- if flag_parm then
- call print_parm();
- end;
-
- sct_ptr = char3_to_ptr(sct.sctansct);
-end;
-
-if have_had_title then
- put skip edit((69)'-')(a);
-
-put skip edit('Maximum completion code was', max_cc)
- (a, x(2), p'zzzz9');
-
-if jctjstat & '08'bx then
- do;
- put skip edit('The job ABENDed', abend_code(jctacode))
- (a, x(1), a);
- end;
-
-print_parm: proc;
-dcl ix fixed bin (31);
-
-ix = index(sctxparm, '00'x);
-if ix = 0 then
- sctxparm_v = sctxparm;
-else
- sctxparm_v = substr(sctxparm, 1, ix);
-
-put skip list('PARM=' || sctxparm_v);
-end print_parm;
-
-print_desc: proc;
-dcl ix fixed bin (31);
-
-do ix = 1 to desc_used while(sct.sctsname ^= desc_array(ix).stepname);
-end;
-
-if ix <= desc_used then
- put edit(desc_array(ix).text) (x(1), a);
-end print_desc;
-
-char3_to_ptr: proc(ch3) returns(ptr);
-dcl ch3 char (3);
-
-dcl 1 * union,
- 2 wp ptr,
- 2 *,
- 3 * char (1) init ('00'x),
- 3 * char (3) init (ch3);
-
-return(wp);
-end char3_to_ptr;
-
-load_desc_array: proc;
-dcl sysin file input record sequential;
-dcl (undf,eof) bit (1) init('0'b);
-
-on undefinedfile(sysin) undf = '1'b;
-on endfile(sysin) eof = '1'b;
-
-dcl sysin_rec char (80);
-dcl ix fixed bin (31);
-
-open file(sysin);
-
-if undf then
- do;
- put skip list('Unable to open SYSIN');
- stop;
- end;
-
-read file(sysin) into(sysin_rec);
-if eof then
- do;
- put skip list('No records in SYSIN');
- stop;
- end;
-
-alloc desc_array;
-
-do while(^eof);
- ix = index(sysin_rec, ',');
-
- if ix > 1 & ix <= 9 then
- do;
- desc_used = desc_used + 1;
- desc_array(desc_used).stepname = substr(sysin_rec, 1, ix - 1);
- desc_array(desc_used).text = substr(sysin_rec, ix + 1, 64);
- end;
- else
- do;
- put skip list('Invalid record in SYSIN');
- stop;
- end;
-
- read file(sysin) into(sysin_rec);
-end;
-
-close file(sysin);
-end load_desc_array;
-
-abend_code: proc(ch4) returns(char(5));
-dcl ch4 char (4);
-dcl w4b fixed bin (31);
-dcl w4 char (4) based(addr(w4b));
-dcl p4 pic '9999';
-
-unspec(w4) = unspec(ch4) & '00fff000'bx;
-if unspec(w4) then
- do;
- return('S' || substr(hex(w4), 3, 3));
- end;
-else
- do;
- unspec(w4) = unspec(ch4) & '00000fff'bx;
- p4 = w4b;
- return('U' || p4);
- end;
-end abend_code;
-
-hex: proc(ch_string) returns(char(100) var);
-dcl ch_string char (*);
-dcl hex_string char (100) var init ('');
-
-hex_string = heximage(addr(ch_string), stg(ch_string));
-return(hex_string);
-end hex;
-
-ch1_to_fb31: proc(ch1) returns(fixed bin(31));
-dcl ch1 char (1);
-dcl 1 * union,
- 2 fb31 fixed bin (31),
- 2 *,
- 3 * char (3) init ('000000'x),
- 3 * char (1) init (ch1);
-
-return(fb31);
-end ch1_to_fb31;
-
-print_accounting: proc;
-dcl (nf, nc) fixed bin (31);
-dcl p ptr;
-dcl 1 actfield based(p),
- 2 len char (1),
- 2 rest char (144);
-dcl w_account char (100) var init ('');
-dcl ix fixed bin (31);
-
-nf = ch1_to_fb31(act.actjnfld);
-p = addr(actaccnt);
-
-do ix = 1 to nf;
- nc = ch1_to_fb31(actfield.len);
- w_account = w_account || substr(actfield.rest, 1, nc);
-
- if ix < nf then
- w_account = w_account || ',';
-
- p = ptradd(p, nc + 1);
-end;
-
-w_account = '(' || w_account || ')';
-
-put edit(w_account, '''' || actprgnm || '''')
- (x(1), a, x(1), a);
-end print_accounting;
-
-print_title: proc;
- put skip edit((69)'-')(a);
- put skip edit('Step', 'Program', 'Code')
- (x(9), a(8), x(1), a(8), x(4), a(4));
- have_had_title = '1'b;
-end print_title;
-end steps;
-/* Old JCL skeleton **************************************************
-//.*******************************************************************
-//. Create .STEPS dataset containing summary of job steps
-//.*******************************************************************
-//#440 EXEC PGM=STEPS,COND=EVEN,
-// PARM='/B D N' Before Desc Nonzero
-//SYSPRINT DD DSN=&SYSUID..&MEM..STEPS,
-// DISP=(,CATLG),
-// UNIT=SYSDA
-// SPACE=(TRK,(2,1),RLSE),
-// DCB=(RECFM=VBA,LRECL=125,BLKSIZE=0)
-//SYSIN DD *
-A&MEM7,Find PLI program (&MEM)
-B&MEM7,PLI Compiler (Macro/Include) (&MEM)
-V&MEM7,IDMS Special Versions (&MEM)
-C&MEM7,IDMS Preprocessor (&MEM)
-D&MEM7,DB2 Precompiler (&MEM)
-Z&MEM7,CICS Preprocessor (&MEM)
-E&MEM7,PLI Compiler (Compile) (&MEM)
-F&MEM7,InterTest Postprocess listing (&MEM)
-G&MEM7,Find LEL (&MEM)
-H&MEM7,Link Edit Load module (&MEM)
-K&MEM7,InterTest Postprocess linkedit (&MEM)
-**********************************************************************/
No clue if it can handle stuff that requires SWAREQ, looks like not.
Remove all the "-" asa characters, I added them to keep the formatting.
Robert
On 2018-11-26 23:57, Bernd Oppolzer wrote:
Sorry, this did not come to my mind, because the code appeared in a public forum
...
this is the link where I found it:
https://www.developpez.net/forums/d1477375/systemes/autres-systemes/z-os/jcl-sort/recuperation-code-retour-d-job-rexx/
If I find a snippet of code THAT OPEN on the internet,
I normally don't care much about copyright,
because IMO the original poster also didn't.
But maybe that's too simple minded.
Thanks for your advice
Kind regards
Bernd
Am 27.11.2018 um 00:46 schrieb Arthur:
On 26 Nov 2018 13:03:55 -0800, in bit.listserv.ibm-main
(Message-ID:<fa6e347f-8acd-08fb-64dc-97ce563d6...@t-online.de>)
bernd.oppol...@t-online.de (Bernd Oppolzer) wrote:
using this as keyword and a well known search engine,
I found a REXX (from a french site), which I will try tomorrow.
This could be of interest to others, so here is the REXX (unedited, no
warranty),
including some original french comments:
A link, instead of copying the code, would have been better. If the code
hasn't been marked as free to use and copy, this is a possible copyright
violation. Just as bad, the person who wrote this code has gotten no
recognition for it, which is a probable violation even if it was covered by a
Creative Commons license. And, if the coder improves the program, people who
take the code from IBM-Main will not have those improvements.
I like the idea of having code where it can be found. A few programs on the
CBT tape are mine. But I *chose* to submit them, and they have my name on
them. Just because it's on the Internet does not mean it's not copyright.
OTOH, I congratulate you on finding this code, and thank you for letting us
all know it exists.
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to lists...@listserv.ua.edu with the message: INFO IBM-MAIN
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to lists...@listserv.ua.edu with the message: INFO IBM-MAIN
--
Robert AH Prins
robert.ah.prins(a)gmail.com
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to lists...@listserv.ua.edu with the message: INFO IBM-MAIN
