/* Rexx  - Add a tag to changed lines: Syntax tag tag col1          */
/*         Tag is required, col1 defaults to 65                     */
/*                                                                  */
/*  Author:Doug Nadel  nadel@US.IBM.COM                             */
/*                                                                  */
/*  (C) Copyright IBM corp., 1999 - All rights reserved             */
 
unitname='VIO'       /* For temp data sets - Change this if needed  */
show_context = 3     /* num of lines above and below changes to show.*/
                     /* Set_show context to 0 to show all lines after*/
                     /* tagging is complete                          */
 
Address 'ISPEXEC'
Numeric Digits 12
'ISREDIT MACRO (TAG,COL1)'
Signal on Novalue
Signal on Syntax
Parse Source system . cmdname .
'ISREDIT (DW) = data_width'
supercrc=-1
If tag='' Then   /* Insure tag was given */
  Do
    Call setmsg '* YES $ Syntax: 'cmdname' TAG <col1>'
    Exit 12
  End
If col1='' Then col1=65
If 0=datatype(col1,'N') Then /* Insure col1 is a number */
  Do
    Call setmsg '* YES Invalid start col $ Syntax: 'cmdname' TAG <col1>'
    Exit 12
  End
If col1 + length(tag)-1>dw Then  /* Insure tag will fit */
  Do
    Call setmsg '* YES Invalid start col $ Syntax: 'cmdname' TAG <col1>'
    Exit 12
  End
 
Call allocates    /* Allocate datasets for superc */
'SELECT PGM(ISRSUPC) PARM(LINECMP,NOLISTL,UPDLDEL)'      /* Compare */
supercrc=rc
If supercrc<5 & supercrc>0 Then
  Call add_tags
Else If supercrc>4 Then
  Do
    Call setmsg 'ISR313B0 YES SuperC Error$'||,
                'SuperC ended with a return code of ' supercrc
  End
If supercrc =1 Then
  Call setmsg '* NO Tagging complete$Added ;'tag' in column 'col1
Else If supercrc =0 Then
  Call setmsg '* NO No tags added$No additions or changed lines found.'
Address tso 'FREE F(NEWDD,OLDDD,DELDD)'
 
Exit 0
 
/*------------------ Process rexx syntax errors --------------------*/
Syntax:
 Say 'Syntax signalled at line 'sigl' of 'cmdname
 Say sourceline(sigl)
 Say copies('-',78)
 Exit 4
 
/*------------------ Process rexx novalue errors -------------------*/
Novalue: 
 Say 'NoValue signalled at line 'sigl
 Say sourceline(sigl)
 Parse Source . . cmdname .
 Say translate(cmdname) 'is an ISPF edit macro and must be invoked',
     'as an ISPF edit primary command.'
 Exit 12 
 
add_tags:
/*-------------------------- Read delta file ----------------------*/
'ISREDIT RESET'
'ISREDIT RESET LAB'
'ISREDIT X ALL .ZF .ZL'
Do queued();Pull;End
compline.=''
compline.0=0
Address tso 'EXECIO * DISKR DELDD (FINIS STEM COMPLINE.'
 
Address isredit
Do a=1 to compline.0  /* Unexclude changed lines */
  line = compline.a
  Parse Var line 1 type 3 . 13 rec_count 19 . 29 line_number 35 .
  SELECT 
    When (type='*H') Then /* Header */
      Nop;
    When (type='*M') Then /* Match  */
      a=a + rec_count     /* skip matches*/
    When (type='*I') Then
      Do 
        Do lineno=line_number to line_number+rec_count-1
          'XSTATUS 'lineno' = NX'
        End
        a=a + rec_count     /* Skip inserts*/
      End
    When (type='*D') Then
      a=a + rec_count     /* Skip deletes*/
    Otherwise
      Do 
        Say 'Unrecognized control type "'type'" in update file at line',
         a
        Exit 4
      End
  End        /* End of SELECT */
End
/* Now add tags to unexcluded lines and process failures */
"CHANGE '"copies(' ',length(tag))"' '"tag"' "col1 "ALL NX"
If rc>0 Then
  Do
     Call setmsg '* NO Tagging error$'||,
          'Tags could not be added to one or more lines.'
  End
