/* */
trace off
parse upper arg Source Coverage .

Lib     = 'USR1.NEWPROD'
Machine = 'Y2KUNIT'

Fm = 'A'                           /* Assume A disk */
IF userid() = 'UMFRUN' then Fm = 'E'

IF Coverage ^= 'NO' then Coverage = 'YES'
IF Source = '' then signal GetInfo
Phase = Source
signal Begin
GetInfo:
say 'Enter Source'
pull Source
IF Source = '' then exit 69
say 'Enter Phase/Object name. Default is' Source
pull Phase
IF Phase = '' then Phase = Source
say 'Add coverage code? YES/NO default is YES'
pull Coverage
IF Coverage = '' then Coverage = 'YES'

Begin:
'SET IMSG OFF'
'SET EMSG OFF'
'ERASE GENCOV $TEMP2$ A'
'SET IMSG ON'
'SET EMSG ON'
'STATE' Source 'OUTCOB F'
IF rc ^= 0 then do
   say Source 'OUTCOB F not found'
   exit 69
end

'ERASE' Source 'COVCOB' Fm

In_EXEC = 'NO'                              /* Not in EXEC-CICS  */
PEnv    = 'BATCH'
Ptype   = 'MAIN'
DLI     = 'NO'
StartWord = 'PROCEDURE'
'pipe < ' Source ' OUTCOB F | locate /DLITCBL/ | VAR dli_found'
IF pos('DLITCBL',dli_found) > 0 then do
   DLI = 'YES'
   StartWord = 'ENTRY'
end
Space40 = '                                        '
IF  Source = 'BCGCCR87' | Source = 'ABEND' then PType = 'SUB'
Sub   =  -1
/*
say 'Source ' Source ' type ' Ptype ' phase ' Phase ' coverage code ' Coverage
*/
/* Get program source into variables */
'EXECIO * DISKR ' Source ' OUTCOB F (STEM ILINE.'

/* Process source */

DO i = 1 to iline.0
   IF substr(iline.i,7,1) ^= ' ' then do
      call CopyLine
   end
   ELSE do
     FirstWord = word(substr(iline.i,8),1)
     Col80     = substr(iline.i,80,1)
     call TestLine
   end
end

/* Add Coverage initialise and report code */
IF Coverage = 'YES' then do
   aline = '       ITD--INIT-COVERAGE SECTION.'
   call AddLine
   aline = '           MOVE LOW-VALUES TO ITD--COVERAGE-TABLE.'
   call AddLine
   aline = '           MOVE SPACES     TO ITD--COVERAGE-TEXT.'
   call AddLine
   aline = "           MOVE "  "'"||Source||"'"  " TO ITD--PROGRAM."
   call Addline
   aline = '           MOVE ' Sub ' TO ITD--LAST-VERB.'
   call AddLine
   'EXECIO 0 DISKW ' Source ' COVCOB' Fm '(FINIS'
   'COPY GENCOV $TEMP2$ A' Source ' COVCOB' Fm '(APP'
   aline = '       ITD--INIT-COVERAGE-EXIT.  EXIT.'
   call AddLine
   'EXECIO 0 DISKW ' Source ' COVCOB' Fm '(FINIS'
   'COPY GENCPD DATA J' Source ' COVCOB' Fm '(APP'
   IF Penv = 'BATCH' then 'COPY GENCPDB DATA J' Source 'COVCOB' Fm '(APP'
   IF Penv = 'CICS'  then 'COPY GENCPDC DATA J' Source 'COVCOB' Fm '(APP'
end

/* Submit compilation */
'CP SP PU' Machine 'CONT'
call StartJCL
'PUNCH GENCOV $TEMP$ A (NOH'
'PUNCH' Source 'COVCOB' Fm '(NOH'
call EndJCL
'PUNCH GENCOV $TEMP$ A (NOH'
'CP SP PU CLOSE'
'CP SP PU NOCONT'
'CP SP PU OFF'
'ERASE GENCOV $TEMP$ A'
'ERASE GENCOV $TEMP2$ A'
exit


