/* REXX, LINEMAC-Macro, Orginal by Doug Nadel, IBM USA                */
/* diese Version, N.Haas                                              */
/*                                                                    */
/* Um neue Commandos zu hinterlegen muessen diese hier erstellt und   */
/* und mit TSO CALL LMAC.LOAD(LMAC) auch dort eingetragen werden.     */
/*                                                                    */
/* -------------------------------------------------------------------*/

"ISREDIT MACRO (PARM) NOPROCESS"
"ISPEXEC CONTROL ERRORS RETURN"

linemacs = "%"   , /* PRozentzeichen %%% (tmp)                        */
           "CE"  , /* CEnter                                          */
           "CM"  , /* Copy Multiple                                   */
           "DB"  , /* Delete Bottom                                   */
           "DM"  , /* Delete Minus                                    */
           "DT"  , /* Delete Top                                      */
           "EI"  , /* End If                                          */
           "EU"  , /* EUro (*EURO* in Cobol Prog. Spalte 1-6)         */
           "H"   , /* Here (after)                                    */
           "LE"  , /* LEft                                            */
           "RC"  , /* Remark Cobol                                    */
           "REV" , /* REVerse                                         */
           "RI"  , /* RIght                                           */
           "RJ"  , /* Remark Jcl                                      */
           "RX"  , /* Remark reXx                                     */
           "T"   , /* Test (*TEST* in Cobol Prog. Spalte 1-6)         */
           "TR"  , /* TRace (einfuegen einer TRACE ?R; NOP Zeile      */
           "XB"  , /* eXclude Bottom                                  */
           "XM"  , /* eXclude Minus                                   */
           "XT"    /* eXclude Top                                     */

IF WORDPOS(parm,linemacs) = 0 THEN DO
   zinfo=parm
   "ISPEXEC SETMSG MSG(ISRE041)"
   EXIT  8
END

/* Range ermitteln, Fehlermeldung */
"ISREDIT PROCESS RANGE" parm
IF rc > 0  THEN DO
   "ISPEXEC SETMSG MSG(ISRZ002)"
   EXIT  8
END

/* erste, letzte Zeile des Bereichs und Datenbreite festhalten */
"ISREDIT (start) = LINENUM .ZFRANGE"
"ISREDIT (stop)  = LINENUM .ZLRANGE"
"ISREDIT (dw)    = DATA_WIDTH"

/* Copy Multiple vorbelegen */
cm_c = 0
cm_line. = ''

/* Delete Top hier verarbeiten */
IF parm = "DT" THEN DO
   IF start /= stop THEN DO
      zedsmsg = 'DTT..DTT or DTn not possible'
      zedlmsg = 'To delete line from here to the top use DT only.'
      CALL Mistake
      EXIT -8
   END
   "ISREDIT LABEL .zfirst = .start 0"
   "ISREDIT LABEL .zcsr   = .stop 0"
   "ISREDIT DELETE ALL .start .stop"
   SIGNAL Ente
END

/* Delete Bottom hier verarbeiten */
IF parm = "DB" THEN DO
   IF start /= stop THEN DO
      zedsmsg = 'DBB..DBB or DBn not possible'
      zedlmsg = 'To delete line from here to the bottom use DB only.'
      CALL Mistake
      EXIT -8
   END
   "ISREDIT LABEL .zcsr  = .start 0"
   "ISREDIT LABEL .zlast = .stop 0"
   "ISREDIT DELETE ALL .start .stop"
   SIGNAL Ente
END

/* eXclude Top hier verarbeiten */
IF parm = "XT" THEN DO
   IF start /= stop THEN DO
      zedsmsg = 'XTT..XTT or XTn not possible'
      zedlmsg = 'To exclude line from here to the top use XT only.'
      CALL Mistake
      EXIT -8
   END
   "ISREDIT LABEL .zfirst = .start 0"
   "ISREDIT LABEL .zcsr   = .stop 0"
   "ISREDIT EXCLUDE ALL .start .stop"
   "ISREDIT RESET LABEL .start .start"
   "ISREDIT RESET LABEL .stop .stop"
   SIGNAL Ente
END

/* eXclude Bottom hier verarbeiten */
IF parm = "XB" THEN DO
   IF start /= stop THEN DO
      zedsmsg = 'XBB..XBB or XBn not possible'
      zedlmsg = 'To exclude line from here to the bottom use XB only.'
      CALL Mistake
      EXIT -8
   END
   "ISREDIT LABEL .zcsr  = .start 0"
   "ISREDIT LABEL .zlast = .stop 0"
   "ISREDIT EXCLUDE ALL .start .stop"
   "ISREDIT RESET LABEL .start .start"
   "ISREDIT RESET LABEL .stop .stop"
   SIGNAL Ente
