Jump to content

$T.REX

From Rosetta Code


$T.REX

This is the   $T.REX   (REXX) program which is used by many other REXX programs to display error or informational message(s),
some of the options are:

  •   in color(s)     (if supported)
  •   highlights (in color) parts (up to 8 unique parts) of the text     (if supported)
  •   write text to a file
  •   breaks/splits the text into multiple lines
  •   adds indentation
  •   justifies the text:   left/right/center/justify   (auto-fill)
  •   add blank lines before and/or after the displaying of text
  •   boxing (around) the text
  •   add spacing around the text inside the box
  •   only showing specific lines of the text messages
  •   suppressing specific lines of the text messages
  •   translation of specific characters in the text
  •   allowing other characters to be used for blanks
  •   repeating a text
  •   allows remarks in the text
  •   writes the message, waits for a confirmation to proceed
  •   delaying (waiting) after the text is displayed
  •   showing a scale and/or a ruler above/below the text message(s)
  •   supports hex/dec/bit strings
  •   changing the case of the text
  •   reverses the text
  •   inverts the bits for certain characters
  •   sounds alarm (beeps) after the text is displayed     (if supported)
  •   displays the text in reverse video (if supported)
  •   displays the text in (big) block letters
  •   clear the screen after or before the displaying of text
  •   allows user-define option character, the default is   .     (period)
  •   and many other options


The help for the   $T   REXX program is included here   ──►   $T.HEL.


The   $T   REXX program makes use of   $ERR   REXX program which is used to display error messages (via   $T).
The   $ERR   REXX program is included here   ──►   $ERR.REX.


The   $T   REXX program makes use of   $BLOCK   REXX program which is used to generate text to display text in (big) blocked letters (via   $T).
The   $BLOCK   REXX program is included here   ──►   $BLOCK.REX.


The   $T   REXX program makes use of   LINESIZE   BIF   which returns the terminals width (linesize).
Some REXXes don't have a   LINESIZE   BIF,   so one is included here   ──►   LINESIZE.REX.


The   $T   REXX program makes use of   SCRSIZE   BIF which returns the terminals width (linesize) and depth.
Some REXXes don't have a   SCRSIZE   BIF,   so one is included here   ──►   SCRSIZE.REX.


The   $T   REXX program makes use of   DELAY   BIF which delays (sleeps) for a specified amount of seconds.
Some REXXes don't have a   DELAY   BIF,   so one is included here   ──►   DELAY.REX.


The   $T   REXX program makes use of   SOUND   BIF which produces sounds via the PC speaker.
Some REXXes don't have a   SOUND   BIF,   so one is included here   ──►   SOUND.REX.


REXX programs not included are   $H   which shows help and other documentation. <lang rexx>/*REXX program to perform various functions in displaying text to the console (screen). */

                                                      /* There be many dragons below.  */

trace off

parse arg ! /*obtain original arguments. */ if !all(0) then exit 0 /*test request for documentation.*/

zz = !! /*save the original arguments. */ if !cms then address /*if CMS, then use fast ADDRESS. */

signal on halt /*be able to handle a HALT. */ signal on noValue /*catch REXX vars with noValue. */ signal on syntax /*catch REXX syntax errors. */

numeric digits 300 /*be able to handle some big 'uns*/

hues=space( 'BLACK 0;30', /*define some colors for DOS. */

           'BROWN     0;33',
           'DEFAULT   1;37',
           'GRAY      1;37',
           'BLUE      1;34',
           'GREEN     1;32',
           'TURQUOISE 1;36',
           'RED       1;31',
           'PINK      1;35',
           'YELLOW    1;33',
           'WHITE     1;37',
           'BRITE     1;37')                          /*colors for  DOS  via  ANSI.SYS */

_= /*(below) set some vars ──> NULL */ parse var _ ?. @ color. colorC. ahics ehics hold lz more onlyo onlys,

           scr0 shics VMout VScolor VSdisp x1 x2

@abc = 'abcdefghijklmnopqrstuvwxyz' @abcU = @abc upper @abcU

  1. ms = 0