StartJCL:
'ERASE GENCOV $TEMP$ A'
IF PType = 'MAIN' & PEnv  = 'BATCH' then do
   queue "* $$ JOB JNM="Source",CLASS=0,DISP=D,FROM="userid()
   queue "* $$ LST RBS=0,JSEP=0,CLASS=A,DEST=(,"userid()")"
   queue "// JOB" Source "- COMPILE COBOL TO PHASE"
   queue "// OPTION SYM,NODECK,NOLOG,CATAL"
   queue " PHASE" Phase",*"
   /*  call Chk24  */
   queue "// LIBDEF *,SEARCH=("Lib",PRD2.SCEEBASE,PRD2.RWPREC,PRD2.RWRUN)"
   queue "// LIBDEF PHASE,CATALOG="Lib
   queue "// EXEC IGYCRCTL,SIZE=512K,                                            *"
   queue "               PARM='EXIT(INEXIT(RW),PRTEXIT(RW)'"
   queue " CBL SEQ,FLAG(W,E),MAP,APOST,TRUNC(STD),ZWB,NOOPT,LIB,OFFSET"
   queue " CBL TEST(SYM)"
end
IF PType = 'SUB' then do
   queue "* $$ JOB JNM="Source",CLASS=0,DISP=D,FROM="userid()
   queue "* $$ LST CLASS=A,DEST=(,"userid()"),JSEP=0,RBS=0"
   queue "* $$ PUN DISP=I,CLASS=U,PRI=3"
   queue "// JOB "Source" - COMPILE COBOL TO OBJECT"
   queue "// OPTION DECK,NOLIST,NOLOG"
   queue "// EXEC ASMA90"
   queue " PUNCH '* $$ LST JSEP=0,RBS=0,CLASS=A,DEST=(,"userid()")'"
   queue " PUNCH '// JOB" Source "- CATALOG TO OBJECT'"
   queue " PUNCH '// EXEC LIBR,SIZE=512K'"
   queue " PUNCH '  ACCESS S="Lib"'"
   queue " PUNCH '  CATALOG "Source".OBJ REPLACE=YES'"
   queue " END"
   queue "/*"
   queue "// OPTION SYM,DECK,NOLOG,LIST"
   queue "// LIBDEF *,SEARCH=("Lib",PRD2.SCEECICS,PRD2.SCEEBASE)"
   queue "// EXEC IGYCRCTL,SIZE=IGYCRCTL"
   queue " CBL SEQ,FLAG(W,E),MAP,APOST,TRUNC(STD),ZWB,NOOPT,LIB,OFFSET"
   queue " CBL TEST(SYM)"
end
IF PEnv  = 'CICS' then do
   queue "* $$ JOB JNM="Source",CLASS=0,DISP=D,FROM="userid()
   queue "* $$ LST CLASS=A,DEST=(,"userid()"),JSEP=0,RBS=0"
   queue "* $$ PUN DISP=I,CLASS=U,PRI=3"
   queue "// JOB "Source "- TRANSLATE COBOL CICS SOURCE"
   queue "// OPTION DECK,NOLIST,NOLOG"
   queue "// EXEC ASMA90"
   queue " PUNCH '* $$ LST JSEP=0,RBS=0,CLASS=A,DEST=(,"userid()")'"
   queue " PUNCH '// JOB "Source" - COMPILE TRANSLATED COBOL CICS SOURCE'"
   queue " PUNCH '// OPTION SYM,NODECK,NOLOG,CATAL'"
   queue " PUNCH '// LIBDEF *,SEARCH=("Lib",PRD2.SCEECICS,PRD2.SCEEBASE)'"
   queue " PUNCH '// LIBDEF PHASE,CATALOG="Lib"'"
   queue " PUNCH ' PHASE" Phase",*'"
   queue " PUNCH ' INCLUDE DFHELII'"
   queue " PUNCH '// EXEC IGYCRCTL,SIZE=IGYCRCTL'"
   queue " PUNCH ' CBL SEQ,FLAG(W,E),MAP,APOST,TRUNC(STD),ZWB,NOOPT,LIB,OFFSET'"
   queue " PUNCH ' CBL RENT,RMODE(ANY)'"
   queue " END"
   queue "/*"
   queue "// EXEC DFHECP1$"
   queue " CBL XOPTS(CICS NOSOURCE NONUM NOSEQ OPTIONS APOST ANSI85)"
end

'EXECIO' queued() 'DISKW GENCOV $TEMP$ A (FINIS'
return