END

/* XM und DM hier vor-verarbeiten (Achtung: DM wird 3 x verarbeitet)  */
IF parm = "XM" | parm = "DM" THEN DO
/* SAY start                XM5 auf Zeile 50 ==> start = 50           */
/* SAY stop                                      stop  = 54           */
   diff = stop - start   /*                      diff  =  4           */
   stop = start          /*                      stop  = 50           */
   start = start - diff  /*                      start = 46           */
/* SAY start                                                          */
/* SAY stop                                                           */
END

/* TRace hier verarbeiten */
IF parm = "TR" THEN DO
   IF start /= stop THEN DO
      zedsmsg = 'TRR..TRR or TRn not possible'
      zedlmsg = 'To insert TRACE-line use TR only.'
      CALL Mistake
      EXIT -8
   END
   "ISREDIT LINE_AFTER .zcsr = 'Trace ?r; NOP'"
   "ISREDIT FIND NEXT 'Trace' 1"
   SIGNAL Ente
END

/* H hier vearbeiten */
IF parm = "H" THEN DO
   IF start /= stop THEN DO
      zedsmsg = 'HH..HH or Hn not possible'
      zedlmsg = 'To insert the multiplecopy lines, use H only.'
      CALL Mistake
      EXIT -8
   END
   dsn = "'"USERID()".ISPAREA($CM)'"
   "ALLOC DD(dd) DSN("dsn") SHR REUSE"
   "EXECIO * DISKR dd (FINIS STEM cm_line.)"
   "FREE DD(dd)"
   DO a = cm_line.0 TO 1 BY -1
      line = cm_line.a
      "ISREDIT LINE_AFTER .zcsr = (line)"
   END
   SIGNAL Ente
END

/* alle anderen werden hier verarbeitet */
DO a = start TO stop
  "ISREDIT (line) = LINE" a
  SELECT
    /* Copy Multiple (nach einer Idee von Jens Kaminski, ITERGO) */
    WHEN (parm = "CM") THEN DO
      cm_c = cm_c + 1
      cm_line.cm_c = line
    END

    /* CEnter */