?.a = 0 ?.b = 0 ?.block = 0 ?.e = 0 ?.end = 0 ?.i = 0 ?.ks = 0 ?.L = 0 ?.p = 0 ?.q = 0 ?.r = 0 ?.ruler = 0 ?.s = 0 ?.scale = 0 ?.ts = 0 ?.x = 0 ?.z = 0 boxing = 0 highL = 0 LLd = 0 LLk = 0 LLx = 0 maxhic = 0

    1. = 1

hue# = 1 minhic = 1 ?.t = 1

?.bd = .2 ?.bf = 800 ?.bs = 2 ?.o = 9999 ?.rulerb = ' ' ?.scaleb = ' ' ?.scaled = . ?.scalep = '+' ?.use = . esc = '1b'x"["

his= 'H() H{} H[] H<> H≤≥ H«» H/\'

  1. his= words(his)
                do jh=1  for #his
                hh.jh= substr( word(his, jh), 2)
                end   /*jh*/

colorSupport= !pcrexx | !r4 | !roo /*colors are supported by these. */

                boxCH = '+-+|+-+|'                    /*define some boxing characters. */

if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box. */ if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box. */

if colorSupport then do /*use pre-saved color values. */

                     _= translate( !var('SCREEN'), , ";,")    /*envVar.*/
                     if \datatype( space(_, 0), "W")  then _= '36 40'
                     scr0= esc  ||  translate(0 _, ';', " ")'m'
                     colorC.0= scr0
                     colorC.1= esc"1;33m"
                     end


 do jz=1  while  zz\==
 if ?.end==1  |  pos('=',zz)==0   | pos(" "?.use,' 'zz)==0  then do
                                                                 @= @ zz
                                                                 leave
                                                                 end
 if left(zz,1)==' '  then lz=lz" "
 parse  var  zz    yy1  2  yy2  3  1  yy  ' '  zz


 if yy1==?.use  &  pos('=',yy)\==0  &  datatype(yy2, "U")  then
    do 1                                              /*process "dot" options if has =.*/
    parse  var  yy  2 _ "=" dotv 2 _1 3
    if datatype(_, 'U')  then                         /*is the option in uppercase?    */
              if length(_)==1  then do                /*is the option just one letter? */
                                    if _=='H'  then ?.hi.1= dotv
                                               else    ?._= dotv
                                    iterate jz
                                    end
                               else select            /*option is more then one letter.*/
                                    when _=='BIN'  then yy= valn("'"dotv"'B", 'BIN', "B")
                                    when _=='BOX'  then do
                                                        if dotv==""  then ?.BOX= boxCH
                                                                     else ?.BOX= dotv
                                                        iterate jz
                                                        end
                                    when _=='DEC'  then yy= valn("'"dotv"'D", 'DEC', "D")
                                    when _=='INV'  then yy= .inv(dotv)
                                    when _=='HEX'  then yy= valn("'"dotv"'X",' HEX', "X")
                                    when _=='USE'  then do
                                                        dotv= tb(dotv, "USE", .)
                                                        iterate jz
                                                        end
                                    otherwise      ?._= dotv
                                                   iterate jz
                                    end   /*select*/


    if _1=='H'  then do                                 /*special handling for:  .Hxx= */
                     _= wordpos(_, his)                 /*see the  HIS  variable above.*/
                     if _\==0  then do
                                    ?.hi._= dotv
                                    iterate jz
                                    end
                     end
    end  /*do 1*/


 if @==  then @= lz || yy
           else @= @ yy
 lz=
 end     /*jz*/


if left(@, 1)==' ' then @= substr(@, 2) /*handle this special case. */

if ?.a\==0 then call .a if ?.a\==0 then call .b if ?.block\==0 then call .block if ?.c\== then call .c if ?.d\== then call .d if ?.e\==0 then call wn 'E',0,99,sd() ?.eb= tb(?.eb, 'EB') if ?.ef\== then call .ef if ?.f\== then call .f

         do _j=1  for #his
         _= ?.hi._j
         if _\== & \!regina  then do
                                    call colors _, "H"hh._j, _j
                                    highL= 1
                                    end
         end   /*_j*/

hue.1= colorC.0

if ?.i\==0 then do

                     call wn 'I',0,sw()
                     ?.ib= tb(?.ib, 'IB')
                     end

if ?.j\== then call .j if ?.k\== then ?.k = valn(?.k, "K") if ?.kd\== then ?.kd= valn(?.kd, "KD") if ?.k\== then if ?.kd\=="" then call er 61, '.K= .KD=' if ?.ks\==0 then call .ks if ?.L\==0 then call .L if ?.o\==9999 then call .o