EndJCL:
'ERASE GENCOV $TEMP$ A'
IF PType = 'MAIN' & PEnv  = 'BATCH' then do
   queue "/*"
   queue "// LIBDEF *,SEARCH=("Lib",PRD2.SCEEBASE,PRD2.RWPREC,PRD2.RWRUN)"
   IF DLI = 'YES' then queue " ENTRY DLITCBL"
   queue "// EXEC LNKEDT,SIZE=512K"
   queue "/*"
   queue "/&"
   queue "* $$ EOJ"
end
IF PType = 'SUB' then do
   queue "/*"
   queue "// OPTION DECK,NOLIST,NOLOG"
   queue "// EXEC ASMA90"
   queue " PUNCH '/+'"
   queue " PUNCH '/*'"
   queue " PUNCH '/&&'"
   queue " PUNCH '* $$ EOJ'"
   queue " END"
   queue "/*"
   queue "/&"
   queue "* $$ EOJ"
end
IF PEnv  = 'CICS' then do
   queue "/*"
   queue "// EXEC ASMA90"
   queue " PUNCH '/*'"
   queue " PUNCH '// LIBDEF *,SEARCH=("Lib",PRD2.SCEECICS,PRD2.SCEEBASE)'"
   queue " PUNCH '// EXEC LNKEDT,SIZE=512K'"
   queue " PUNCH '/*'"
   queue " PUNCH '/&&'"
   queue " PUNCH '* $$ EOJ'"
   queue " END"
   queue "/*"
   queue "// IF $MRC >= 5 THEN"
   queue "// GOTO ABEND"
   queue "// GOTO END"
   queue "/. ABEND"
   queue "*  *****************************"
   queue "*  TRANSLATOR FAILED WITH ERRORS"
   queue "*  *****************************"
   queue "/. END"
   queue "/*"
   queue "/&"
   queue "* $$ EOJ"
end

'EXECIO' queued() 'DISKW GENCOV $TEMP$ A (FINIS'
return

TestLine:
IF FirstWord = 'WORKING-STORAGE' then do
   call CopyLine
   IF Coverage = 'YES' then do
      'EXECIO 0 DISKW ' Source ' COVCOB' Fm '(FINIS'
      'COPY GENCWS DATA J' Source ' COVCOB' Fm '(APP'
   end
   return
end

IF FirstWord = StartWord then do
   Sub = 0
   call CopyLine
   aline = '                                        PERFORM ITD--INIT-COVERAGE.'
   call AddLine
   return
end

IF Sub = -1 then do
   call CopyLine
   return
end

IF FirstWord = 'EXEC' then do
   In_EXEC = 'YES'
   PEnv  = 'CICS'
   call AnalEXEC
   return
end

IF In_EXEC = 'YES' then do
   call CopyLine
   DO j = 1 to 30
      IF word(iline.i,j) = '' then leave
      IF strip(word(iline.i,j),,'.') = 'END-EXEC' then do
         In_EXEC = 'NO'
      end
   end
   return
end

IF FirstWord = 'GOBACK' |  FirstWord = 'GOBACK.' | FirstWord = 'STOP'  then do
   call AddCover
   call AddReport
   call CopyLine
   return
end

IF FirstWord = 'CALL' then do
   IF word(substr(iline.i,8),2) ="'ABEND'" then do
      call AddCover
      call AddReport
   end
   ELSE do
      call AddCover
   end
   call CopyLine
   return
end

IF FirstWord = 'GOBACK' |  FirstWord = 'GOBACK.' | FirstWord = 'STOP'  then do
   call AddCover
   call AddReport
end

Verb = 'Y'
call ChkVerb
IF Verb = 'N' then do
   call CopyLine
   return
end

call AddCover
call CopyLine
return