/*  WHEN (parm = "CE")  THEN line = CENTER(strip(line),dw)            */
    WHEN (parm = "CE")  THEN line = CENTER(strip(line),72)

    /* REVerse */
    WHEN (parm = "REV") THEN line = REVERSE(line)

    /* Remark reXx (Meik Naujeck, ITERGO) */
    WHEN (parm = "RX") THEN DO
       IF POS('/*',line) > 0 THEN DO
          "ISREDIT CURSOR =" a 1
          "ISREDIT CHANGE ALL '/*' '  '" .zcsr .zcsr
          "ISREDIT CHANGE ALL '*/' '  '" .zcsr .zcsr
          "ISREDIT (line) = LINE" a
          "ISREDIT CURSOR =" a 1
       END
       ELSE DO
          SELECT
             /* Ersten 2 Zeichen /= Blank & letzten 4 Zeichen /= Blank*/
             /* dann Kommentar nicht erlauben wg. Datenverlust        */
             WHEN SUBSTR(line,1,2)  /= '  ' &,
                  SUBSTR(line,69,4) /= '    '  THEN DO
                     zedsmsg = '"REM ON" NOT POSSIBLE'
                     zedlmsg = 'AT LEAST ON LINE CAN NOT BE SHIFT',
                               'RIGHT 2 CHARS.'
                     CALL Mistake
             END
             /* Ersten 2 Zeichen /= Blank & letzten 4 Zeichen = Blank */
             /* 2 Zeich. einrücken und letzten 2 Zeich. überschreiben */
             WHEN SUBSTR(line,1,2)  /= '  ' &,
                  SUBSTR(line,69,4)  = '    '  THEN DO
                     line = '/*' || line
                     line = OVERLAY('*/',line,71)
             END
             /* Ersten 2 Zeichen = Blank & letzten 2 Zeichen /= Blank */
             /* dann Kommentar nicht erlauben wg. Datenverlust        */
             WHEN SUBSTR(line,1,2)   = '  ' &,
                  SUBSTR(line,71,2) /= '  '  THEN DO
                     zedsmsg = '"REM ON" NOT POSSIBLE'
                     zedlmsg = 'THE LAST 2 CHARACTERS ARE NOT BLANK'
                     CALL Mistake
             END
             /* Ersten 2 Zeichen = Blank & letzten 2 Zeichen = Blank  */
             /* ersten und letzten 2 Zeichen überschreiben            */
             WHEN SUBSTR(line,1,2)   = '  ' &,
                  SUBSTR(line,71,2)  = '  '  THEN DO
                     line = OVERLAY('/*',line,1)
                     line = OVERLAY('*/',line,71)
             END
             OTHERWISE NOP
          END
       END
    END

    /* Remark Cobol */
    WHEN (parm = "RC") THEN DO
       IF SUBSTR(line,7,1) = '*' THEN DO
          line = OVERLAY(' ',line,7)
       END
       ELSE DO
          line = OVERLAY('*',line,7)
       END
    END

    /* Remark Jcl */
    WHEN (parm = "RJ") THEN DO
       IF SUBSTR(line,1,3) = '//*' THEN DO
          line = OVERLAY('// ',line,1)
       END
       ELSE DO
          line = OVERLAY('//*',line,1)
       END
    END

    /* LEft */
    WHEN (parm = "LE")  THEN line = STRIP(line,"L")

    /* RIght */
    WHEN (parm = "RI")  THEN line = RIGHT(STRIP(line,"T"),dw)

    /* PRozentzeichen %%% (tmp) */
    WHEN (parm = "%")  THEN DO
       line = OVERLAY('%%%   ',line,1)
    END

    /* EUro */
    WHEN (parm = "EU")  THEN DO
       line = OVERLAY('*EURO*',line,1)
    END

    /* XM */
    WHEN (parm = "XM")  THEN DO
       "ISREDIT XSTATUS" a "= X"
    END

    /* DM */
    WHEN (parm = "DM")  THEN DO
       "ISREDIT DELETE" start          /* Achtung: nicht DELETE a !!! */
    END

    /* Test (Kommentarzeile *TEST* in Cobol) */
    WHEN (parm = "T")  THEN DO
       line = OVERLAY('*TEST*',line,1)
    END

    /* ENDIF (Cobol) */
    WHEN (parm = "EI")  THEN DO
       IF punkt /= '.' THEN DO /* Wenn >.< gesetzt, nicht mehr fragen */
          IF POS('.',line) > 0 THEN DO
             punkt = '.'
          END
          ELSE DO
             punkt = ''
          END
       END
       IF Erstes_EI /= '' THEN DO
          Erstes_EI = ''
          line = STRIP(line,"T","0") /* NUMBER ON ?  hinten Zahlen ab */
          line = STRIP(line,"T","1")              /* hinten Zahlen ab */
          line = STRIP(line,"T","2")              /* hinten Zahlen ab */
          line = STRIP(line,"T","3")              /* hinten Zahlen ab */
          line = STRIP(line,"T","4")              /* hinten Zahlen ab */
          line = STRIP(line,"T","5")              /* hinten Zahlen ab */
          line = STRIP(line,"T","6")              /* hinten Zahlen ab */
          line = STRIP(line,"T","7")              /* hinten Zahlen ab */
          line = STRIP(line,"T","8")              /* hinten Zahlen ab */
          line = STRIP(line,"T","9")              /* hinten Zahlen ab */
          line = STRIP(line,"T"," ")              /* hinten Blanks ab */
          line = STRIP(line,"T",".")            /* hinten Punkt(e) ab */
          PARSE VALUE DATE('E') WITH . '/' m '/' j
       END
       diff = stop - a
       IF diff = 0 THEN DO
          newline = 'EI' || m || j ||,
                    '     END-IF' || punkt          /* ggf mit Punkt */
       END
       ELSE DO
          blanks = COPIES('   ',diff)
          newline = 'EI' || m || j || '     ' ||,
                    blanks ||,
                    'END-IF'                        /* ohne Punkt */
       END
       "ISREDIT LINE_AFTER" a "= DATALINE (newline)"
    END

    OTHERWISE  NOP
  END

  /* Zeile zurueckschreiben, wenn nicht DM */
  IF parm /= 'DM' THEN "ISREDIT LINE "a" = (line)"
END

/* Sonderverarbeitung CM */
IF parm = "CM" THEN DO
   dsn = "'"USERID()".ISPAREA($CM)'"
   "ALLOC DD(dd) DSN("dsn") SHR REUSE"
   "EXECIO" cm_c "DISKW dd (FINIS STEM cm_line.)"
   "FREE DD(dd)"
END

Ente:
EXIT 0

Mistake:
/* Fehlerbehandlung */
   "ISPEXEC SETMSG MSG(ISRZ001)"
RETURN -8