if ?.p\==0 then do

                     call wn 'P',-99,99
                     ?.pb= tb(?.pb, 'PB')
                     end

if ?.q\==0 then call wn 'Q',0,1 if ?.r\==0 then call wn "R",0,99 ?.r= ?.r + 1 if ?.ruler\==0 then call .ruler if ?.s\==0 then call .s ?.s= ?.s + 1 if ?.scale\==0 then call .scale if ?.t\==1 then call .t if ?.u\== then call .u ?.ub= tb(?.ub,'UB') if ?.ut\== then call .ut if ?.v\== then call .v ?.xb= tb(?.xb,'XB') if ?.z\==0 then call wn 'Z',0,99,,"N" if ?.box\== then call .box if highL then call highLight indent= copies(?.ib,?.i) if ?.x\==0 then call .x @= copies(@, ?.r) ll= length(@) if ?.ub\==' ' then @= translate(@, ?.ub, " ") _= length(?.ut) % 2 if _\==0 then @= translate(@, right(?.ut, _), left(?.ut, _) ) tx.1= @ xk= ?.k || ?.kd if xk\== then call .xk if LLk\==0 then LL= LLk

if ?.block\==0 then tLL= 12 + max(LL - 1, 0) * (12 + ?.bs)

                else tLL= LL

bline= strip(indent || x1 || copies(?.ab, tLL+4*boxing)x2, 'T')

if boxing then call ms bx.1 || copies(bx.2, LLx + tLL + 2)bx.3 caLL VEReb ?.e,?.eb


 do jt=1  for ?.t
 if jt\==1  then  if jt\==?.t  then  call VEReb ?.ts,?.tsb
   do jj=1  for ##
   if jj\==1     then call VEReb ?.ks,?.ksb
   if boxing     then _= left(tx.jj, tLL)
                 else _= tx.jj
   if ?.v=='R'   then _= reverse(_)
   if ?.u\==   then select
                      when ?.u=='A'  then nop
                      when ?.u=='U'  then upper _
                      when ?.u=='L'  then _= lower(_)
                      when ?.u=='F'  then _= proper(_)
                      when ?.u=='W'  then do
                                          __=
                                                 do jw=1  for words(_)
                                                 __= __ proper( word(_, jw) )
                                                 end   /*jw*/
                                          _= strip(__)
                                          end
                      end   /*select*/
   if ?.block==0  then call tellIt _
                  else call blocker
   end   /*jj*/
 end     /*jt*/


call VEReb ?.e,?.eb if boxing then call ms bx.7 || copies(bx.6, LLx + tLL + 2)bx.5 call beeps ?.b call .p if ?.ruler<0 then call inches ?.ruler,0 if ?.scale<0 then call inches ?.scale,1

    select
    when highL                                    then call sayHighlight
    when \highL & (?.c=='BRITE' | ?.c=="BRIGHT")  then call sayBright
    when ?.L\==0                                  then call sayAline
    otherwise                                          call sayNline
    end   /*select*/

if ?.c\== then call VMcolor VMout,space(VScolor VSdisp) if ?.b<0 then call call beeps ?.b if ?.z\==0 then call .z if ?.ruler>0 then call inches ?.ruler,0 if ?.scale>0 then call inches ?.scale,1 _= abs(?.a)

if _==99 & \?.q then !cls

                 else do  min(99, _)
                      call wit bline
                      end   /*min···*/

if ?.w\== then call .w

if !pcrexx then if ?.q & LLd>79 then if LLd>sw() then say

                                             /*(above)  PC-REXX bug:  wrapped lines are*/
                                             /*            overwritten during cleanup. */

return 0

