/* rexx */
/**********************************************************************/
/*  Library clean utiltity. Compare the directories of two PDS'.      */
/*  Optionally delete members, compare members, etc.                  */
/*                                                                    */
/*  Written by: Rob Wunderlich 4/93                                   */
/*                                                                    */
/*MM/YY VER WHO                                                       */
/*----- --- ---                                                       */
/*02/95 1.3 DAL Added EN and EO commands to edit members and improved */
/*              the leap year logic and added vputs to main panel     */
/*              to save dataset names in the pool.                    */
/*03/94 1.2 RBW Added logic to disallow commands against "OLD" lib    */
/*              when using an unmatched list.                         */
/*03/94 1.1 RBW Distributed Public Domain version 1.1.                */
/**********************************************************************/
lc_version = '1.3'                /* LIBCLEAN version */
/*    *    *    *    Establish Error Traps    *    *    *    *    *   */
call on error name errproc
call on failure name errproc
signal on syntax name errproc
signal on novalue name errproc
signal on halt name haltproc
address ispexec "control errors return"
/**********************************************************************/
/*                                                                    */
/**********************************************************************/
/*  if left(sysvar('SYSUID'),3) ¬= 'WTS'
    then do
      say 'You not authorized to use LIBCLEAN'
      exit 8
    end                       */

flag = ''
newsize = ''; newdate = ''; newid = 'LMOD'
oldsize = ''; olddate = ''; oldid = 'LMOD'
disp_restore = 0
alloc_done = 0
delcount = 0
matchcnt = 0
sysmembers = 0
input_count = 0
get_out = 0

