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

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