/*──────────────────────────────────────────────────────────────────────────────────────*/ .a: call wn 'A',-99,99,sd()

        ?.ab= tb(?.ab, 'AB')
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .b: call wn 'B',-99,99,sd()

        if ?.bd\==.2   then do
                            _= translate(?.bd, , ',')
                            __= _
                                           do  while  __\==
                                           parse  var  __  ?.bd __
                                           call wn 'BD', .1, 9, ,"N"
                                           end   /*while*/
                            ?.bd= _
                            end
        if ?.bf\==800  then do
                            _= translate(?.bf, , ',')
                            __= _
                                           do  while  __\==
                                           parse  var  __  ?.bf __
                                           call wn 'BF', 1, 20000
                                           end   /*while*/
                            ?.bf= _
                            end
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .block: call wn 'BLOCK',-12,12

        if ?.bs\==2   then call wn 'BS', -12, sw()
        if ?.bc\==  then ?.bc = tb(?.bc, "BC")
        ?.bb= tb(?.bb, 'BB')
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .box: _= ?.box

        upper _
        if _=='*NONE*'  then ?.box=
        boxing= ?.box\==
        if \boxing  then return
        if _=='SINGLELINE'  then _= boxCH
        if length(_)>8      then call er 30, '.BOX='_ "boxcharacters 1 8"
        ?.box= left(_, 8, right(_,1) )
                      do _=1  for 8
                      bx._= substr(?.box, _, 1)
                      end   /*_*/
        _= verify(@, ' ')  -  1
        if _>0  then @= @ || copies(" ", _)
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .c: call colors ?.c, 'C', 0

        if !cms  then do
                      call cp 'QUERY SCREEN',1
                      parse var cp.1 "VMOUT" VMout
                      'QUERY VSCREEN CMS ALL (LIFO'
                      if rc==0  then pull "(" . . VScolor VSdisp .
                      if ?.c=='BRITE'  then call VMcolor "DEFAULT NONE"
                                       else call VMcolor color.0 ?.d, color.0  ?.d
                      end
        if \colorSupport  then ?.c=
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .d: upper ?.d

        _=    ?.d
        if \(abbrev('BRITE',     _,3)    |,
             abbrev("BRIGHT",    _,3)    |,
             abbrev('HIGHLIGHT', _)      |,
             abbrev("NONE",      _,3)    |,
             abbrev('REVVIDEO',  _,3)    |,
             abbrev("UNDERLINE", _,3) )     then call er 55, _ ".D="
        if !regina  then ?.d=                          /*Regina can't handle DISP's.   */
                    else if  left(_, 1)=='H'  then  highL= 1
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ ef: if ?.f\== then call er 61, '.F= .EF=' /*conflicting options.*/

        ?.f = ?.ef
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .f: _= ?.f /*File where the text is written.*/

        if !cms  then do
                      _= translate(_, , '/,')   /*try to translate to CMS format.*/
                      if words(_)>3  then call er 10, ?.f
                      ?.f= _ word(subword(_, 2)  !fn, 1)  word( subword(_, 3) 'A1', 1)
                      end
        __= lastpos("\", _)
        if !dos  &  ?.ef==  &  __\==0   then call $mkdir left(_, __)
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) )