do forever
  address ispexec

  ok='0 8';"DISPLAY PANEL(LIB@CLN1)"
  if rc = 8
    then exit
  if matchopt = 'U'              /* If option unmatched, */
    then oldid = ''              /*  then clear default id */
  if matchopt = 'M'
    then matchtxt = '   Matches:'
    else matchtxt = 'Nonmatches:'
  rc = LISTDSI(newdsn 'DIRECTORY')
  statmsg = 'Member list compare in progress...'
  "CONTROL DISPLAY LOCK"
  "DISPLAY PANEL(  )"            /* tell user work is in progress */

  ok=0;"TBCREATE MEMTBL NOWRITE KEYS(MEMBER)" ,
     "NAMES(NEWSIZE OLDSIZE NEWDATE OLDDATE NEWID OLDID FLGDATE)"
  ok=0;"LMINIT DATAID(OLDLIB) DATASET("olddsn") ENQ(SHRW)"
  ok=0;"LMINIT DATAID(NEWLIB) DATASET("newdsn") ENQ(SHRW)"
  ok=0;"LMOPEN DATAID("oldlib") OPTION(INPUT) RECFM(ORECFM) ORG(OORG)"
  ok=0;"LMOPEN DATAID("newlib") OPTION(INPUT) RECFM(NRECFM) ORG(NORG)"
  if oorg ¬= 'PO' ¦ norg ¬= 'PO'
  then do
    say '*** ERROR - NewLib or OldLib not partitioned.'
    call cleanup_after_error
  end
  if orecfm = 'U' ¦ nrecfm = 'U'
    then if lmodstat = 'Y'
     then do
       ok=0;address tso "ALLOC FI(OLDLIBDD) DA("olddsn") SHR REUSE"
       ok=0;address tso "ALLOC FI(NEWLIBDD) DA("newdsn") SHR REUSE"
       alloc_done = 1
     end
  else nop


  member = ''         /*    */
  end_of_list = 0     /* Reset end of member list indicator */
  do until end_of_list    /* Do for each member */
    ok='0 8';"LMMLIST DATAID("newlib") MEMBER(MEMBER) STATS(YES)"
    mlist_rc = rc
    input_count = input_count + 1
    if input_count // 10 = 0
    then do
      statmsg2 = 'Member' input_count 'of' sysmembers ,
                 '-' strip(matchtxt,'L') matchcnt
      "CONTROL DISPLAY LOCK"
      "DISPLAY PANEL(  )"            /* tell user work is in progress */
    end
    if mlist_rc = 0
    then do                         /* We have a member from newlib */
      if left(nrecfm,2) = 'FB'
      then do
        newsize = zlcnorc
        newdate = zlmdate
        newid   = zluser
      end


      ok='0 8';"LMMFIND DATAID("oldlib") MEMBER("member") STATS(YES)"
      if rc = 0                     /* Set flag re member found */
        then oldmem_match = 1
        else oldmem_match = 0

      if oldmem_match & matchopt = 'M'     /* If found and looking for */
      then do                              /*  matches */
        if left(orecfm,2) = 'FB'           /* Get oldmem stats */
        then do
          oldsize = zlcnorc
          olddate = zlmdate
          oldid   = zluser
        end
        else if lmodstat = 'Y'
          then do
            ok=0;address tso "FINDMEM" member "OLDLIBDD"
            oldsize = right(c2x(substr(fmdirent,25,3)),6,'0')
            olddate = jul2greg(fmlkeddt)
          end
          else nop
      end               /* End of oldmem stats */


      /* Common actions section */
      if oldmem_match & matchopt = 'M' ¦,
         ªoldmem_match & matchopt = 'U'
      then do
        if lmodstat = 'Y' & nrecfm = 'U'
        then do
          ok=0;address tso "FINDMEM" member "NEWLIBDD"
          newsize = right(c2x(substr(fmdirent,25,3)),6,'0')
          newdate = jul2greg(fmlkeddt)
        end
        matchcnt = matchcnt + 1
        ok=0;"TBADD MEMTBL"
        if olddate = '' ¦ newdate = ''  /* If missing old or new date */
          then flgdate = ''             /*  then skip test */
        else do
          if olddate > newdate
            then flgdate = '>'
            else flgdate = ''
        end

      end     /* End of common actions section */

    end
    if mlist_rc = 8 then end_of_list = 1   /* Indicate no more members */
  end              /* End of do until end_of_list */

  ok='0 8';"LMMLIST DATAID("newlib") OPTION(FREE)"
  ok=0;"LMCLOSE DATAID("newlib")"
  ok=0;"LMCLOSE DATAID("oldlib")"

  ok=0;"LMOPEN DATAID("newlib") OPTION(OUTPUT)"
  ok=0;"LMOPEN DATAID("oldlib") OPTION(OUTPUT)"
  ok=0; address ispexec "TBTOP MEMTBL"
  do forever
    ok='0 4 8';address ispexec "TBDISPL MEMTBL PANEL(LIB@CLN2)"
    if rc = 8 then leave
    i = ztdsels              /* Number of selected rows */
    do i                     /* Do for all selected rows */
      call process_linecmd   /* Go process entered line commands */
      if ztdsels > 1         /* If more than one row selected */
      then do                /*  then go fetch the next row */
        ok='0 4 8';"TBDISPL MEMTBL"
      end
    end
    if zcmd ¬= '' then call process_zcmd  /* If entry in COMMAND line */
    if get_out
      then leave
    ok='0 8';"TBSKIP MEMTBL ROW("ztdtop")"   /* Set top display row */
  end

  ok=0;address ispexec "TBEND MEMTBL"
  ok=0;"LMCLOSE DATAID("oldlib")"
  ok=0;"LMFREE DATAID("newlib")"
  ok=0;"LMFREE DATAID("oldlib")"

  zedsmsg = delcount "members deleted"
  zedlmsg = ''
  ok=0;"SETMSG MSG(ISRZ000)"
end

exit

/**********************************************************************/
/* Line Command Routine                                               */
/**********************************************************************/
process_linecmd:
linecmd = strip(linecmd,'B','_')
member = strip(member,'B')

if matchopt = 'M'
  then, /* Linecmds for MATCHED */
    valid_linecmds = 'BN BO C DN DO EN EO S X'
  else, /* Linecmds for UNMATCHED */
    valid_linecmds = 'BN DN EN S X'

do while wordpos(linecmd,valid_linecmds) = 0 /* Valid line cmds */
  ok = 0;"ADDPOP ROW(7) COLUMN(10)"     /* Set popup mode */
  ok='0 8';"DISPLAY PANEL(LIB@CLN4)"    /* Display command selections*/
  save_rc = rc                          /* Save return code          */
  ok=0;"REMPOP"                         /* Clear popup mode */
  if save_rc = 8                        /* If user pressed END  */
    then return                         /*  then return to caller */
  linecmd = strip(linecmd,'B','_')
