git.oblomov.eu Git - ohcount/blob - test/expected_dir/rexx1.rex

   1 rexx    comment /* REXX    FLTTBL     Cloned from DUMPTBL 960619 to produce a flat
   2 rexx    comment                       version (up to 32K characters wide) of any ISPF
   3 rexx    comment                       table.
   4 rexx    blank
   5 rexx    comment            Written by Frank Clarke, Oldsmar, FL
   6 rexx    blank
   7 rexx    comment      Impact Analysis
   8 rexx    comment .    SYSPROC   LA
   9 rexx    comment .    SYSPROC   TRAPOUT
  10 rexx    blank
  11 rexx    comment      Modification History
  12 rexx    comment      19960918 fxc added some error-checking
  13 rexx    comment      19970115 fxc upgrade REXXSKEL from v.960606 to v.970113; add
  14 rexx    comment                   RESTARTability;
  15 rexx    comment      19991231 fxc upgrade REXXSKEL from v.970113 to v.19991109;
  16 rexx    comment                   RXSKLY2K; DECOMM; LRECL reduced from 32K to "min
  17 rexx    comment                   needed";
  18 rexx    blank
  19 rexx    code    */ arg argline
  20 rexx    code    address TSO                            /* REXXSKEL ver.19991109      */
  21 rexx    code    arg parms "((" opts
  22 rexx    blank
  23 rexx    code    signal on syntax
  24 rexx    code    signal on novalue
  25 rexx    blank
  26 rexx    code    call TOOLKIT_INIT                      /* conventional start-up     -*/
  27 rexx    code    rc     = Trace(tv)
  28 rexx    code    info   = parms                         /* to enable parsing          */
  29 rexx    blank
  30 rexx    code    if \sw.inispf  then do
  31 rexx    code       arg line
  32 rexx    code       line = line "((  RESTARTED"         /* tell the next invocation   */
  33 rexx    code       "ISPSTART CMD("exec_name line")"    /* Invoke ISPF if nec.        */
  34 rexx    code       exit                                /* ...and restart it          */
  35 rexx    code       end
  36 rexx    blank
  37 rexx    code    call A_INIT                            /*                           -*/
  38 rexx    blank
  39 rexx    code    "NEWSTACK"
  40 rexx    code                                        if \sw.0error_found then,
  41 rexx    code    call C_TABLE_OPS                       /*                           -*/
  42 rexx    code                                        if \sw.0error_found then,
  43 rexx    code    call D_PUMP_TBL                        /*                           -*/
  44 rexx    blank
  45 rexx    code    "DELSTACK"
  46 rexx    blank
  47 rexx    code    if sw.restarted then do
  48 rexx    code       rc = OutTrap("ll.")
  49 rexx    code       exit 4
  50 rexx    code       end
  51 rexx    blank
  52 rexx    code    exit                                   /*@ FLTTBL                    */
  53 rexx    comment /*
  54 rexx    comment .  ----------------------------------------------------------------- */
  55 rexx    code    A_INIT:                                /*@                           */
  56 rexx    code       if branch then call BRANCH
  57 rexx    code       address TSO
  58 rexx    blank
  59 rexx    code       call AA_KEYWDS                      /*                           -*/
  60 rexx    code       parse var info  $tn$    .           /* table-name required        */
  61 rexx    code       if $tn$ = "" then do
  62 rexx    code          helpmsg = "Tablename is required."
  63 rexx    code          call HELP
  64 rexx    code          end
  65 rexx    blank
  66 rexx    code       parse value outdsn "FLATTBLS."$tn$     with,
  67 rexx    code                   outdsn  .
  68 rexx    blank
  69 rexx    code       xefef     = "efef"x
  70 rexx    code       if tblds = "" then do
  71 rexx    code          call AB_FIND_LIBRARY             /*                           -*/
  72 rexx    code          if tblds = "" then do
  73 rexx    code             helpmsg = "Table" $tn$ "was not found in ISPTLIB.  Please",
  74 rexx    code                       "restart specifying a library name as shown below."
  75 rexx    code             call HELP                     /* ...and don't come back     */
  76 rexx    code             end
  77 rexx    code          end
  78 rexx    code       else,
  79 rexx    code       if Left(tblds,1) = "'" then tblds = Strip(tblds,,"'")
  80 rexx    code                              else tblds = Userid()"."tblds
  81 rexx    blank
  82 rexx    code    return                                 /*@ A_INIT                    */
  83 rexx    comment /*
  84 rexx    comment .  ----------------------------------------------------------------- */
  85 rexx    code    AA_KEYWDS:                             /*@                           */
  86 rexx    code       if branch then call BRANCH
  87 rexx    code       address TSO
  88 rexx    blank
  89 rexx    code       tblds       = KEYWD("IN")
  90 rexx    code       outdsn      = KEYWD("OUTPUT")
  91 rexx    code       sortseq     = KEYWD("SORT")
  92 rexx    code       sw.0purge   = SWITCH("DELETEBEHIND")
  93 rexx    blank
  94 rexx    code       parse value KEYWD("ADD") "0"  with  bytes_to_add  .
  95 rexx    blank
  96 rexx    code    return                                 /*@ AA_KEYWDS                 */
  97 rexx    comment /*
  98 rexx    comment    <tblds> was not specified.  Locate the table in ISPTLIB.
  99 rexx    comment .  ----------------------------------------------------------------- */
 100 rexx    code    AB_FIND_LIBRARY:                       /*@                           */
 101 rexx    code       if branch then call BRANCH
 102 rexx    code       address TSO
 103 rexx    blank
 104 rexx    code       "NEWSTACK"
 105 rexx    code       "LA ISPTLIB ((STACK LINE"
 106 rexx    code       pull tliblist
 107 rexx    code       "DELSTACK"
 108 rexx    blank
 109 rexx    code       do Words(tliblist)                  /* each library               */
 110 rexx    code          parse var tliblist  tblds  tliblist
 111 rexx    code          if Sysdsn("'"tblds"("$tn$")'") = "OK" then return
 112 rexx    code       end                                 /* tliblist                   */
 113 rexx    code       tblds = ""
 114 rexx    blank
 115 rexx    code    return                                 /*@ AB_FIND_LIBRARY           */
 116 rexx    comment /*
 117 rexx    comment .  ----------------------------------------------------------------- */
 118 rexx    code    C_TABLE_OPS:                           /*@                           */
 119 rexx    code       if branch then call BRANCH
 120 rexx    code       address ISPEXEC
 121 rexx    blank
 122 rexx    code       call CA_OPEN_TBL                    /*                           -*/
 123 rexx    code       call CS_SPIN_TBL                    /*                           -*/
 124 rexx    code       call CZ_DROP_TBL                    /*                           -*/
 125 rexx    blank
 126 rexx    code    return                                 /*@ C_TABLE_OPS               */
 127 rexx    comment /*
 128 rexx    comment .  ----------------------------------------------------------------- */
 129 rexx    code    CA_OPEN_TBL:                           /*@                           */
 130 rexx    code       if branch then call BRANCH
 131 rexx    code       address ISPEXEC
 132 rexx    blank
 133 rexx    code       "LIBDEF ISPTLIB DATASET ID('"tblds"')  STACK"
 134 rexx    code       "TBSTATS" $tn$ "STATUS1(s1) STATUS2(s2) ROWCURR(rowct)"
 135 rexx    code       if s1 > 1 then do
 136 rexx    code          say "Table" $tn$ "not available."
 137 rexx    code          sw.0error_found = "1"; return
 138 rexx    code          end; else,
 139 rexx    code       if s2 = 1 then,                     /* not open                   */
 140 rexx    code          "TBOPEN " $tn$ "NOWRITE"
 141 rexx    code       else "TBTOP" $tn$
 142 rexx    code       "LIBDEF ISPTLIB"
 143 rexx    code                                           if sw.0error_found then return
 144 rexx    code       "TBQUERY" $tn$  "KEYS(keylist)",
 145 rexx    code                       "NAMES(nmlist)"
 146 rexx    code       parse var keylist "(" keylist ")"
 147 rexx    code       parse var  nmlist "("  nmlist ")"
 148 rexx    code       namelist = keylist nmlist
 149 rexx    blank
 150 rexx    code       if sortseq <> "" then "TBSORT" $tn$ "FIELDS("sortseq")"
 151 rexx    blank
 152 rexx    code    return                                 /*@ CA_OPEN_TBL               */
 153 rexx    comment /*
 154 rexx    comment .  Given: <namelist> contains all the defined names for this table.
 155 rexx    comment    The table has been TOPped.
 156 rexx    comment .  ----------------------------------------------------------------- */
 157 rexx    code    CS_SPIN_TBL: Procedure expose,         /*@ hide everything           */
 158 rexx    code          expose (tk_globalvars),          /* except these               */
 159 rexx    code          $tn$  namelist  xefef  tblds  rows  keylist  nmlist  maxlen
 160 rexx    code                                                            cs_tv = Trace()
 161 rexx    code       if branch then call BRANCH
 162 rexx    code       address ISPEXEC
 163 rexx    blank
 164 rexx    code       maxlen = 0                          /* maximum line length        */
 165 rexx    code       do forever
 166 rexx    code          "TBSKIP" $tn$ "SAVENAME(xvars)"
 167 rexx    code          if rc > 0 then leave             /* we're done...              */
 168 rexx    code          line  = ""                       /* set empty                  */
 169 rexx    comment                            /* add blocks of "var .. varvalue .."     */
 170 rexx    code          do cx = 1 to Words(namelist)
 171 rexx    code             thiswd = Word(namelist,cx)
 172 rexx    code             line = line thiswd xefef Value(thiswd) xefef
 173 rexx    code          end                              /* cx                         */
 174 rexx    code          rc = Trace("O"); rc = Trace(cs_tv)
 175 rexx    code          parse var xvars "(" xvars ")"
 176 rexx    comment                            /* add a block of "XVARS .. xvarlist .."  */
 177 rexx    code          line = line "XVARS" xefef xvars xefef
 178 rexx    comment                            /* add blocks of "xvar .. xvarvalue .."   */
 179 rexx    code          do cx = 1 to Words(xvars)
 180 rexx    code             thiswd = Word(xvars,cx)
 181 rexx    code             line = line thiswd xefef Value(thiswd) xefef
 182 rexx    code          end                              /* cx                         */
 183 rexx    code          rc = Trace("O"); rc = Trace(cs_tv)
 184 rexx    code          maxlen  = Max(maxlen,Length(line))
 185 rexx    code          queue line
 186 rexx    code       end                                 /* forever                    */
 187 rexx    blank
 188 rexx    code       lines_in_stack = queued()
 189 rexx    code       line = "Contents of" $tn$ "in" tblds,
 190 rexx    code              "("lines_in_stack" rows)  KEYS("keylist")  NAMES("nmlist")."
 191 rexx    code       push line                           /* make it the first line     */
 192 rexx    code       maxlen  = Max(maxlen,Length(line))
 193 rexx    code       if monitor then say "Maximum line length is" maxlen
 194 rexx    blank
 195 rexx    code    return                                 /*@ CS_SPIN_TBL               */
 196 rexx    comment /*
 197 rexx    comment .  ----------------------------------------------------------------- */
 198 rexx    code    CZ_DROP_TBL:                           /*@                           */
 199 rexx    code       if branch then call BRANCH
 200 rexx    code       address ISPEXEC
 201 rexx    blank
 202 rexx    code       if s2 = 1 then,                     /* table was not open at start*/
 203 rexx    code          "TBEND" $tn$
 204 rexx    blank
 205 rexx    code    return                                 /*@ CZ_DROP_TBL               */
 206 rexx    comment /*
 207 rexx    comment .  ----------------------------------------------------------------- */
 208 rexx    code    D_PUMP_TBL:                            /*@                           */
 209 rexx    code       if branch then call BRANCH
 210 rexx    code       address TSO
 211 rexx    blank
 212 rexx    code       if monitor then say,
 213 rexx    code          "Writing text."
 214 rexx    blank
 215 rexx    code       maxlen = maxlen + 4 + bytes_to_add  /* set LRECL                  */
 216 rexx    code       vbmax.0   = "NEW CATALOG UNIT(SYSDA) SPACE(1 5) TRACKS",
 217 rexx    code                        "RECFM(V B) LRECL("maxlen") BLKSIZE(0)"
 218 rexx    code       vbmax.1   = "SHR"                   /* if it already exists...    */
 219 rexx    blank
 220 rexx    code       tempstat = Sysdsn(outdsn) = "OK"    /* 1=exists, 0=missing        */
 221 rexx    code       "ALLOC FI($TMP) DA("outdsn") REU" vbmax.tempstat
 222 rexx    code       rcx = rc
 223 rexx    code       "EXECIO" queued() "DISKW $TMP (FINIS"
 224 rexx    code       rcx = max(rcx,rc)
 225 rexx    code       "FREE  FI($TMP)"
 226 rexx    blank
 227 rexx    code       if rcx = 0 & sw.0purge then do
 228 rexx    code          address ISPEXEC
 229 rexx    code          "LIBDEF  ISPTLIB  DATASET  ID('"tblds"')  STACK"
 230 rexx    code          "TBERASE" $tn$
 231 rexx    code          if rc = 0 then say $tn$ "was deleted"
 232 rexx    code          "LIBDEF  ISPTLIB"
 233 rexx    code          end
 234 rexx    blank
 235 rexx    code    return                                 /*@ D_PUMP_TBL                */
 236 rexx    comment /*
 237 rexx    comment .  ----------------------------------------------------------------- */
 238 rexx    code    LOCAL_PREINIT:                         /*@ customize opts            */
 239 rexx    code       if branch then call BRANCH
 240 rexx    code       address TSO
 241 rexx    blank
 242 rexx    blank
 243 rexx    code    return                                 /*@ LOCAL_PREINIT             */
 244 rexx    comment /*
 245 rexx    comment .  ----------------------------------------------------------------- */
 246 rexx    code    HELP:                                  /*@                           */
 247 rexx    code    address TSO;"CLEAR"
 248 rexx    code    if helpmsg <> "" then do ; say helpmsg; say ""; end
 249 rexx    code    ex_nam = Left(exec_name,8)             /* predictable size           */
 250 rexx    code    say "  "ex_nam"      produces a flattened version of any ISPF table    "
 251 rexx    code    say "                into a VB-form dataset of minimum necessary LRECL."
 252 rexx    code    say "                                                                  "
 253 rexx    code    say "   The field contents are written in KEYPHRS format               "
 254 rexx    code    say "             (var .. varval ..)                                   "
 255 rexx    code    say "   key-fields first, followed by name-fields, followed by the     "
 256 rexx    code    say "   names of any extension variables key-phrased by 'XVARS',       "
 257 rexx    code    say "   followed by the extension variables themselves in KEYPHRS      "
 258 rexx    code    say "   format.                                                        "
 259 rexx    code    say "                                                                  "
 260 rexx    code    say "   The first record on the file identifies the table name, the    "
 261 rexx    code    say "   source library, the number of rows processed, and the key- and "
 262 rexx    code    say "   name-fields.                                                   "
 263 rexx    code    say "                                                                  "
 264 rexx    code    say "                                             more....             "
 265 rexx    code    pull
 266 rexx    code    "CLEAR"
 267 rexx    code    say "  Syntax:   "ex_nam"  <tbl>                             (Required)"
 268 rexx    code    say "                      <IN     libdsn>                             "
 269 rexx    code    say "                      <OUTPUT outdsn>                   (Defaults)"
 270 rexx    code    say "                      <SORT   sortspec>                           "
 271 rexx    code    say "                      <ADD    bytes>                    (Defaults)"
 272 rexx    code    say "                                                                          "
 273 rexx    code    say "            <tbl>     identifies the table to be dumped.                  "
 274 rexx    code    say "                                                                          "
 275 rexx    code    say "            <libdsn>  identifies the ISPF Table library which holds <tbl>."
 276 rexx    code    say "                      If <libdsn> is not specified, ISPTLIB will be       "
 277 rexx    code    say "                      searched to find the correct dataset.               "
 278 rexx    code    say "                                                                          "
 279 rexx    code    say "            <outdsn>  (default: FLATTBLS.<tbl>) names the output file.    "
 280 rexx    code    say "                      <outdsn> will be created if it does not exist.      "
 281 rexx    code    say "                                                                          "
 282 rexx    code    say "            <sortspec> causes the table to be sorted as indicated before  "
 283 rexx    code    say "                      being dumped.                                       "
 284 rexx    code    say "                                                                          "
 285 rexx    code    say "            <bytes>   (default=0) causes the LRECL of the output dataset  "
 286 rexx    code    say "                      to be extended to enable updating.                  "
 287 rexx    code    pull
 288 rexx    code    "CLEAR"
 289 rexx    code    say "   Debugging tools provided include:                              "
 290 rexx    code    say "                                                                  "
 291 rexx    code    say "        MONITOR:  displays key information throughout processing. "
 292 rexx    code    say "                  Displays most paragraph names upon entry.       "
 293 rexx    code    say "                                                                  "
 294 rexx    code    say "        NOUPDT:   by-pass all update logic.                       "
 295 rexx    code    say "                                                                  "
 296 rexx    code    say "        BRANCH:   show all paragraph entries.                     "
 297 rexx    code    say "                                                                  "
 298 rexx    code    say "        TRACE tv: will use value following TRACE to place the     "
 299 rexx    code    say "                  execution in REXX TRACE Mode.                   "
 300 rexx    code    say "                                                                  "
 301 rexx    code    say "                                                                  "
 302 rexx    code    say "   Debugging tools can be accessed in the following manner:       "
 303 rexx    code    say "                                                                  "
 304 rexx    code    say "        TSO "ex_nam"  parameters     ((  debug-options            "
 305 rexx    code    say "                                                                  "
 306 rexx    code    say "   For example:                                                   "
 307 rexx    code    say "                                                                  "
 308 rexx    code    say "        TSO "ex_nam" vt2231 add 17 (( MONITOR TRACE ?R            "
 309 rexx    code    address ISPEXEC "CONTROL DISPLAY REFRESH"
 310 rexx    code    exit                                   /*@ HELP                      */
 311 rexx    comment /*   REXXSKEL back-end removed for space   */