/*──────────────────────────────────────────────────────────────────────────────────────*/ .j: upper ?.j

        if ?.j==  then ?.j= 'N'                     /*Justify  (or not)  the text.   */
                    else ?.j= left(?.j,1)             /*just use the first letter of .J*/
        if pos(?.j, "ACJLNR")==0  then call er 55, ?.j '.J='
        if ?.j== 'A'              then ?.j= substr( copies('LRC', 30), random(1, 90), 1)
        ?.jb= tb(?.jb, 'JB')                          /*while we're here, handle  JB.  */
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .ks: call wn 'KS', 0, 99, sw()

        ?.ksb = tb(?.ksb, 'KSB')                      /*blank lines between karate chop*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .L: upper ?.L /*Line(s) for the text is shown. */

        if !cms  then do
                      '$QWHAT DSC'
                      if rc==4  then ?.L= 0
                      end
        if ?.L=='CMSG'  then ?.L= "*"
        call wn 'L',-sd(),sd()
        if ?.L<0        then ?.L= sd() - ?.L
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .o: call wn 'O',-999,999,9999

        if ?.o<0  then do
                       onlyo= -?.o
                       ?.o= 9999
                       end
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .p: if ?.q then return /*Post (writting) blank lines. */

        _= ?.p
        if _>98 |,
           _<0  then do 1
                     if !cms       & _>9998     then call CPmore
                     !cls
                     if \!cms                   then leave  /*1*/
                     if _>9998     & more\==  then call CP 'TERMINAL MORE' more
                     if _>99999998 & hold\==  then call CP 'TERMINAL HOLD' hold
                     if _>99999998 & hold\==  then call CP 'TERMINAL HOLD' hold
                     end   /*1*/
           do  abs(_)  while _<99
           call wit bline
           end   /*abs*/
                             do _=1  to -?.a
                             call wit  bline
                             end  /*_*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */

        ?.rulerb= tb(?.rulerb, 'RULERB')
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .s: call wn "S", -999, 999, 999 /*Skip (or suppress) line(s). */

        if ?.s<0  then do
                       if left(?.o, 1)=='-'  then       /*check for conflicting options*/
                             call er 61,"O="?.o 'S='?.s "(both can't be negative)"
                       onlys = -?.s
                       ?.s   = 0
                       end
        if left(?.o, 1)=="-" & left(?.s, 1)=='-'  then
                             call er 61,"O="?.o 'S='?.s "(both can't be negative)"
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .scale: call wn 'SCALE', -sw(), sw() /*SCALE draws a "scale" line. */

        ?.scaleb= tb(?.scaleb, 'SCALEB')
        ?.scaled= tb(?.scaled, 'SCALED', .)
        ?.scalep= tb(?.scalep, 'SCALEP', "+")
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .t: call wn 'T', 0, 99 /*Times the text is written. */

        if ?.ts\==0  then call wn 'TS', 0, 99
        ?.tsb= tb(?.tsb, 'TSB')
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .u: upper ?.u /*handle uppercasing text parts. */

        ?.u= left(?.u, 1)
        if pos(?.u, " AFLUW")==0  then call er 55, ?.u  '.U='
        if ?.u==' ' | ?.u=='A'    then ?.u=
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .ut: call wn 'T', 0, 99 /*Times the text is written. */

        ?.ut= valn(?.ut, "UT")
        if length(?.ut) // 2  == 1  then
                call er 30,?.ut 'translate-characters an-even-number-of'
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .v: upper ?.v /*video mode, Normal -or- Reverse*/

        ?.v= left(?.v, 1)
        if pos(?.v, " NR")==0   then call er 55, ?.v  '.V='
        if ?.v==' ' | ?.v=='N'  then ?.v=
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .w: if ?.q then return

        if ?.wb\==  then ?.wb= tb(?.wb, 'WB')
        ww= translate(?.w, , "_")
        if ww='dd'x   then ww = "press any key to continue ..."
        if ww='de'x   then ww = "press the  ENTER  key to continue ..."
        call '$T'  ".C=yel" translate(ww,?.wb,' ')
        if ww='dd'x   then call inkey
        if ww='de'x   then pull external
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .x: call wn 'X', -sw(), sw()

        x2= copies(?.xb, abs(?.x) )
        if ?.x<0  then x1= x2
        LLx= length(x1 || x2)
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .xk: do ##=1

                 parse  var  @  _ (xk) @
                 if _==  &  @==""  then leave
                 tx.##= _
                 if @\==           then tx.## = tx.## || ?.k
                 tx.##= strip(tx.##)
                 LLk= max(LLk, length(tx.##))
                 end    /*##*/
        ##= ## - 1
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ .z: _z= word( arg(1) ?.z, 1) /*snore subroutine: zzzzzz... */

        if _z=0  then return
        if !cms  then call cp 'SLEEP'  _z  "SEC"
        if !dos  then call delay _z
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ beeps: if \!dos & !pcrexx then return /*can this OS handle sounds? */

                 do jb=1  for abs( arg(1) )
                 if jb\==1  then call delay  .1
                     do jb_=1  for words(?.bf)
                     call sound word(?.bf, jb_),  word( word(?.bd, jb_) .2, 1)
                     end   /*jb_*/
                 end       /*jb */
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ blocker: do jc=1 for LL /*process some blocked characters*/

            chbit.jc= $block(substr(_, jc, 1) )
            end   /*jc*/
        bcl= ?.block
        bcs= 1
        if bcl<0    then do
                         bcl= -bcl
                         bcs= 3 * bcl - 2
                         end
        if _==    then _=' '
        tbc = ?.bc
        if tbc==  then tbc=_
        tbc = left( copies(tbc, 1 + sw() % length(tbc) ), sw() )
          do jl=bcs  to 3*bcl  by 3
          _ = copies(?.bb, max(1, 12 * LL + ?.bs * LL - ?.bs) )
          bix = 1
                  do jo=1  for LL
                  _= overlay( translate( x2b( substr(chbit.jo, jl, 3)),,
                               substr(tbc, jo, 1)?.bb, 10), _, bix)
                  bix = max(1, bix + ?.bs + 12)
                  end   /*jo*/
          call tellIt _
          end     /*jl*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ colors: arg hue,__,cc#,cc /*verify/handle synonymous colors*/

        dark = left(hue,4)=='DARK'
        if dark                          then hue = substr(hue, 5)
        if hue=='BRITE' | hue=="BRIGHT"  then hue = 'WHITE'
        if left(hue, 5)=='BRITE'         then hue = substr(hue, 6)
        if left(hue, 6)=="BRIGHT"        then hue = substr(hue, 7)
        if abbrev('MAGENTA', hue, 3)     then hue = "PINK"
        if abbrev('CYAN'   , hue, 3)     then hue = "TURQUOIS"
        if hue=='GREY'                   then hue = "GRAY"
           do jj=1  to words(hues)  by 2
           ahue= word(hues, jj)
           if abbrev(ahue, hue, 3)   then do
                                          cc= word(hues, jj + 1)
                                          hue= ahue
                                          leave
                                          end
           end   /*jj*/
        if cc==                    then call er 50, "color" '.'__"="hue
        if dark & left(cc, 2)=='1;'  then cc= "0"substr(cc, 2)
        if !cms  then do
                      if hue='GRAY' | hue=="BLACK"  then hue= 'WHITE'
                      if hue="BROWN"                then hue= 'YELLOW'
                      end
        color.cc#  = hue
        colorC.cc# = esc || cc'm'
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ cpMore: call cp 'QUERY TERM', 9 /*parse CP TERMINAL for MORE,HOLD*/

        __=
                    do jj=1  for cp.0
                    __= __ cp.jj
                    end   /*jj*/
        parse upper var __  'MORE'  more  ','  1  'HOLD'  hold  ','
        if _>9998     & more\==  then call  cp  'TERMINAL MORE 0 0'
        if _>99999998 & hold\==  then call  cp  'TERMINAL HOLD OFF'
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ dsay: if ?.q then return /*do SAY subroutine, write to scr*/

        dsay_= strip( translate( arg(1), , '0'x), 'T')
        say dsay_
        LLd= length(dsay_)                            /*length of last line displayed. */
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ highLight: do _=1 for 7

              hhl._  = color._\==
              hics._ =  left(hh._, 1)
              hice._ = right(hh._, 1)
              if hhl._  then do
                             minhic= min(_, minhic);      shics= shics || hics._
                             maxhic= max(_, maxhic);      ehics= ehics || hice._
                             end
              end   /*_*/
        ahics= shics || ehics
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ hue: hue#= max(1, hue# + arg(1) )

        __= arg(2)
        if __\==  then hue.hue#= __
        _=
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ inches: _= kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED')

                                                      /*handle  RULER and SCALE  stuff.*/
        if arg(2)  then _= $scale(?.scale _ 'Q')
                   else _= $scale(?.ruler 'RULE' _ "Q")
        parse  var  _    _.1  '9'x  _.2  '9'x  _.3
                   do jk=1  for 3
                   _= _.jk
                   if _\==  then call wit _
                   end   /*jk*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ ms: #ms= #ms + 1 /*justification and indentation. */

        parse  arg  _i
               select
               when ?.j==             then nop
               when ?.N=='N'            then nop
               when length(_i)>=sw()-1  then nop
               when ?.j=='C'            then _i= centre(_i, sw() - 1, ?.jb)
               when ?.j=='L'            then _i= strip(_i)
               when ?.j=='R'            then _i= right( strip(_i, "T"), sw() - 1)
               when ?.j=='J'            then _i= justify(_i, sw() - 1, ?.jb)
               end   /*select*/
        mm.#ms= strip(indent || _i, 'T')
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ sayAline:

               do jj=?.s  to #ms  for ?.o
               if skp()  then iterate
               if \?.q   then do
                              if !cms  then '$CLEAR .WL='?.L _mm
                              if !dos  then call dsay,
                                     esc || (?.L - 1) || ";0f"colorC.0 || _mm || scr0
                              end
               call wr _mm
               ?.L= ?.L + 1
               if ?.L>sd()  then ?.L= 1
               end   /*jj*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ sayBrite: do jj=?.s to #ms for ?.o

               if skp()  then iterate
               call wr _mm
               if ?.q    then iterate
               if !cms   then '$CLEAR .C=BRITE' _mm
                         else if  !dos  then call dsay colorC.0 || _mm || scr0
               end   /*jj*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ sayNline: do jj=?.s to #ms for ?.o

               if skp()  then iterate
               if !dos  then do
                             if ?.c==  then call dsay _mm
                                         else call dsay colorC.0 || _mm || scr0
                             call wr _mm
                             end
                        else call wit _mm
               end   /*jj*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ sayHighlight:

               do jj=?.s  to #ms  for ?.o
               if skp()   then iterate
               if !cms    then do
                               if \?.q  then '$CLEAR .C=HIGHL' _mm
                               iterate
                               end
               lenmm= length(_mm)
               __= verify(_mm, ahics, 'M')
               if __==0   then hc= lenmm + 1
                          else hc= __
               _xx= hue.1
               if hc>1    then _xx= _xx || left(_mm, hc - 1)


                     do jl=hc  to lenmm
                     _= substr(_mm, jl, 1)
                       do jc=minhic  to maxhic
                       if hhl.jc  then  if _==hics.jc  then call hue 1, colorC.jc
                                                       else if _==hice.jc  then call hue - 1
                       end  /*jc*/
                     if _==  then _xx= _xx" "
                     __= verify( substr(_mm, jl + 1), ahics, 'M')
                     if __==0  then pl= lenmm - jl + 1
                               else pl= __
                     if pl==1  then iterate
                     _xx= _xx || hue.hue# || substr(_mm, jl + 1, pl - 1)
                     jl= jl + pl - 1
                     end   /*jl*/


              if length(_xx)>sw()  then if lenmm<=sw()  then _xx = esc's'_xx || esc"u"
              call dsay _xx || scr0
              call wr _mm
              end   /*jj*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ skp: if (onlyo\== & onlyo\==jj) | (onlys\=="" & onlys ==jj) then return 1

        _mm= mm.jj
        return 0

/*──────────────────────────────────────────────────────────────────────────────────────*/ tb: tb= arg(1) /*test|verify Blank specification*/

        if tb==         then return left(arg(3), 1)
        if length(tb)==2  then return valn("'"tb"'X", arg(2), 'X')
        if length(tb)>1   then call er 30, tb "."arg(2)'=' 1
        return tb

/*──────────────────────────────────────────────────────────────────────────────────────*/ tellIt: ___= arg(1) /*tell it to the display terminal*/

                        ___= x1 || ___ || x2
        if boxing  then ___= bx.8 || ?.eb || ___ || ?.eb || bx.4
        call ms ___
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ valn: procedure; parse arg x,n,k /*validate number (dec,bin,hex). */

        _= left(x, 1)
        v= "."n'='
        if (_\=='"' & _\=="'")  |  ((right(x,2)\==_||k)  &  k\==)  then return x
        arg ' '  -1  t
        x= substr(x, 2, length(x) - 3)
        _= length(x)
        if t=='X'  then do
                        if \datatype(x, t)  then call er 40, x v
                        return x2c(x)
                        end
        if t=='B'  then do
                        if \datatype(x, t)  then call er 91, x v
                        return x2c(b2x(x))
                        end
        if \datatype(x, 'W')                then call er 53, x v
        return d2c(x)

/*──────────────────────────────────────────────────────────────────────────────────────*/ VEReb: if arg(1)==0 then return /*character for Extra Blank(s). */

        eb_ = x1 || copies(?.eb,tLL)x2
        if boxing  then eb_= bx.8 || ?.eb || eb_ || ?.eb || bx.4
                do jeb=1  for arg(1)
                call  ms  eb_
                end   /*jeb*/
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ VMcolor: if \!cms then return

        parse  arg  c1,c2
        if c1\==  then call cp "SCREEN VMOUT"  c1
        if c2\==  then    "SET VSCREEN CMS"    c2
        return

/*──────────────────────────────────────────────────────────────────────────────────────*/ wn: procedure expose ?. /*normalize, validate N in range.*/

        arg  z, L, H, d, t
        _= ?.z
        parse  upper  var  _  f 2
        m= pos(f, 'MH')\==0
        if m | f=='*'  then do
                            _= (word(d H L sw(), 1)) / word(1 2,  m + 1)substr(_, 2)
                            if \datatype(_,"N")  then interpret '_=' translate(_,"%",'/')
                            ?.z= _
                            end
        if  datatype(_, "N")             then ?.z= _ / 1
        if \datatype(_, left(t"W", 1) )  then call er 53, _ '.'z"="
        if L\==  then  if _<L  |  _>H  then call er 81, L H _ "value for option ."z'='
        return _

/*──────────────────────────────────────────────────────────────────────────────────────*/ wr: parse arg wr /*write [argument 1] ───> disk. */

        if ?.f==             then return            /*Nothing to write? Then skip it.*/
        if highL & ahics\==  then wr= translate(wr, , ahics)      /*has highlighting?*/
        if !cms | !tso         then 'EXECIO 1 DISKW'  ?.f  "(FINIS STRING"  wr
                               else call lineout  ?.f, translate(wr, '10'x, "1a"x)
                                                      /*(above) Handle E-O-F character.*/
        call lineout ?.f                              /*close the output file.         */
        return 0

/*══════════════════════════════════════════════════════════════════════════════════════*/ !all: !!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=; return 1 !cal: if symbol('!CALL')\=="VAR" then !call=; return !call !env: !env='ENVIRONMENT'; if !sys=="MSDOS" | !brexx | !r4 | !roo then !env='SYSTEM'; if !os2 then !env="OS2"!env; !ebcdic= 3=='f3'x; if !crx then !env='DOS'; return !fid: parse upper source !sys !fun !fid . 1 . . !fn !ft !fm .; call !sys; if !dos then do; _= lastpos('\', !fn); !fm= left(!fn, _); !fn= substr(!fn, _+1); parse var !fn !fn '.' !ft; end; return word(0 !fn !ft !fm, 1 +('0'arg(1))) !rex: parse upper version !ver !vernum !verdate .; !brexx= 'BY'==!vernum; !kexx= 'KEXX'==!ver; !pcrexx= 'REXX/PERSONAL'==!ver | 'REXX/PC'==!ver; !r4= 'REXX-R4'==!ver; !regina= 'REXX-REGINA'==left(!ver,11); !roo= 'REXX-ROO'==!ver; call !env; return !sys: !cms= !sys=='CMS'; !os2= !sys=="OS2"; !tso= !sys=='TSO' | !sys=="MVS"; !vse= !sys=='VSE'; !dos= pos("DOS", !sys)\==0 | pos('WIN', !sys)\==0 | !sys=="CMD"; !crx= left(!sys, 6)=='DOSCRX'; call !rex; return !var: call !fid; if !kexx then return space( dosenv(arg(1) ) ); return space( value(arg(1), , !env) ) $block: !call= '$BLOCK'; call "$BLOCK" arg(1); !call=; return result $mkdir: !call= '$MKDIR'; call "$MKDIR" arg(1); !call=; return result $scale: !call= '$SCALE'; call "$SCALE" arg(1); !call=; return result cp: "EXECIO" '0'arg(2) "CP(STEM CP. STRING" arg(1); return rc er: parse arg _1,_2; call '$ERR' "14"p(_1) p(word(_1,2) !fid(1)) _2; if _1<0 then return _1; exit result p: return word( arg(1), 1) halt: call er .1 kw: parse arg kw; return kw c2x(?.kw) lower: return translate( arg(1), @abc, @abcu) noValue: !sigl= sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) proper: procedure; arg f 2; parse arg 2 r; return f || r sd: if ?.scrdepth== then parse value scrsize() with  ?.scrdepth ?.linesize .; return ?.scrdepth sw: if ?.linesize== then ?.linesize= linesize(); return ?.linesize syntax: !sigl= sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl) wit: call dsay arg(1); call wr arg(1); return</lang>



Programming note:   this REXX program makes use of   DELAY   BIF which delays (sleeps) for a specified amount of seconds.
Some REXXes don't have a   DELAY   BIF,   so one is included here   ──►   DELAY.REX.

Cookies help us deliver our services. By using our services, you agree to our use of cookies.