end

select

  when linecmd = 'BO' ¦ linecmd = 'BN'
  then do
    ok=0;"CONTROL DISPLAY SAVE"          /* save display environment */
    disp_restore = 1                     /* restore required */
    if linecmd = 'BO'
      then "BROWSE DATAID("oldlib") MEMBER("member")"
      else "BROWSE DATAID("newlib") MEMBER("member")"
    ok=0;"CONTROL DISPLAY RESTORE"       /* restore display env */
    disp_restore = 0
  end

  when linecmd = 'C'                     /* Compare members */
  then do
    if orecfm = 'U' ¦ nrecfm = 'U'
      then cp_ctype = 'BYTE'
      else cp_ctype = 'LINE'
    if right(olddsn,1) = "'"           /* If quoted dsname, */
      then x = length(olddsn) - 1      /*  then set insert position */
      else x = length(olddsn)          /*  else insert after dsname */
    old_dsname = insert("("member")",olddsn,x)
    ok=0; address tso,
      "ALLOC FI(OLDDD) DA("old_dsname") SHR REUSE"

    if right(newdsn,1) = "'"           /* If quoted dsname, */
      then x = length(newdsn) - 1      /*  then set insert position */
      else x = length(newdsn)          /*  else insert after dsname */
    new_dsname = insert("("member")",newdsn,x)
    ok=0; address tso,
      "ALLOC FI(NEWDD) DA("new_dsname") SHR REUSE"

    compare_outdd_fname = "'"userid()".SUPERC.LIST'"
    call msg 'OFF'
    ok='*'; address tso,
      "ALLOC FI(OUTDD) DA("compare_outdd_fname") OLD REUSE"
    call msg 'ON'
    if rc > 0
    then do
      ok=0; address tso,
        "ALLOC FI(OUTDD) DA("compare_outdd_fname") NEW REUSE",
        "DSORG(PS) RELEASE SPACE(50 100) BLKSIZE(3325)"
    end
    ok=0; address tso,
      "ALLOC FI(SYSIN) DUMMY REUSE"

    /* Invoke SuperC */
    ok='*';"SELECT PGM(ISRSUPC) PARM(DELTAL,LINECMP,)"
    ok=0;"CONTROL DISPLAY SAVE"       /* Save display environ        */
    disp_restore = 1                  /* Indicate RESTORE required   */
    ok=0;"BROWSE DATASET("compare_outdd_fname")" /* Browse output    */
    ok=0;"CONTROL DISPLAY RESTORE"               /* Restore display  */
    disp_restore = 0                  /* Reset restore flag          */
    ok=0; address tso,
      "FREE FI(OUTDD,SYSIN,OLDDD,NEWDD)"

  end    /* End of Compare line command */


  when linecmd = 'DO' ¦ linecmd = 'DN'
  then do
    ok=0;
    if linecmd = 'DO'
      then "LMMDEL DATAID("oldlib") MEMBER("member")"
      else "LMMDEL DATAID("newlib") MEMBER("member")"
    delcount = delcount + 1
    ok=0;"TBDELETE MEMTBL"        /* Delete the row */
/* If the following TBSKIP is not done, the wrong row may be deleted */
    ok='0 8';"TBSKIP MEMTBL NUMBER(0)"  /* Refetch the vars */
  end

  when linecmd = 'EO' ¦ linecmd = 'EN'
  then do
    ok=0;"CONTROL DISPLAY SAVE"          /* save display environment */
    disp_restore = 1                     /* restore required */
    if linecmd = 'EO' then do
      ok='0 4 8';"EDIT DATAID("oldlib") MEMBER("member")"
      end
      else do
      ok='0 4 8';"EDIT DATAID("newlib") MEMBER("member")"
      end
    ok=0;"CONTROL DISPLAY RESTORE"       /* restore display env */
    disp_restore = 0
  end

  when linecmd = 'S'
  then do
    if ªalloc_done
    then do
      ok=0;address tso "ALLOC FI(NEWLIBDD) DA("newdsn") SHR REUSE"
      ok=0;address tso "ALLOC FI(OLDLIBDD) DA("olddsn") SHR REUSE"
      alloc_done = 1
    end
    if nrecfm = 'U'
    then do
      ok=0;address tso "FINDMEM" member "NEWLIBDD"
      newsize = right(c2x(substr(fmdirent,25,3)),6,'0')
      newdate = jul2greg(fmlkeddt)
    end
    if orecfm = 'U'
    then do
      ok=0;address tso "FINDMEM" member "OLDLIBDD"
      oldsize = right(c2x(substr(fmdirent,25,3)),6,'0')
      olddate = jul2greg(fmlkeddt)
    end

    if olddate > newdate
      then flgdate = '>'
      else flgdate = ''

    ok=0;"TBPUT MEMTBL"          /* Update the row */

  end

  when linecmd = 'X'
  then do
    ok=0;"TBDELETE MEMTBL"        /* Delete the row */