ChkVerb:
IF FirstWord = 'MOVE' then return
IF FirstWord = 'IF' then return
IF FirstWord = 'PERFORM' then return
IF FirstWord = 'ACCEPT' then return
IF FirstWord = 'ADD' then return
IF FirstWord = 'ALTER' then return
IF FirstWord = 'CLOSE' then return
IF FirstWord = 'COMPUTE' then return
IF FirstWord = 'DELETE' then return
IF FirstWord = 'DISPLAY' then return
IF FirstWord = 'DIVIDE' then return
IF FirstWord = 'EVALUATE' then return
IF FirstWord = 'EXAMINE' then return
IF FirstWord = 'EXHIBIT' then return
IF FirstWord = 'GENERATE' then return
IF FirstWord = 'GO' then return
IF FirstWord = 'INITIALIZE' then return
IF FirstWord = 'INITIATE' then return
IF FirstWord = 'INSERT' then return
IF FirstWord = 'INSPECT' then return
IF FirstWord = 'MULTIPLY' then return
IF FirstWord = 'ON' then return
IF FirstWord = 'OPEN' then return
IF FirstWord = 'READ' then return
IF FirstWord = 'READY' then return
IF FirstWord = 'REWRITE' then return
IF FirstWord = 'SEARCH' then return
IF FirstWord = 'SEEK' then return
IF FirstWord = 'SEND' then return
IF FirstWord = 'SERVICE' then return
IF FirstWord = 'SET' then return
IF FirstWord = 'SORT' then return
IF FirstWord = 'START' then return
IF FirstWord = 'STRING' then return
IF FirstWord = 'SUBTRACT' then return
IF FirstWord = 'TERMINATE' then return
IF FirstWord = 'TRANSFORM' then return
IF FirstWord = 'UNSTRING' then return
IF FirstWord = 'WRITE' then return
Verb = 'N'
return

AddCover:
IF Coverage = 'NO' then return
Sub = Sub + 1
aline = Space40||'ADD +1 TO ITD--USED ('Sub')'
call AddLine
IF Col80 = ' ' then return
CovLine = left(Space40||"MOVE" "'"Col80"'" "TO ITD--COL80 ("Sub").                         ",72)||'COVERAGE'
'EXECIO 1 DISKW GENCOV $TEMP2$ A (FINIS VAR COVLINE'
return

AddReport:
IF Coverage = 'NO' then return
aline = Space40||'PERFORM ITD--REPORT-COVERAGE'
call Addline
return

AddLine:
IF Coverage = 'NO' then return
aline = left(aline'                                                                        ',72)||'COVERAGE'
'EXECIO 1 DISKW ' Source ' COVCOB' Fm '(VAR ALINE'
return

CopyLine:
IF Coverage = 'NO' | Sub < 1 | substr(iline.i,7,1) ^= ' ' then do
   oline = iline.i
end
ELSE do
   VerbNo = right('0000000'Sub,7)
   oline = left(iline.i,72)||VerbNo||Col80
end
'EXECIO 1 DISKW ' Source ' COVCOB' Fm '(VAR OLINE'
return

Chk24:
IF source = '???????' then queue ' MODE AMODE(24) RMODE(24)'
return

AnalEXEC:
/* Check for END-EXEC on same line */
EXEC_Line = substr(iline.i,8)
DO j = 1 to 30
   Temp = strip(word(EXEC_Line,j),,'.')
   IF Temp = '' then leave
   IF Temp = 'END-EXEC' then do
      In_EXEC = 'NO'
      leave
   end
end

/* Parse to END-EXEC */
m      = 0
EXEC.0 = 0
DO j = 0 to 50
   k = i + j
   EXEC_Line = substr(iline.k,8)
   DO l = 1 to 30
      IF word(EXEC_Line,l) ^= '' then do
         m      = m + 1
         EXEC.0 = m
         EXEC.m = strip(word(EXEC_Line,l),,'.')
      end
      IF EXEC.m = 'END-EXEC' then leave
   end
   IF EXEC.m = 'END-EXEC' then leave
end
/* Check Function code */
CICS_Function = EXEC.3
IF CICS_Function = 'ABEND' | CICS_Function = 'RETURN' | CICS_Function = 'XCTL' then do
   call AddCover
   call AddReport
   call CopyLine
   return
end
IF CICS_Function ^= 'SEND' then do
   call AddCover
   call CopyLine
   return
end
/* But is it EXEC CICS SEND PAGE RELEASE */
IF EXEC.4 = 'PAGE' & EXEC.5 = 'RELEASE' then do
   call AddCover
   call AddReport
   call CopyLine
   return
end

call AddCover
call CopyLine
return

© Copyright IT Doctors.co.uk. 2002