$T.REX: Difference between revisions
m (→$T.REX: added comments to the section header. -- ~~~~) |
m (→$T.REX: elided duplicated code (from cut-n-paste).) |
||
(22 intermediate revisions by 2 users not shown) | |||
Line 1: | Line 1: | ||
[[Category:REXX library routines]] |
|||
==$T.REX== |
==$T.REX== |
||
This is the '''$T.REX''' (REXX) program which is used by other REXX programs to display |
This is the '''$T.REX''' (REXX) program which is used by many other REXX programs to display error or informational message(s), |
||
<br>some of the options |
<br>some of the options are: |
||
* in color(s) (if supported) |
::* in color(s) (if supported) |
||
* highlights (in color) parts (up to 8 unique parts) of the text (if supported) |
::* highlights (in color) parts (up to 8 unique parts) of the text (if supported) |
||
* write text to a file |
::* write text to a file |
||
* breaks the text into multiple lines |
::* breaks/splits the text into multiple lines |
||
* adds indentation |
::* adds indentation |
||
* justifies the text: left/right/center/justify ( |
::* justifies the text: left/right/center/justify (auto-fill) |
||
* add blank lines before and/or after the displaying of text |
::* add blank lines before and/or after the displaying of text |
||
* boxing (around) the text |
::* boxing (around) the text |
||
* add spacing around the text inside the box |
::* add spacing around the text inside the box |
||
* only showing specific lines of the text messages |
::* only showing specific lines of the text messages |
||
* suppressing specific lines of the text messages |
::* suppressing specific lines of the text messages |
||
* translation of |
::* translation of specific characters in the text |
||
* allowing other characters to be used for blanks |
::* allowing other characters to be used for blanks |
||
* repeating a text |
::* repeating a text |
||
* allows remarks in the text |
::* allows remarks in the text |
||
* writes the message, waits for a confirmation to proceed |
::* writes the message, waits for a confirmation to proceed |
||
* delaying (waiting) after the text is displayed |
::* delaying (waiting) after the text is displayed |
||
* showing a scale and/or a ruler above/below the text message(s) |
::* showing a scale and/or a ruler above/below the text message(s) |
||
* supports hex/dec/bit strings |
::* supports hex/dec/bit strings |
||
* changing the case of the text |
::* changing the case of the text |
||
* reverses the text |
::* reverses the text |
||
* inverts the bits for certain characters |
::* inverts the bits for certain characters |
||
* sounds alarm (beeps) after the text is displayed (if supported) |
::* sounds alarm (beeps) after the text is displayed (if supported) |
||
* displays the text in reverse video (if supported) |
::* displays the text in reverse video (if supported) |
||
* displays the text in (big) block letters |
::* displays the text in (big) block letters |
||
* clear the screen after or before the displaying of text |
::* clear the screen after or before the displaying of text |
||
* allows user-define option character, the default is '''.''' (period) |
::* allows user-define option character, the default is '''.''' (period) |
||
* and many other options |
::* and many other options |
||
<lang rexx>/**/ trace off /* There be many dragons below. */ |
|||
parse arg ! |
|||
The help for the '''$T''' REXX program is included here ──► [[$T.HEL]]. |
|||
if !all(0) then exit /*help options and boilerplate.*/ |
|||
The '''$T''' REXX program makes use of '''$ERR''' REXX program which is used to display error messages (via '''$T'''). |
|||
<br>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'''). |
|||
<br>The '''$BLOCK''' REXX program is included here ──► [[$BLOCK.REX]]. |
|||
The '''$T''' REXX program makes use of '''LINESIZE''' BIF which returns the terminals width (linesize). |
|||
<br>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. |
|||
<br>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. |
|||
<br>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. |
|||
<br>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*/ |
|||
if !cms then 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. */ |
hues=space( 'BLACK 0;30', /*define some colors for DOS. */ |
||
'BROWN 0;33', |
'BROWN 0;33', |
||
'DEFAULT 1;37', |
'DEFAULT 1;37', |
||
Line 52: | Line 91: | ||
'YELLOW 1;33', |
'YELLOW 1;33', |
||
'WHITE 1;37', |
'WHITE 1;37', |
||
'BRITE 1;37') /*colors for DOS via ANSI.SYS */ |
'BRITE 1;37') /*colors for DOS via ANSI.SYS */ |
||
_= /*(below) set some vars ──> NULL */ |
_= /*(below) set some vars ──> NULL */ |
||
parse var _ ?. @ color. colorC. ahics ehics hold lz more onlyo onlys, |
parse var _ ?. @ color. colorC. ahics ehics hold lz more onlyo onlys, |
||
scr0 shics VMout VScolor VSdisp x1 x2 |
scr0 shics VMout VScolor VSdisp x1 x2 |
||
@abc = 'abcdefghijklmnopqrstuvwxyz' |
@abc = 'abcdefghijklmnopqrstuvwxyz' |
||
@abcU = @abc |
|||
upper @abcU |
|||
#ms = 0 |
#ms = 0 |
||
?.a = 0 |
?.a = 0 |
||
?.b = 0 |
?.b = 0 |
||
?.block = 0 |
?.block = 0 |
||
?.e = 0 |
?.e = 0 |
||
?.end = 0 |
?.end = 0 |
||
?.i = 0 |
?.i = 0 |
||
?.ks = 0 |
?.ks = 0 |
||
?.L = 0 |
?.L = 0 |
||
?.p = 0 |
?.p = 0 |
||
?.q = 0 |
?.q = 0 |
||
?.r = 0 |
?.r = 0 |
||
?.ruler = 0 |
?.ruler = 0 |
||
?.s = 0 |
?.s = 0 |
||
?.scale = 0 |
?.scale = 0 |
||
?.ts = 0 |
?.ts = 0 |
||
?.x = 0 |
?.x = 0 |
||
?.z = 0 |
?.z = 0 |
||
boxing = 0 |
boxing = 0 |
||
highL = 0 |
highL = 0 |
||
LLd = 0 |
LLd = 0 |
||
LLk = 0 |
LLk = 0 |
||
LLx = 0 |
LLx = 0 |
||
maxhic = 0 |
maxhic = 0 |
||
## = 1 |
## = 1 |
||
Line 90: | Line 131: | ||
?.t = 1 |
?.t = 1 |
||
?.bd |
?.bd = .2 |
||
?.bf |
?.bf = 800 |
||
?.bs |
?.bs = 2 |
||
?.o |
?.o = 9999 |
||
?.rulerb |
?.rulerb = ' ' |
||
?.scaleb |
?.scaleb = ' ' |
||
?.scaled |
?.scaled = . |
||
?.scalep |
?.scalep = '+' |
||
?.use |
?.use = . |
||
esc |
esc = '1b'x"[" |
||
his='H() H{} H[] H<> H≤≥ H«» H/\ |
his= 'H() H{} H[] H<> H≤≥ H«» H/\' |
||
#his= words(his) |
|||
do jh=1 for 7 |
|||
hh.jh=substr(word(his,jh),2) |
|||
end /*jh*/ |
|||
do jh=1 for #his |
|||
hh.jh= substr( word(his, jh), 2) |
|||
if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box.*/ |
|||
end /*jh*/ |
|||
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box.*/ |
|||
colorSupport= !pcrexx | !r4 | !roo /*colors are supported by these. */ |
|||
_=translate(!var('SCREEN'), ,";,") /*envVar*/ |
|||
boxCH = '+-+|+-+|' /*define some boxing characters. */ |
|||
if !ebcdic then boxCH = 'acbfbcfabbbfabfa'x /*¼┐╝·╗┐½· <──single box. */ |
|||
scr0=esc || translate(0 _, ';', " ")'m' |
|||
if !dos then boxCH = 'c9cdbbbabccdc8ba'x /*╔═╗║╝═╚║ <──double box. */ |
|||
colorC.1=esc"1;33m" |
|||
if colorSupport then do /*use pre-saved color values. */ |
|||
_= translate( !var('SCREEN'), , ";,") /*envVar.*/ |
|||
do jz=1 while zz\=='' |
|||
if \datatype( space(_, 0), "W") then _= '36 40' |
|||
if ?.end==1 | pos('=',zz)==0 | pos(" "?.use,' 'zz)==0 then do |
|||
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" " |
if left(zz,1)==' ' then lz=lz" " |
||
parse var zz yy1 2 yy2 3 1 yy ' ' zz |
parse var zz yy1 2 yy2 3 1 yy ' ' zz |
||
if yy1==?.use & pos('=',yy)\==0 & datatype(yy2,"U") then |
|||
do 1 |
|||
parse var yy 2 _ "=" dotv 2 _1 3 |
|||
if datatype(_,'U') then |
|||
do |
|||
L1=length(_)==1 |
|||
if L1 then do |
|||
if _=='H' then ?.hi.1=dotv |
|||
else ?._=dotv |
|||
iterate jz |
|||
end |
|||
else select |
|||
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*/ |
|||
end |
|||
if yy1==?.use & pos('=',yy)\==0 & datatype(yy2, "U") then |
|||
if _1=='H' then do |
|||
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 |
if _\==0 then do |
||
?.hi._=dotv |
?.hi._= dotv |
||
iterate jz |
iterate jz |
||
end |
end |
||
end |
end |
||
end /*1*/ |
end /*do 1*/ |
||
if @=='' then @=lz || yy |
|||
if @=='' then @= lz || yy |
|||
else @= @ yy |
|||
lz= |
lz= |
||
end /*jz*/ |
end /*jz*/ |
||
if left(@,1)==' ' then @=substr(@,2) /*handle this special case. */ |
|||
if left(@, 1)==' ' then @= substr(@, 2) /*handle this special case. */ |
|||
if ?.a\==0 then call .a |
if ?.a\==0 then call .a |
||
Line 174: | Line 226: | ||
if ?.block\==0 then call .block |
if ?.block\==0 then call .block |
||
if ?.c\=='' then call .c |
if ?.c\=='' then call .c |
||
hue.1=colorC.0 |
|||
if ?.d\=='' then call .d |
if ?.d\=='' then call .d |
||
if ?.e\==0 then call wn 'E',0,99,sd() |
if ?.e\==0 then call wn 'E',0,99,sd() |
||
?.eb=tb(?.eb,'EB') |
?.eb= tb(?.eb, 'EB') |
||
if ?.ef\=='' then call .ef |
if ?.ef\=='' then call .ef |
||
if ?.f\=='' then call .f |
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 ?.i\==0 then do; call wn 'I',0,sw(); ?.ib=tb(?.ib,'IB'); end |
|||
if ?.j\=='' then call .j |
if ?.j\=='' then call .j |
||
if ?.k\=='' then ?.k =valn(?.k,"K") |
if ?.k\=='' then ?.k = valn(?.k, "K") |
||
if ?.kd\=='' then ?.kd=valn(?.kd,"KD") |
if ?.kd\=='' then ?.kd= valn(?.kd, "KD") |
||
if ?.k\=='' then if ?.kd\=="" then call er 61, '.K= .KD=' |
if ?.k\=='' then if ?.kd\=="" then call er 61, '.K= .KD=' |
||
if ?.ks\==0 then call .ks |
if ?.ks\==0 then call .ks |
||
if ?.L\==0 then call .L |
if ?.L\==0 then call .L |
||
if ?.o\==9999 then call .o |
if ?.o\==9999 then call .o |
||
if ?.p\==0 then do; call wn 'P',-99,99; ?.pb=tb(?.pb,'PB'); end |
|||
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 ?.q\==0 then call wn 'Q',0,1 |
||
if ?.r\==0 then call wn "R",0,99 |
if ?.r\==0 then call wn "R",0,99 |
||
?.r= ?.r + 1 |
|||
if ?.ruler\==0 then call .ruler |
if ?.ruler\==0 then call .ruler |
||
if ?.s\==0 then call .s |
if ?.s\==0 then call .s |
||
?.s= ?.s + 1 |
|||
if ?.scale\==0 then call .scale |
if ?.scale\==0 then call .scale |
||
if ?.t\==1 then call .t |
if ?.t\==1 then call .t |
||
if ?.u\=='' then call .u |
if ?.u\=='' then call .u |
||
?.ub=tb(?.ub,'UB') |
?.ub= tb(?.ub,'UB') |
||
if ?.ut\=='' then call .ut |
if ?.ut\=='' then call .ut |
||
if ?.v\=='' then call .v |
if ?.v\=='' then call .v |
||
?.xb=tb(?.xb,'XB') |
?.xb= tb(?.xb,'XB') |
||
if ?.z\==0 then call wn 'Z',0,99,,"N" |
if ?.z\==0 then call wn 'Z',0,99,,"N" |
||
if ?.box\=='' then call .box |
if ?.box\=='' then call .box |
||
if highL then call highLight |
if highL then call highLight |
||
indent=copies(?.ib,?.i) |
indent= copies(?.ib,?.i) |
||
if ?.x\==0 then call .x |
if ?.x\==0 then call .x |
||
@=copies(@,?.r) |
@= copies(@, ?.r) |
||
ll=length(@) |
ll= length(@) |
||
if ?.ub\==' ' then @=translate(@,?.ub," ") |
if ?.ub\==' ' then @= translate(@, ?.ub, " ") |
||
_=length(?.ut)%2 |
_= length(?.ut) % 2 |
||
if _\==0 then @=translate(@,right(?.ut,_),left(?.ut,_)) |
if _\==0 then @= translate(@, right(?.ut, _), left(?.ut, _) ) |
||
tx.1=@ |
tx.1= @ |
||
xk=?.k || ?.kd |
xk= ?.k || ?.kd |
||
if xk\=='' then call .xk |
if xk\=='' then call .xk |
||
if LLk\==0 then LL=LLk |
if LLk\==0 then LL= LLk |
||
if ?.block\==0 then tLL=12+max(LL-1,0)*(12+?.bs) |
if ?.block\==0 then tLL= 12 + max(LL - 1, 0) * (12 + ?.bs) |
||
else tLL=LL |
else tLL= LL |
||
bline=strip(indent || x1 || copies(?.ab, tLL+4*boxing)x2, 'T') |
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 |
if boxing then call ms bx.1 || copies(bx.2, LLx + tLL + 2)bx.3 |
||
caLL VEReb ?.e,?.eb |
caLL VEReb ?.e,?.eb |
||
do jt=1 for ?.t |
do jt=1 for ?.t |
||
Line 238: | Line 303: | ||
if jj\==1 then call VEReb ?.ks,?.ksb |
if jj\==1 then call VEReb ?.ks,?.ksb |
||
if boxing then _=left(tx.jj,tLL) |
if boxing then _= left(tx.jj, tLL) |
||
else _=tx.jj |
else _= tx.jj |
||
if ?.v=='R' then _=reverse(_) |
if ?.v=='R' then _= reverse(_) |
||
if ?.u\=='' then select |
if ?.u\=='' then select |
||
when ?.u=='A' then nop |
when ?.u=='A' then nop |
||
when ?.u=='U' then upper _ |
when ?.u=='U' then upper _ |
||
when ?.u=='L' then _=lower(_) |
when ?.u=='L' then _= lower(_) |
||
when ?.u=='F' then _=proper(_) |
when ?.u=='F' then _= proper(_) |
||
when ?.u=='W' then do |
when ?.u=='W' then do |
||
__= |
__= |
||
do jw=1 for words(_) |
do jw=1 for words(_) |
||
__=__ proper(word(_,jw)) |
__= __ proper( word(_, jw) ) |
||
end /*jw*/ |
end /*jw*/ |
||
_=strip(__) |
_= strip(__) |
||
end |
end |
||
end /*select*/ |
end /*select*/ |
||
if ?.block==0 then call tellIt _ |
if ?.block==0 then call tellIt _ |
||
else call blocker |
else call blocker |
||
end /*jj*/ |
end /*jj*/ |
||
end /*jt*/ |
end /*jt*/ |
||
call VEReb ?.e,?.eb |
call VEReb ?.e,?.eb |
||
if boxing then call ms bx.7 || copies(bx.6,LLx+tLL+2)bx.5 |
if boxing then call ms bx.7 || copies(bx.6, LLx + tLL + 2)bx.5 |
||
call beeps ?.b |
call beeps ?.b |
||
call .p |
call .p |
||
Line 270: | Line 336: | ||
if ?.scale<0 then call inches ?.scale,1 |
if ?.scale<0 then call inches ?.scale,1 |
||
select |
|||
select /* <══════════════════════════where the rubber meets the road.*/ |
|||
when highL then call sayHighlight |
when highL then call sayHighlight |
||
when \highL & (?.c=='BRITE' | ?.c=="BRIGHT") then call sayBright |
when \highL & (?.c=='BRITE' | ?.c=="BRIGHT") then call sayBright |
||
when ?.L\==0 then call sayAline |
when ?.L\==0 then call sayAline |
||
otherwise call sayNline |
otherwise call sayNline |
||
end /*select*/ |
end /*select*/ |
||
if ?.c\=='' then call VMcolor VMout,space(VScolor VSdisp) |
if ?.c\=='' then call VMcolor VMout,space(VScolor VSdisp) |
||
Line 282: | Line 348: | ||
if ?.ruler>0 then call inches ?.ruler,0 |
if ?.ruler>0 then call inches ?.ruler,0 |
||
if ?.scale>0 then call inches ?.scale,1 |
if ?.scale>0 then call inches ?.scale,1 |
||
_=abs(?.a) |
_= abs(?.a) |
||
if _==99 & \?.q then !cls |
if _==99 & \?.q then !cls |
||
else do min(99,_) |
else do min(99, _) |
||
call wit bline |
call wit bline |
||
end /*min |
end /*min···*/ |
||
if ?.w\=='' then call .w |
if ?.w\=='' then call .w |
||
if !pcrexx then if ?.q & LLd>79 then if LLd>sw() then say |
if !pcrexx then if ?.q & LLd>79 then if LLd>sw() then say |
||
/*(above) PC-REXX bug: wrapped lines are */ |
|||
/*(above) PC-REXX bug: wrapped lines are*/ |
|||
/* overwritten during cleanup. */ |
|||
return 0 |
return 0 |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.B subroutine───────────────────────*/ |
|||
. |
.a: call wn 'A',-99,99,sd() |
||
?.ab= tb(?.ab, 'AB') |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if ?.bd\==.2 then do |
|||
.b: call wn 'B',-99,99,sd() |
|||
__=_ |
|||
do while __\=='' |
|||
parse var __ ?.bd __ |
|||
call wn 'BD', .1, 9, ,"N" |
|||
end /*while*/ |
|||
?.bd=_ |
|||
end |
|||
if ?. |
if ?.bd\==.2 then do |
||
_=translate(?. |
_= translate(?.bd, , ',') |
||
__=_ |
__= _ |
||
do while __\=='' |
do while __\=='' |
||
parse var __ ?. |
parse var __ ?.bd __ |
||
call wn ' |
call wn 'BD', .1, 9, ,"N" |
||
end /*while*/ |
end /*while*/ |
||
?. |
?.bd= _ |
||
end |
end |
||
return |
|||
if ?.bf\==800 then do |
|||
/*──────────────────────────────────.BLOCK subroutine───────────────────*/ |
|||
_= translate(?.bf, , ',') |
|||
.block: call wn 'BLOCK',-12,12 |
|||
__= _ |
|||
do while __\=='' |
|||
parse var __ ?.bf __ |
|||
?.bb=tb(?.bb,'BB') |
|||
call wn 'BF', 1, 20000 |
|||
return |
|||
end /*while*/ |
|||
?.bf= _ |
|||
end |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.BOX subroutine─────────────────────*/ |
|||
.block: call wn 'BLOCK',-12,12 |
|||
.box: _=?.box; upper _ |
|||
if _=='*NONE*' then ?.box= |
|||
boxing= ?.box\=='' |
|||
if \boxing then return |
|||
if ?.bs\==2 then call wn 'BS', -12, sw() |
|||
if _=='SINGLELINE' then _=boxCH |
|||
if ?.bc\=='' then ?.bc = tb(?.bc, "BC") |
|||
?.box=left(_,8,right(_,1)) |
|||
do _=1 for 8 |
|||
bx._=substr(?.box,_,1) |
|||
end /*_*/ |
|||
_=verify(@,' ')-1 |
|||
if _>0 then @=@ || copies(" ",ldb) |
|||
return |
|||
?.bb= tb(?.bb, 'BB') |
|||
/*──────────────────────────────────.C subroutine───────────────────────*/ |
|||
return |
|||
.c: call colors ?.c,'C',0 |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if !cms then do |
|||
.box: _= ?.box |
|||
call cp 'QUERY SCREEN',1 |
|||
upper _ |
|||
if _=='*NONE*' then ?.box= |
|||
boxing= ?.box\=='' |
|||
if rc==0 then pull "(" . . VScolor VSdisp . |
|||
if \boxing then return |
|||
else call VMcolor color.0 ?.d, color.0 ?.d |
|||
end |
|||
if _=='SINGLELINE' then _= boxCH |
|||
if !regina then ?.c= /*Regina can't handle colors. */ |
|||
if length(_)>8 then call er 30, '.BOX='_ "boxcharacters 1 8" |
|||
return |
|||
?.box= left(_, 8, right(_,1) ) |
|||
/*──────────────────────────────────.D subroutine───────────────────────*/ |
|||
.d: upper ?.d |
|||
_ = ?.d |
|||
do _=1 for 8 |
|||
if \(abbrev('BRITE',_,3) |, |
|||
bx._= substr(?.box, _, 1) |
|||
abbrev("BRIGHT",_,3) |, |
|||
end /*_*/ |
|||
abbrev('HIGHLIGHT',_) |, |
|||
abbrev("NONE",_,3) |, |
|||
abbrev('REVVIDEO',_,3) |, |
|||
abbrev("UNDERLINE",_,3)) then call er 55, _ ".D=" |
|||
_= verify(@, ' ') - 1 |
|||
if !regina then ?.d= /*Regina can't handle DISP's. */ |
|||
if _>0 then @= @ || copies(" ", _) |
|||
return |
return |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.EF subroutine──────────────────────*/ |
|||
.c: call colors ?.c, 'C', 0 |
|||
?.f = ?.ef |
|||
return |
|||
if !cms then do |
|||
/*──────────────────────────────────.F subroutine───────────────────────*/ |
|||
call cp 'QUERY SCREEN',1 |
|||
parse var cp.1 "VMOUT" VMout |
|||
if !cms then do |
|||
'QUERY VSCREEN CMS ALL (LIFO' |
|||
if |
if rc==0 then pull "(" . . VScolor VSdisp . |
||
?.f = _ word(subword(_,2) !fn,1) word(subword(_,3) 'A1',1) |
|||
end |
|||
if ?.c=='BRITE' then call VMcolor "DEFAULT NONE" |
|||
__=lastpos("\",_) |
|||
else call VMcolor color.0 ?.d, color.0 ?.d |
|||
if !dos & ?.ef=='' & __\==0 then call $mkdir left(_,__) |
|||
end |
|||
return |
|||
if \colorSupport then ?.c= |
|||
/*──────────────────────────────────.INV subroutine─────────────────────*/ |
|||
return |
|||
.inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) ) |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.J subroutine───────────────────────*/ |
|||
.d: upper ?.d |
|||
.j: upper ?.j /*Justify (or not) the text. */ |
|||
_= ?.d |
|||
if ?.j=='' then ?.j = 'N' /*Justify (or not) the text. */ |
|||
else ?.j=left(?.j,1) /*just use the first letter of .J*/ |
|||
if \(abbrev('BRITE', _,3) |, |
|||
if pos(?.j,"ACJLNR")==0 then call er 55, ?.j '.J=' |
|||
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 |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.KS subroutine──────────────────────*/ |
|||
ef: if ?.f\=='' then call er 61, '.F= .EF=' /*conflicting options.*/ |
|||
.ks: call wn 'KS', 0, 99, sw() |
|||
?.f = ?.ef |
|||
?.ksb = tb(?.ksb, 'KSB') /*blank lines between karate chop*/ |
|||
return |
return |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.L subroutine───────────────────────*/ |
|||
. |
.f: _= ?.f /*File where the text is written.*/ |
||
if !cms then do |
if !cms then do |
||
_= translate(_, , '/,') /*try to translate to CMS format.*/ |
|||
if |
if words(_)>3 then call er 10, ?.f |
||
?.f= _ word(subword(_, 2) !fn, 1) word( subword(_, 3) 'A1', 1) |
|||
end |
|||
__= lastpos("\", _) |
|||
if ?.L=='CMSG' then ?.L="*" |
|||
if !dos & ?.ef=='' & __\==0 then call $mkdir left(_, __) |
|||
call wn 'L',-sd(),sd() |
|||
return |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.O subroutine───────────────────────*/ |
|||
.inv: return x2c( b2x( translate( x2b( c2x( arg(1) ) ), 01, 10) ) ) |
|||
.o: call wn 'O',-999,999,9999 |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if ?.o<0 then do |
|||
.j: upper ?.j |
|||
if ?.j=='' then ?.j= 'N' /*Justify (or not) the text. */ |
|||
?.o=9999 |
|||
else ?.j= left(?.j,1) /*just use the first letter of .J*/ |
|||
end |
|||
return |
|||
if pos(?.j, "ACJLNR")==0 then call er 55, ?.j '.J=' |
|||
/*──────────────────────────────────.P subroutine───────────────────────*/ |
|||
if ?.j== 'A' then ?.j= substr( copies('LRC', 30), random(1, 90), 1) |
|||
_=?.p |
|||
?.jb= tb(?.jb, 'JB') /*while we're here, handle JB. */ |
|||
if _>98 |, |
|||
return |
|||
if !cms & _>9998 then call CPmore |
|||
!cls |
|||
if \!cms then leave /*1*/ |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if _>9998 & more\=='' then call CP 'TERMINAL MORE' more |
|||
.ks: call wn 'KS', 0, 99, sw() |
|||
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold |
|||
?.ksb = tb(?.ksb, 'KSB') /*blank lines between karate chop*/ |
|||
if _>99999998 & hold\=='' then call CP 'TERMINAL HOLD' hold |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
do abs(_) while _<99 |
|||
.L: upper ?.L /*Line(s) for the text is shown. */ |
|||
call wit bline |
|||
end /*abs*/ |
|||
do _=1 to -?.a |
|||
call wit bline |
|||
end /*_*/ |
|||
return |
|||
if !cms then do |
|||
/*──────────────────────────────────.RULER subroutine───────────────────*/ |
|||
'$QWHAT DSC' |
|||
.ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */ |
|||
if rc==4 then ?.L= 0 |
|||
?.rulerb = tb(?.rulerb, 'RULERB') |
|||
end |
|||
return |
|||
if ?.L=='CMSG' then ?.L= "*" |
|||
/*──────────────────────────────────.S subroutine───────────────────────*/ |
|||
.s: call wn "S", -999, 999, 999 /*Skip (or suppress) line(s). */ |
|||
call wn 'L',-sd(),sd() |
|||
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 ?.L<0 then ?.L= sd() - ?.L |
|||
if left(?.o,1)=="-" & left(?.s,1)=='-' then |
|||
return |
|||
call er 61,"O="?.o 'S='?.s "(both can't be negative)" |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.SCALE subroutine───────────────────*/ |
|||
. |
.o: call wn 'O',-999,999,9999 |
||
?.scaleb = tb(?.scaleb, 'SCALEB') |
|||
?.scaled = tb(?.scaled, 'SCALED', ".") |
|||
?.scalep = tb(?.scalep, 'SCALEP', "+") |
|||
return |
|||
if ?.o<0 then do |
|||
/*──────────────────────────────────.T subroutine───────────────────────*/ |
|||
onlyo= -?.o |
|||
?.o= 9999 |
|||
if ?.ts\==0 then call wn 'TS', 0, 99 |
|||
end |
|||
return |
return |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.U subroutine───────────────────────*/ |
|||
. |
.p: if ?.q then return /*Post (writting) blank lines. */ |
||
_= ?.p |
|||
if pos(?.u, " AFLUW")==0 then call er 55, ?.u '.U=' |
|||
if ?.u==' ' | ?.u=='A' then ?.u= |
|||
return |
|||
if _>98 |, |
|||
/*──────────────────────────────────.UT subroutine──────────────────────*/ |
|||
_<0 then do 1 |
|||
.ut: call wn 'T', 0, 99 /*Times the text is written. */ |
|||
if !cms & _>9998 then call CPmore |
|||
?.ut=valn(?.ut, "UT") |
|||
!cls |
|||
if \!cms then leave /*1*/ |
|||
if |
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 |
|||
return |
|||
end /*1*/ |
|||
do abs(_) while _<99 |
|||
/*──────────────────────────────────.V subroutine───────────────────────*/ |
|||
call wit bline |
|||
.v: upper ?.v /*video mode, Normal -or- Reverse*/ |
|||
end /*abs*/ |
|||
do _=1 to -?.a |
|||
call wit bline |
|||
end /*_*/ |
|||
return |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.W subroutine───────────────────────*/ |
|||
.ruler: call wn 'RULER', -sw(), sw() /*RULER draws a "ruler" line. */ |
|||
.w: if ?.q then return |
|||
?.rulerb= tb(?.rulerb, 'RULERB') |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
ww=translate(?.w,,"_") |
|||
.s: call wn "S", -999, 999, 999 /*Skip (or suppress) line(s). */ |
|||
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 |
|||
if ?.s<0 then do |
|||
/*──────────────────────────────────.X subroutine───────────────────────*/ |
|||
if left(?.o, 1)=='-' then /*check for conflicting options*/ |
|||
.x: call wn 'X', -sw(), sw() |
|||
call er 61,"O="?.o 'S='?.s "(both can't be negative)" |
|||
onlys = -?.s |
|||
?.s = 0 |
|||
end |
|||
return |
|||
if left(?.o, 1)=="-" & left(?.s, 1)=='-' then |
|||
/*──────────────────────────────────.XK subroutine──────────────────────*/ |
|||
call er 61,"O="?.o 'S='?.s "(both can't be negative)" |
|||
.xk: do ##=1 |
|||
return |
|||
if _=='' & @=="" then leave |
|||
tx.## = _ |
|||
if @\=='' then tx.## = tx.## || ?.k |
|||
tx.## = strip(tx.##) |
|||
LLk = max(LLk, length(tx.##)) |
|||
end /*##*/ |
|||
##=##-1 |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────.Z subroutine───────────────────────*/ |
|||
. |
.scale: call wn 'SCALE', -sw(), sw() /*SCALE draws a "scale" line. */ |
||
if _z=0 then return |
|||
if !cms then call cp 'SLEEP' _z "SEC" |
|||
if !dos then call delay _z |
|||
return |
|||
?.scaleb= tb(?.scaleb, 'SCALEB') |
|||
/*──────────────────────────────────BEEPS subroutine────────────────────*/ |
|||
?.scaled= tb(?.scaled, 'SCALED', .) |
|||
beeps: if \!dos & !pcrexx then return /*can this OS handle sounds? */ |
|||
?.scalep= tb(?.scalep, 'SCALEP', "+") |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
do jb=1 for abs(arg(1)) |
|||
.t: call wn 'T', 0, 99 /*Times the text is written. */ |
|||
if jb\==1 then call delay .1 |
|||
if ?.ts\==0 then call wn 'TS', 0, 99 |
|||
?.tsb= tb(?.tsb, 'TSB') |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
do jb_=1 for words(?.bf) |
|||
.u: upper ?.u /*handle uppercasing text parts. */ |
|||
call sound word(?.bf, jb_), word(word(?.bd,jb_) .2,1) |
|||
?.u= left(?.u, 1) |
|||
if pos(?.u, " AFLUW")==0 then call er 55, ?.u '.U=' |
|||
if ?.u==' ' | ?.u=='A' then ?.u= |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
end /*jb */ |
|||
.ut: call wn 'T', 0, 99 /*Times the text is written. */ |
|||
return |
|||
?.ut= valn(?.ut, "UT") |
|||
if length(?.ut) // 2 == 1 then |
|||
/*──────────────────────────────────BLOCKER subroutine──────────────────*/ |
|||
call er 30,?.ut 'translate-characters an-even-number-of' |
|||
return |
|||
chbit.jc = $block(substr(_, jc, 1)) |
|||
end /*jc*/ |
|||
bcl = ?.block |
|||
bcs = 1 |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if bcl<0 then do |
|||
.v: upper ?.v /*video mode, Normal -or- Reverse*/ |
|||
bcl=-bcl |
|||
?.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 _=' ' |
if _=='' then _=' ' |
||
tbc = ?.bc |
tbc = ?.bc |
||
if tbc=='' then tbc=_ |
if tbc=='' then tbc=_ |
||
tbc = left(copies(tbc,1+sw()%length(tbc)),sw()) |
tbc = left( copies(tbc, 1 + sw() % length(tbc) ), sw() ) |
||
do jl=bcs to 3*bcl by 3 |
do jl=bcs to 3*bcl by 3 |
||
_ = copies(?.bb, max(1, 12*LL+?.bs*LL-?.bs)) |
_ = copies(?.bb, max(1, 12 * LL + ?.bs * LL - ?.bs) ) |
||
bix = 1 |
bix = 1 |
||
do jo=1 for LL |
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) |
bix = max(1, bix + ?.bs + 12) |
||
end /*jo*/ |
end /*jo*/ |
||
call tellIt _ |
|||
end /*jl*/ |
|||
call tellIt _ |
|||
return |
|||
end /*jl*/ |
|||
return |
|||
/*──────────────────────────────────COLORS subroutine───────────────────*/ |
|||
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 |
|||
colors: arg hue,__,cc#,cc /*verify/handle synonymous colors*/ |
|||
ahue=word(hues,jj) |
|||
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" |
|||
end /*jj*/ |
|||
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 dark & left(cc,2)=='1;' then cc="0"substr(cc,2) |
|||
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 !cms then do |
|||
if dark & left(cc, 2)=='1;' then cc= "0"substr(cc, 2) |
|||
if hue="BROWN" then hue='YELLOW' |
|||
end |
|||
if !cms then do |
|||
color.cc# = hue |
|||
if hue='GRAY' | hue=="BLACK" then hue= 'WHITE' |
|||
colorC.cc# = esc || cc'm' |
|||
if hue="BROWN" then hue= 'YELLOW' |
|||
return |
|||
end |
|||
color.cc# = hue |
|||
/*──────────────────────────────────CPMORE subroutine───────────────────*/ |
|||
colorC.cc# = esc || cc'm' |
|||
cpMore: call cp 'QUERY TERM', 9 /*parse CP TERMINAL for MORE,HOLD*/ |
|||
return |
|||
do jj=1 for cp.0 |
|||
__=__ cp.jj |
|||
end /*jj*/ |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
parse upper var __ 'MORE' more ',' 1 'HOLD' hold ',' |
|||
cpMore: call cp 'QUERY TERM', 9 /*parse CP TERMINAL for MORE,HOLD*/ |
|||
__= |
|||
if _>99999998 & hold\=='' then call cp 'TERMINAL HOLD OFF' |
|||
do jj=1 for cp.0 |
|||
return |
|||
__= __ cp.jj |
|||
end /*jj*/ |
|||
parse upper var __ 'MORE' more ',' 1 'HOLD' hold ',' |
|||
/*──────────────────────────────────DSAY subroutine─────────────────────*/ |
|||
if _>9998 & more\=='' then call cp 'TERMINAL MORE 0 0' |
|||
if _>99999998 & hold\=='' then call cp 'TERMINAL HOLD OFF' |
|||
return |
|||
LLd = length(dsay_) /*length of last line displayed. */ |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────HIGHLIGHT subroutine────────────────*/ |
|||
dsay: if ?.q then return /*do SAY subroutine, write to scr*/ |
|||
highLight: do _=1 for 7 |
|||
dsay_= strip( translate( arg(1), , '0'x), 'T') |
|||
say dsay_ |
|||
LLd= length(dsay_) /*length of last line displayed. */ |
|||
hice._ = right(hh._,1) |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if hhl._ then do |
|||
highLight: do _=1 for 7 |
|||
minhic= min(_,minhic); shics= shics || hics._ |
|||
hhl._ = color._\=='' |
|||
hics._ = left(hh._, 1) |
|||
hice._ = right(hh._, 1) |
|||
if hhl._ then do |
|||
ahics=shics || ehics |
|||
minhic= min(_, minhic); shics= shics || hics._ |
|||
return |
|||
maxhic= max(_, maxhic); ehics= ehics || hice._ |
|||
end |
|||
end /*_*/ |
|||
ahics= shics || ehics |
|||
/*──────────────────────────────────HUE subroutine──────────────────────*/ |
|||
return |
|||
__=arg(2) |
|||
if __\=='' then hue.hue#=__ |
|||
_= |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────INCHES Subroutine───────────────────*/ |
|||
hue: hue#= max(1, hue# + arg(1) ) |
|||
inches: /*handle RULER and SCALE stuff.*/ |
|||
__= arg(2) |
|||
_ = kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED') |
|||
if __\=='' then hue.hue#= __ |
|||
_= |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if arg(2) then _=$scale(?.scale _ 'Q') |
|||
inches: _= kw('RULERB') kw('SCALEB') kw('SCALEP') kw('SCALED') |
|||
else _=$scale(?.ruler 'RULE' _ 'Q') |
|||
/*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 |
parse var _ _.1 '9'x _.2 '9'x _.3 |
||
do jk=1 for 3 |
do jk=1 for 3 |
||
_=_.jk |
_= _.jk |
||
if _\=='' then call wit _ |
if _\=='' then call wit _ |
||
end /*jk*/ |
end /*jk*/ |
||
return |
return |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────MS subroutine───────────────────────*/ |
|||
ms: #ms=#ms+1 /*justification and indentation. */ |
ms: #ms= #ms + 1 /*justification and indentation. */ |
||
parse arg _i |
parse arg _i |
||
select |
select |
||
when ?.j=='' then nop |
when ?.j=='' then nop |
||
when ?.N=='N' then nop |
when ?.N=='N' then nop |
||
when length(_i)>=sw()-1 then nop |
when length(_i)>=sw()-1 then nop |
||
when ?.j=='C' then _i |
when ?.j=='C' then _i= centre(_i, sw() - 1, ?.jb) |
||
when ?.j=='L' then _i |
when ?.j=='L' then _i= strip(_i) |
||
when ?.j=='R' then _i |
when ?.j=='R' then _i= right( strip(_i, "T"), sw() - 1) |
||
when ?.j=='J' then _i |
when ?.j=='J' then _i= justify(_i, sw() - 1, ?.jb) |
||
end /*select*/ |
end /*select*/ |
||
mm.#ms=strip(indent || _i,'T') |
mm.#ms= strip(indent || _i, 'T') |
||
return |
return |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────SAYALINE subroutine──────────────────*/ |
|||
sayAline: |
sayAline: |
||
do jj=?.s to #ms for ?.o |
|||
if skp() then iterate |
|||
if \?.q then do |
|||
if !cms then '$CLEAR .WL='?.L _mm |
|||
if skp() then iterate |
|||
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 |
|||
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 |
|||
/*──────────────────────────────────SAYBRITE subroutine─────────────────*/ |
|||
else if !dos then call dsay colorC.0 || _mm || scr0 |
|||
sayBrite: do jj=?.s to #ms for ?.o |
|||
end /*jj*/ |
|||
call wr _mm |
|||
if ?.q then iterate |
|||
return |
|||
if !cms then '$CLEAR .C=BRITE' _mm |
|||
else if !dos then call dsay colorC.0 || _mm || scr0 |
|||
end /*jj*/ |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────SAYNLINE subroutine─────────────────*/ |
|||
sayNline: do jj=?.s to #ms for ?.o |
sayNline: do jj=?.s to #ms for ?.o |
||
if skp() then iterate |
if skp() then iterate |
||
if !dos then do |
if !dos then do |
||
if ?.c=='' then call dsay _mm |
if ?.c=='' then call dsay _mm |
||
else call dsay colorC.0 || _mm || scr0 |
else call dsay colorC.0 || _mm || scr0 |
||
call wr _mm |
call wr _mm |
||
end |
end |
||
else call wit _mm |
else call wit _mm |
||
end /*jj*/ |
end /*jj*/ |
||
return |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────SAYHIGHLIGHT subroutine─────────────*/ |
|||
sayHighlight: |
sayHighlight: |
||
do jj=?.s to #ms for ?.o |
|||
if skp() then iterate |
|||
if !cms then do |
|||
do jj=?.s to #ms for ?.o |
|||
if \?.q then '$CLEAR .C=HIGHL' _mm |
|||
if skp() then iterate |
|||
iterate |
|||
end |
|||
lenmm= length(_mm) |
|||
if !cms then do |
|||
__= verify(_mm, ahics, 'M') |
|||
iterate |
|||
end |
|||
if __==0 then hc= lenmm + 1 |
|||
lenmm=length(_mm) |
|||
else hc= __ |
|||
__=verify(_mm,ahics,'M') |
|||
_xx= hue.1 |
|||
if hc>1 then _xx= _xx || left(_mm, hc - 1) |
|||
_xx=hue.1 |
|||
if hc>1 then _xx=_xx || left(_mm, hc-1) |
|||
do jl=hc to lenmm |
|||
_=substr(_mm,jl,1) |
|||
do |
do jl=hc to lenmm |
||
_= substr(_mm, jl, 1) |
|||
else if _==hice.jc then call hue -1 |
|||
end /*jc*/ |
|||
do jc=minhic to maxhic |
|||
if _=='' then _xx=_xx" " |
|||
if hhl.jc then if _==hics.jc then call hue 1, colorC.jc |
|||
__=verify(substr(_mm, jl+1), ahics, 'M') |
|||
else if _==hice.jc then call hue - 1 |
|||
end /*jc*/ |
|||
if |
if _=='' then _xx= _xx" " |
||
__= verify( substr(_mm, jl + 1), ahics, 'M') |
|||
if |
if __==0 then pl= lenmm - jl + 1 |
||
else pl= __ |
|||
_xx=_xx || hue.hue# || substr(_mm, jl+1, pl-1) |
|||
jl=jl+pl-1 |
|||
end /*jl*/ |
|||
if pl==1 then iterate |
|||
if length(_xx)>sw() then if lenmm<=sw() then _xx = esc's'_xx || esc"u" |
|||
_xx= _xx || hue.hue# || substr(_mm, jl + 1, pl - 1) |
|||
call dsay _xx || scr0 |
|||
jl= jl + pl - 1 |
|||
call wr _mm |
|||
end /* |
end /*jl*/ |
||
return |
|||
if length(_xx)>sw() then if lenmm<=sw() then _xx = esc's'_xx || esc"u" |
|||
/*──────────────────────────────────SKP subroutine──────────────────────*/ |
|||
call dsay _xx || scr0 |
|||
skp: if (onlyo\=='' & onlyo\==jj) |, |
|||
call wr _mm |
|||
end /*jj*/ |
|||
_mm = mm.jj |
|||
return 0 |
|||
return |
|||
/*──────────────────────────────────TB subroutine───────────────────────*/ |
|||
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 subroutine───────────────────*/ |
|||
skp: if (onlyo\=='' & onlyo\==jj) | (onlys\=="" & onlys ==jj) then return 1 |
|||
tellIt: ___=arg(1) /*tell it to the display terminal*/ |
|||
_mm= mm.jj |
|||
return 0 |
|||
if boxing then ___=bx.8 || ?.eb || ___ || ?.eb || bx.4 |
|||
call ms ___ |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────VALN subroutine─────────────────────*/ |
|||
tb: tb= arg(1) /*test|verify Blank specification*/ |
|||
valn: procedure; parse arg x,n,k /*validate number (dec,bin,hex). */ |
|||
if tb=='' then return left(arg(3), 1) |
|||
if length(tb)==2 then return valn("'"tb"'X", arg(2), 'X') |
|||
v = "."n'=' |
|||
if length(tb)>1 then call er 30, tb "."arg(2)'=' 1 |
|||
if (_\=='"' & _\=="'") | ((right(x,2)\==_||k) & k\=='') then return x |
|||
return tb |
|||
arg ' ' -1 t |
|||
x = substr(x,2,length(x)-3) |
|||
_ = length(x) |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if t=='X' then do |
|||
tellIt: ___= arg(1) /*tell it to the display terminal*/ |
|||
___= x1 || ___ || x2 |
|||
if boxing then ___= bx.8 || ?.eb || ___ || ?.eb || bx.4 |
|||
call ms ___ |
|||
return |
|||
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 |
|||
valn: procedure; parse arg x,n,k /*validate number (dec,bin,hex). */ |
|||
return d2c(x) |
|||
_= 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 |
|||
/*──────────────────────────────────VEREB subroutine────────────────────*/ |
|||
if \datatype(x, t) then call er 40, x v |
|||
VEReb: if arg(1)==0 then return /*character for Extra Blank(s). */ |
|||
return x2c(x) |
|||
eb_ = x1 || copies(?.eb,tLL)x2 |
|||
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 |
return _ |
||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
/*──────────────────────────────────VMCOLOR subroutine──────────────────*/ |
|||
wr: parse arg wr /*write [argument 1] ───> disk. */ |
|||
VMcolor: if \!cms then return |
|||
if ?.f=='' then return /*Nothing to write? Then skip it.*/ |
|||
parse arg c1,c2 |
|||
if highL & ahics\=='' then wr= translate(wr, , ahics) /*has highlighting?*/ |
|||
if c2\=='' then "SET VSCREEN CMS" c2 |
|||
return |
|||
if !cms | !tso then 'EXECIO 1 DISKW' ?.f "(FINIS STRING" wr |
|||
/*──────────────────────────────────WN subroutine───────────────────────*/ |
|||
else call lineout ?.f, translate(wr, '10'x, "1a"x) |
|||
wn: procedure expose ?. /*normalize, validate N in range.*/ |
|||
/*(above) Handle E-O-F character.*/ |
|||
arg z, L, H, d, t |
|||
_ = ?.z |
|||
parse upper var _ f 2 |
|||
m = pos(f,'MH')\==0 |
|||
call lineout ?.f /*close the output file. */ |
|||
if m | , |
|||
return 0 |
|||
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 |
|||
!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 |
|||
if \datatype(_,left(t"W",1)) then call er 53, _ '.'z"=" |
|||
!cal: if symbol('!CALL')\=="VAR" then !call=; return !call |
|||
if L\=='' then if _<L|_>H then call er 81,L H _ "value for option ."z'=' |
|||
!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 |
|||
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> |
|||
/*──────────────────────────────────WR subroutine───────────────────────*/ |
|||
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 file. */ |
|||
return |
|||
Programming note: this REXX program makes use of '''DELAY''' BIF which delays (sleeps) for a specified amount of seconds. |
|||
/*═════════════════════════════general 1-line subs══════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/ |
|||
<br>Some REXXes don't have a '''DELAY''' BIF, so one is included here ──► [[DELAY.REX]]. |
|||
!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=1=='f0'x;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';call !rex;return |
|||
!var:call !fid;if !kexx then return space(dosenv(arg(1)));return space(value(arg(1),,!env)) |
|||
.a: call wn 'A',-99,99,sd(); ?.ab=tb(?.ab,'AB'); return |
|||
$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> |
Latest revision as of 03:05, 19 January 2021
$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
- 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
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/\'
- 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.