/* If the following TBSKIP is not done, the wrong row may be deleted */
    ok='0 8';"TBSKIP MEMTBL NUMBER(0)"  /* Refetch the vars */
  end

  otherwise nop;

end
return

/**********************************************************************/
/* Primary Command Routine                                            */
/**********************************************************************/
process_zcmd:
parse var zcmd zcmd oper
upper oper
select

  when zcmd = 'DELETE'
  then do

    if matchopt = 'U'                       /* If Unmatched list, then*/
      then oper = 'NEW'                     /* force delete from NEW */
    do while wordpos(oper,'NEW OLD') = 0    /* Valid operands  */
      ok = 0;"ADDPOP ROW(7) COLUMN(10)"     /* Set popup mode */
      ok='0 8';"DISPLAY PANEL(LIB@CLN5)"    /* Display oper prompt */
      save_rc = rc                          /* Save return code   */
      ok=0;"REMPOP"                         /* Clear popup mode */
      if save_rc = 8                        /* If user pressed END  */
        then return                         /*  then return to caller */
    end

    if oper = 'OLD'
      then deldsn = olddsn
      else deldsn = newdsn

    ok=0;"ADDPOP ROW(8) COLUMN(15)"  /* POSITION THE POP UP */
    ok=0;"DISPLAY PANEL(LIB@CLN3)"
    save_rc = rc
    ok=0;"REMPOP"               /* Remove the popup */
    if uconfirm ¬= 'Y' ¦ save_rc > 0
    then do
      zedsmsg = 'Delete cancelled'
      zedlmsg = 'Delete was cancelled at your request.'

      ok=0;"SETMSG MSG(ISRZ001)"
    end
    else do
    if oper = 'OLD'
      then dellib = oldlib
      else dellib = newlib
      ok=0;"TBTOP MEMTBL"                /* Set table to top */
      do until rc = 8
        ok='0 8';"TBSKIP MEMTBL NUMBER(1)"  /* Read table row */
        if rc = 0                        /* If a row was read */
        then do
          ok=0;"LMMDEL DATAID("dellib") MEMBER("member")"
          delcount = delcount + 1
          if delcount // 10 = 0
          then do
            ok=0;"CONTROL DISPLAY LOCK"
            ok=0;"DISPLAY PANEL(  )"
          end
        end
      end
      get_out = 1
    end
  end

  when abbrev('LOCATE',zcmd,1)
  then do
    ok=0;"TBTOP MEMTBL"
    member = oper
    ok=0;"TBSCAN MEMTBL ARGLIST(MEMBER)" ,
         "CONDLIST(GE)"
  end

/* 'VERsion' command. Display EXEC version number */
  when abbrev('VERSION',zcmd)       /* If version cmd */
  then do
    zedsmsg = 'LIBCLEAN version' lc_version
    zedlmsg = ''
    ok=0;"SETMSG MSG(ISRZ000)"  /*  display messages */
  end

  otherwise do
    zedsmsg = 'Invalid command'
    zedlmsg = '"'zcmd'" is not a recognized primary command.' ,
              'Valid commands are DELETE.'
    ok=0;"SETMSG MSG(ISRZ001)"
  end

end
return

/**********************************************************************/
/*   Halt routine                                                     */
/**********************************************************************/
haltproc:
signal off syntax
signal off novalue
call off error
call off failure
call cleanup_after_error
exit

/**********************************************************************/
/*   Function to convert julian date to gregorian                     */
/**********************************************************************/
jul2greg:
procedure
parse arg date