If show_context > 0 Then
  Do
    Address ispexec 'CONTROL ERRORS RETURN'
    'ISREDIT (LAST) = LINENUM .ZLAST'
    nxlist = ''
    Do a=1 to last
      '(XT) = XSTATUS 'a
      If xt='NX' Then nxlist=nxlist a
    End
    Do While nxlist \= ''
      Parse Var nxlist currentline nxlist
      Do a = currentline-show_context to currentline+show_context
        'XSTATUS 'a' = NX'
      End
    End
    Address ispexec 'CONTROL ERRORS CANCEL'
  End
Else
  'RESET'
"FIND ALL NX '"tag"' "col1  /* Find and Highlight changes */
Return
 
 
/*********************** Findmem *************************************/
 
findmem: Procedure   /* Find where the member exists in concatenation*/
  'ISREDIT (DATAID) = DATAID'
  zdsn.=''
  tfdp = 140+ptr(76+ptr(640+ptr(ptr(24+ptr(112+ptr(132+ptr(540)))))))
  Do a=1 to 4
    Parse Value storage(d2x(ptr((a-1)*4+tfdp)),46) With d 3 n
    If d>'0000'x Then zdsn.a="'"strip(n)
  End
  zllib=1;corg = 'PS'
  'LMOPEN DATAID('dataid') ORG(CORG)' /* Find current data set */
  If Arg(1)^='' & corg='PO' Then
    'LMMFIND dataid('dataid') MEMBER('Arg(1)') STATS(YES)'
  'LMCLOSE dataid('dataid')'
  Return_dsn=zdsn.zllib
  If Arg(1)='' Then Return_dsn=Return_dsn"'"   /* No member name */
  Else Return_dsn=Return_dsn'('Arg(1)")'"
  Return_dsn=translate(Return_dsn)
Return Return_dsn
 
 
 
/************************** Allocates *******************************/
allocates: Procedure Expose curdsn unitname
  'ISREDIT (LRECL) = LRECL'
  'ISREDIT (CMEM)  = MEMBER'
  'ISREDIT (RECFM) = RECFM'
  If recfm='V' Then lrecl=lrecl+4
  curdsn=findmem(cmem)
  Address tso 'ALLOC F(OLDDD) SHR DSNAME('curdsn') REUSE'
  If rc=0 Then
    Address tso 'ALLOC F(NEWDD) NEW DEL DSORG(PS) REUSE
               LRECL('lrecl') RECFM('recfm' B) BLKSIZE(0)
               UNIT('unitname') SP(1,10) TRACKS'
  If rc>0 Then /* Temp allocation not OK? */
    Do;
      Call setmsg '* YES Allocation failed$'||,
                  'Temporary data set could not be allocated.'
      Exit 1
    End; 
  Else /* Temp file exists - Copy current contents to temp file*/
    Do
      'LMINIT DATAID(D) DDNAME(NEWDD) ENQ(EXCLU)'
      'LMOPEN DATAID(&D) OPTION(OUTPUT)'
      Address isredit '(LAST) = LINENUM .ZL'
      Do a = 1 to last
        Address isredit '(LINE) = LINE' a
        "LMPUT DATAID(&D) MODE(INVAR) DATALOC(LINE) DATALEN("||,
               length(line)')'
      End
      'LMFREE DATAID(&D)'
    End
  Address tso
  'ALLOC FILE(SYSIN) DUMMY REUSE'
  'ALLOC NEW FILE(DELDD) LRECL(255) BLKSIZE(6120) RECFM(F B) DSORG(PS)
       TRACK UNIT('unitname') SPACE(5,10) REUSE'
Return
ptr: Return c2d(bitand(storage(d2x(Arg(1)),4),'7FFFFFFF'x))
setmsg: /* Process all SETMSG requests as conditional setmsgs */
   Parse Arg zerrhm zerralrm zerrsm'$'zerrlm
   Address ispexec 'SETMSG MSG(ISRZ002) COND'
Return