days.1 = 31
days.2 = 28
days.3 = 31
days.4 = 30
days.5 = 31
days.6 = 30
days.7 = 31
days.8 = 31
days.9 = 30
days.10 = 31
days.11 = 30
days.12 = 31

/*** julian to gregorian conversion ***/
year = substr(date,1,2)
day = substr(date,3)
julian = day

/*  validate input */
if verify(date,'0123456789') ¬= 0
then do
  say 'Invalid characters in julian date'
  exit 8
end
if year // 100 = 0
  then if year // 400 = 0
          then max_julday = 366
          else max_julday = 365
  else if year // 4 = 0
          then max_julday = 366
          else max_julday = 365
if day < 1 ¦ day > max_julday
then do
  say 'Invalid value for julian day'
  exit 8
end

/* input is ok. Calculate gregorian */
if year // 100 = 0
  then if year // 400 = 0
          then days.2 = 29
          else nop
  else if year // 4 = 0
          then days.2 = 29
          else nop
month = 1
do while day > days.month
  day = day - days.month
  month = month + 1
end
date = right(year,2,'0')¦¦'/'¦¦right(month,2,'0')¦¦'/'¦¦right(day,2,'0')
return date  /* return to caller */
/**********************************************************************/
/* Cleanup after error                                                */
/**********************************************************************/
cleanup_after_error:
"LMCLOSE DATAID("newlib")"
"LMCLOSE DATAID("oldlib")"
"LMFREE DATAID("newlib")"
"LMFREE DATAID("oldlib")"
"TBEND MEMTBL"
if disp_restore
  then "CONTROL DISPLAY RESTORE"
exit
/*********************************************************************/
/**   standard error handling routine                               **/
/*********************************************************************/
errproc:
if (condition('c') = 'ERROR' ¦ condition('c') = 'FAILURE') ,
   & symbol('OK') = 'VAR'
  then if wordpos(rc,ok) > 0 ¦ ok = '*' then return;   /* Not an error*/
/* Cancel error traps to prevent recursion */
signal off syntax
signal off novalue
call off error
call off failure
/* error presentation code */
error_type = condition('c')
say error_type 'at line' sigl ':' condition('d')
if error_type = 'SYNTAX'
  then say errortext(rc)
if (error_type = 'ERROR' ¦ error_type = 'FAILURE') ,
    & symbol('zerrlm') = 'VAR'
  then say zerrlm
if error_type = 'ERROR' ¦ error_type = 'FAILURE'
  then say 'Return code = ' rc
call cleanup_after_error
            

 LIBCLEAN is a "shareware" utility I loaded from the NASCOM BBS.  The
 provided documentation is as follows:

 LIBCLEAN is a REXX ISPF dialog that compares the directories of two PDS
 libraries and displays a list of matching or non-matching member names
 and statistics.  Only non-load libraries are supported.

 Operations such as browse, compare, or delete may then be performed
 against members in the list. All listed members may be mass deleted
 from either the OLD or NEW library. Selected members may be excluded
 from the mass delete.

 This tool can be useful for deleting duplicate copies of software when
 the product is in a mixed library. It is a very fast way to clean up
 messy ISPF files.  It can also be used to verify source members exist
 for a load library.

 Invoking LIBCLEAN
 ------------------
 Enter TSO %LIBCLEAN

 Enter library names as directed on the initial panel. LIBCLEAN will
 then build the matched or unmatched list.

 Sorry...no help screens yet.

 Line commands
 -------------
 Any unrecognized line command, e.g. '?' will display a list of valid
 line commands.

 The following line commands are provided:

 - BO / BN - Browse member from the OLD lib (BO) or the NEW lib (BN).

 - C - Invoke IBM SuperCompare with the members from NEW and OLD libs.

 - DO / DN - Delete member from the OLD lib (DO) or the NEW lib (DN).

 - EO / EN - Edit member from the OLD lib (BO) or the NEW lib (BN).

 - S - Show Load module stats for the member. Requires the FINDMEM CP.

 - X - EXclude the member from the list. Use this to exclude members
       from the mass DELETE primary command.

 Primary commands
 ----------------
 The following primary commands are provided:

   - DELETE OLD
   - DELETE NEW   Delete all members on list from OLD or NEW lib. This
                  will be followed by a delete confirmation panel.

   - Locate xxx   Position the list to member xxx.