SCRSIZE.REX: Difference between revisions
Thundergnat (talk | contribs) (Move to REXX library routines category) |
No edit summary |
||
| Line 1: | Line 1: | ||
The '''SCRSIZE.REX''' is a REXX program to emulate the '''scrsize''' |
The '''SCRSIZE.REX''' is a REXX program to emulate the '''scrsize''' BIF (which is available under some REXXes). |
||
<br><br>The help for the '''SCRSIZE''' REXX program is included here ──► [[SCRSIZE.HEL]]. |
<br><br>The help for the '''SCRSIZE''' REXX program is included here ──► [[SCRSIZE.HEL]]. |
||
<lang rexx>/*REXX pgm finds the SCRSIZE (screen size) of the console (terminal), returns 2 values.*/ */ |
|||
<lang rexx>/**/trace o;parse arg !;if !all(arg()) then exit;if !cms then address '';signal on halt;signal on novalue;signal on syntax |
|||
trace off |
|||
/*┌────────────────────────────────────────────────────────────────────┐ |
|||
┌─┘ └─┐ |
|||
│ The SCRSIZE function is used to return the screen size (depth and │ |
|||
│ width) for those REXX interpereters that don't support the SCRSIZE │ |
|||
│ built-in function (BIF). │ |
|||
│ │ |
|||
│ │ |
|||
│ [PC/REXX, R4, and ROO support the SCRSIZE bif.] │ |
|||
│ │ |
|||
│ Method: to save time, this program first attempts to find the DOS │ |
|||
│ environmental variable LINES and COLUMNS. │ |
|||
│ │ |
|||
│ Failing that (in whole or in part), it then parses the results from │ |
|||
│ the MODE CON (DOS) command and scans for the LINES and COLUMNS │ |
|||
│ parameters. │ |
|||
└─┐ ┌─┘ |
|||
└────────────────────────────────────────────────────────────────────┘*/ |
|||
parse arg ! |
|||
if !cms then do /*if CMS, use $QWHAT pgm. */ |
|||
if !all(arg()) then exit |
|||
'$QWHAT SCRDEPTH , 24';sd=rc /*get sd, default to 24. */ |
|||
if !cms then address '' |
|||
'$QWHAT SCRWIDTH , 80';sw=rc /*get sw, default to 80. */ |
|||
return sd sw /*return depth and width. */ |
|||
end |
|||
if \!dos then return 24 80 /*not DOS? Return default.*/ |
|||
signal on halt |
|||
@abc='abcdefghijklmnopqrstuvwxyz' |
|||
signal on noValue |
|||
@erase ='ERASE' /*point to dos ERASE cmd*/ |
|||
signal on syntax |
|||
@find ='FIND' /*point to the dos FIND cmd*/ |
|||
@MODE ='MODE' /*point to the dos MODE cmd*/ |
|||
tfid= /*name of a temporary FID. */ |
|||
/*Note: /i = ignore case.*/ |
|||
@find_s ='/i "s"' /*find line with an "s". */ |
|||
@find_l ='/i "l"' /*find line with an "l". */ |
|||
/*┌────────────────────────────────────────────────────────────────────┐ |
|||
findCols=1 |
|||
┌─┘ └─┐ |
|||
findRows=1 |
|||
│ The SCRSIZE function is used to return the screen size (depth and │ |
|||
sd=0 |
|||
│ width) for those REXX interpreters that don't support the SCRSIZE │ |
|||
sw=0 |
|||
│ built-in function (BIF). │ |
|||
│ │ |
|||
│ │ |
|||
│ [PC/REXX, PERSONAL REXX, R4, and ROO support the SCRSIZE BIF.] │ |
|||
│ │ |
|||
│ Method: to save time, this program first attempts to find the DOS │ |
|||
│ environmental variable LINES and COLUMNS. │ |
|||
│ │ |
|||
│ Failing that (in whole or in part), it then parses the results from │ |
|||
│ the MODE CON (DOS) command and scans for the LINES and COLUMNS │ |
|||
│ parameters. │ |
|||
└─┐ ┌─┘ |
|||
└────────────────────────────────────────────────────────────────────┘*/ |
|||
parse var !! _ . '(' ops ')' __ |
|||
if _\=='' | __\=='' then call er 59 |
|||
ops=space(ops) |
|||
if !cms then do /*if CMS, use $QWHAT program.*/ |
|||
do while ops\==''; parse var ops _1 2 1 _ . 1 _o ops; upper _ |
|||
'$QWHAT SCRDEPTH , 24'; sd= rc /*get the sd, default to 24.*/ |
|||
select |
|||
'$QWHAT SCRWIDTH , 80'; sw= rc /*get the sw, default to 80.*/ |
|||
when _==',' then nop |
|||
return sd sw /*return depth and width. */ |
|||
when _1=='.' & pos("=",_)\==0 then tops=tops _o |
|||
end |
|||
when abbn('SCRWIDths' )|, |
|||
abbn('WIDths' )|, |
|||
abbn('WIDes' )|, |
|||
abbn('WIDs' )|, |
|||
abbn('COLums' )|, |
|||
abbn('COLs' ) then findcols=no() |
|||
when abbn('SCRWIDTHs' )|, |
|||
abbn('DEPTHs' )|, |
|||
abbn('DEPs' )|, |
|||
abbn('ROWs' )|, |
|||
abbn('LINEs' )|, |
|||
abbn('LINESizes' ) then findrows=no() |
|||
otherwise call er 55,_o |
|||
end |
|||
end |
|||
if \!dos then return 24 80 /*not DOS? Return default. */ |
|||
tfid= /*name of a temporary FID. */ |
|||
/*──────────────attempt to use the DOS environmental variable: COLUMNS. */ |
|||
@abc= 'abcdefghijklmnopqrstuvwxyz' /*lowercase for options. */ |
|||
if findcols then do |
|||
sw=p(!var('COLUMNS')) /*pick off the first word. */ |
|||
if \isint(sw) then sw=0 /*if not whole #, then 0. */ |
|||
sw=sw/1 /*decimal point ? remove.*/ |
|||
end |
|||
@erase = 'ERASE' /*point to DOS ERASE command*/ |
|||
@find = 'FIND' /* " " " FIND " */ |
|||
@mode = 'MODE' /* " " " MODE " */ |
|||
@pipe = '|' /*variable for pipe symbol. */ |
|||
/*──────────────attempt to use the DOS environmental variable: LINES. */ |
|||
@find_s = '/i "s:"' /*find record with s: */ |
|||
if findrows then do |
|||
/*the /i ignores the case. */ |
|||
if \isint(sd) then sd=0 /*if not whole #, then 0. */ |
|||
sd=sd/1 /*decimal point ? remove.*/ |
|||
end |
|||
findCols= 1 |
|||
findRows= 1 |
|||
sd= 0 |
|||
sw= 0 |
|||
parse var !! _ . '(' ops ')' __ |
|||
/*──────────────if not defined, then use (DOS) MODE (writes to a file). */ |
|||
if |
if _\=='' | __\=='' then call er 59 |
||
ops= space(ops) |
|||
do /*first, find temp. disk. */ |
|||
call gettfid ,'$$$' /*get a TEMP id: !fn $$$ */ |
|||
@mode 'con', /*issue MODE CON, then: */ |
|||
'|' @find @find_s, /*find lines with an "s", */ |
|||
'|' @find @find_l '>' tfid /*find lines with an "l". */ |
|||
do while ops\=='' |
|||
call linein tfid,1,0 /*point to record 1. */ |
|||
parse var ops _1 2 1 _ . 1 _o ops |
|||
upper _ |
|||
select |
|||
when _==',' then nop |
|||
when _1==. & pos("=",_)\==0 then tops= tops _o |
|||
when abbn('SCRWIDths' ) | , |
|||
abbn('WIDths' ) | , |
|||
abbn('WIDes' ) | , |
|||
abbn('WIDs' ) | , |
|||
abbn('COLums' ) | , |
|||
abbn('COLs' ) then findcols= no() |
|||
when abbn('SCRWIDTHs' ) | , |
|||
abbn('DEPTHs' ) | , |
|||
abbn('DEPs' ) | , |
|||
abbn('ROWs' ) | , |
|||
abbn('LINEs' ) | , |
|||
abbn('LINESizes' ) then findrows= no() |
|||
otherwise call er 55,_o |
|||
end /*select*/ |
|||
end /*while*/ |
|||
if !regina then call addr_with |
|||
do while sd==0 | sw==0 /*read file while sw|sw =0.*/ |
|||
else call hard_way |
|||
if lines(tfid)==0 then leave /*No lines left? We're done*/ |
|||
_=translate(linein(tfid),,'=:') /*translate = : --> blanks.*/ |
|||
parse upper var _ yname yval . /*parse with name value. */ |
|||
if yname=='COLUMNS' & sw==0 then sw=yval /*if COLUMNS, it's width.*/ |
|||
if yname=='LINES' & sd==0 then sd=yval /*if LINES, it's depth.*/ |
|||
end /*do while*/ |
|||
return sd sw /*return depth and width. */ |
|||
end |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
if sd==0 then sd=50 /*just in case MODE failed.*/ |
|||
hard_way: /*The (DOS) MODE command */ |
|||
/* |
/* (writes to a temp file). */ |
||
call gettfid, '$$$' /*get a TEMP id: !fn $$$ */ |
|||
@mode 'con: |' @find @find_s '>' tfid /*find lines with s: */ |
|||
call linein tfid, 1, 0 /*point to record 1. */ |
|||
do while sd==0 | sw==0 /*read file while sw|sw =0. */ |
|||
if lines(tfid)==0 then leave /*No lines left? We're done. */ |
|||
_= translate( linein(tfid), , '=:') /*translate = : ──> blanks. */ |
|||
parse upper var _ yname yval . /*parse with name value. */ |
|||
if yname=='COLUMNS' & sw==0 then sw=yval /*if COLUMNS, it's width. */ |
|||
if yname=='LINES' & sd==0 then sd=yval /* " LINES, " depth. */ |
|||
end /*while*/ |
|||
call lineout tfid /*close the (now) input file.*/ |
|||
/*═════════════════════════════general 1-line subs════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/ |
|||
@erase tfid /*erase the temporary file. */ |
|||
!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 |
|||
if sd==0 then sd= 50 /*just in case MODE failed.*/ |
|||
!env:!env='ENVIRONMENT';if !sys=='MSDOS'|!brexx|!r4|!roo then !env='SYSTEM';if !os2 then !env='OS2'!env;!ebcdic=1=='f0'x;return |
|||
if sw==0 then sw= 80 /* " " " " " */ |
|||
!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 |
|||
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)) |
|||
$fact!:procedure;parse arg x _ .;l=length(x);n=l-length(strip(x,'T',"!"));if n<=-n|_\==''|arg()\==1 then return x;z=left(x,l-n);if z<0|\isint(z) then return x;return $fact(z,n) |
|||
/*──────────────────────────────────────────────────────────────────────────────────────*/ |
|||
$fact:procedure;parse arg x _ .;arg ,n ! .;n=p(n 1);if \isint(n) then n=0;if x<-n|\isint(x)|n<1|_||!\==''|arg()>2 then return x||copies("!",max(1,n));!=1;s=x//n;if s==0 then s=n;do j=s to x by n;!=!*j;end;return ! |
|||
addr_with: @.= /*prepare stem, just in case.*/ |
|||
$sfxa:parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isnum(_) then return m*_;leave;end;return arg(1) |
|||
signal . /*do an old fashioned GO TO */ |
|||
$sfxf:parse arg y;if right(y,1)=='!' then y=$fact!(y);if \isnum(y) then y=$sfxz();if isnum(y) then return y;return $sfxm(y) |
|||
.: where= sigL + 3 /*point to ADDRESS statement.*/ |
|||
$sfxm:parse arg z;arg w;b=1000;if right(w,1)=='I' then do;z=shorten(z);w=z;upper w;b=1024;end;p=pos(right(w,1),'KMGTPEZYXWVU');if p==0 then return arg(1);n=shorten(z);r=num(n,f,1);if isnum(r) then return r*b**p;return arg(1) |
|||
/*this blank line must exist.*/ |
|||
$sfxz:return $sfxa($sfxa($sfxa($sfxa($sfxa($sfxa(y,'PAIRs',2),'DOZens',12),'SCore',20),'GREATGRoss',1728),'GRoss',144),'GOOGOLs',1e100) |
|||
address system @mode 'CON:' @pipe @find @find_s with output stem @. |
|||
abb:arg abbu;parse arg abb;return abbrev(abbu,_,abbl(abb)) |
|||
abbl:return verify(arg(1)'a',@abc,'M')-1 |
|||
/*the above cmd only works with Regina.*/ |
|||
abbn:parse arg abbn;return abb(abbn)|abb('NO'abbn) |
|||
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 |
|||
if rc\==0 then do /*did a DOS error happen? */ |
|||
err:call er '-'arg(1),arg(2);return '' |
|||
parse source . . xfid /*obtain the program's name. */ |
|||
erx:call er '-'arg(1),arg(2);exit '' |
|||
say |
|||
getdtfid:tfid=p(!var("TMP") !var('TEMP') homedrive()"\");if substr(tfid,2,1)==':'&substr(tfid,3,1)\=="\" then tfid=insert('\',t,2);return strip(tfid,'T',"\")'\'arg(1)'.'arg(2) |
|||
say '***error*** from: ' xfid /*tell where/what this is. */ |
|||
gettfid:if tfid\=='' then return tfid;gfn=word(arg(1) !fn,1);gft=word(arg(2) 'ANS',1);tfid='TEMP';if !tso then tfid=gfn'.'gft;if !cms then tfid=gfn','gft",A4";if !dos then tfid=getdtfid(gfn,gft);return tfid |
|||
say 'return code ' rc " from the REXX statement number " where |
|||
halt:call er .1 |
|||
say 'REXX statement:' |
|||
homedrive:if symbol('HOMEDRIVE')\=="VAR" then homedrive=p(!var('HOMEDRIVE') 'C:');return homedrive |
|||
say copies('-', 77) |
|||
int:int=num(arg(1),arg(2));if \isint(int) then call er 92,arg(1) arg(2);return int/1 |
|||
say strip ( sourceLine(where) ) /*show the source line of pgm*/ |
|||
isint:return datatype(arg(1),'W') |
|||
say copies('-', 77) |
|||
isnum:return datatype(arg(1),'N') |
|||
say |
|||
na:if arg(1)\=='' then call er 01,arg(2);parse var ops na ops;if na=='' then call er 35,_o;return na |
|||
exit rc /*exit with the return code. */ |
|||
nai:return int(na(),_o) |
|||
end |
|||
nan:return num(na(),_o) |
|||
no:if arg(1)\=='' then call er 01,arg(2);return left(_,2)\=='NO' |
|||
if @.0=='' then @.0= 0 /*just in case MODE failed. */ |
|||
novalue:!sigl=sigl;call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) |
|||
num:procedure;parse arg x .,f,q;if x=='' then return x;if isnum(x) then return x/1;x=space(translate(x,,','),0);if \isnum(x) then x=$sfxf(x);if isnum(x) then return x/1;if q==1 then return x;if q=='' then call er 53,x f;call erx 53,x f |
|||
do j=1 for @.0 /*traipse through the output.*/ |
|||
p:return word(arg(1),1) |
|||
_= translate( @.j, , '=:') /*translate = : ──> blanks.*/ |
|||
s:if arg(1)==1 then return arg(3);return word(arg(2) 's',1) |
|||
parse upper var _ yname yval . /*parse with name value. */ |
|||
shorten:procedure;parse arg a,n;return left(a,max(0,length(a)-p(n 1))) |
|||
if yname=='COLUMNS' then sw= yval /*if COLUMNS, it's width. */ |
|||
syntax:!sigl=sigl;call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)</lang> |
|||
if yname=='LINES' then sd= yval /*if LINES, it's depth. */ |
|||
end /*j*/ |
|||
if sd==0 | \datatype(sd, 'W') then sd= 50 /*just in case MODE failed.*/ |
|||
if sw==0 | \datatype(sw, 'W') then sw= 80 /* " " " " " */ |
|||
return |
|||
/*──────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────*/ |
|||
!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) ) |
|||
$fact!: procedure; parse arg x _ .; l= length(x); n= l - length( strip(x, 'T', "!") ); if n<=-n|_\==''|arg()\==1 then return x; z=left(x,l-n); if z<0|\isInt(z) then return x; return $fact(z, n) |
|||
$fact: procedure; parse arg x _ .; arg ,n ! .; n= p(n 1); if \isInt(n) then n=0; if x<-n | \isInt(x) | n<1 | _ || !\=='' | arg()>2 then return x || copies("!", max(1,n)); !=1; s=x//n; if s==0 then s= n; do j=s to x by n; !=!*j; end; return ! |
|||
$sfxa: parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isNum(_) then return m*_; leave; end; return arg(1) |
|||
$sfxf: parse arg y;if right(y,1)=='!' then y=$fact!(y); if \isNum(y) then y= $sfxz(); if isNum(y) then return y; return $sfxm(y) |
|||
$sfxm: parse arg z; arg w; b=1000; if right(w, 1)=='I' then do; z= shorten(z); w=z; upper w; b=1024; end; p= pos( right(w, 1), 'KMGTPEZYXWVU'); if p==0 then return arg(1); n=shorten(z); r=num(n,f,1); if isNum(r) then return r*b**p; return arg(1) |
|||
$sfxz: return $sfxa( $sfxa( $sfxa( $sfxa( $sfxa( $sfxa(y,'PAIRs',2), 'DOZens', 12), 'SCore', 20), 'GREATGRoss', 1728), 'GRoss', 144), 'GOOGOLs', 1e100) |
|||
abb: arg abbu; parse arg abb; return abbrev( abbu, _, abbl(abb) ) |
|||
abbl: return verify( arg(1)'a', @abc, 'M') - 1 |
|||
abbn: parse arg abbn; return abb(abbn) | abb('NO'abbn) |
|||
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 |
|||
err: call er '-'arg(1), arg(2); return '' |
|||
erx: call er '-'arg(1), arg(2); exit '' |
|||
getdtfid: tfid= p(!var("TMP") !var('TEMP') homedrive()"\"); if substr(tfid, 2, 1)==':' & substr(tfid, 3, 1)\=="\" then tfid= insert('\', t, 2); return strip(tfid, 'T', "\")'\'arg(1)'.'arg(2) |
|||
getTFID: if symbol('TFID')=='LIT' then tfid=; if tfid\=='' then return tfid; gfn=word(arg(1) !fn,1); gft=word(arg(2) 'ANS',1); tfid='TEMP';if !tso then tfid=gfn'.'gft;if !cms then tfid=gfn','gft",A4";if !dos then tfid=getdTFID(gfn,gft); return tfid |
|||
halt: call er .1 |
|||
homedrive: if symbol('HOMEDRIVE')\=="VAR" then homedrive= p(!var('HOMEDRIVE') 'C:'); return homedrive |
|||
int: int= num(arg(1), arg(2)); if \isInt(int) then call er 92, arg(1) arg(2); return int/1 |
|||
isInt: return datatype( arg(1), 'W') |
|||
isNum: return datatype( arg(1), 'N') |
|||
na: if arg(1)\=='' then call er 01, arg(2); parse var ops na ops; if na=='' then call er 35,_o; return na |
|||
nai: return int(na(), _o) |
|||
nan: return num(na(), _o) |
|||
no: if arg(1)\=='' then call er 01,arg(2); return left(_,2)\=='NO' |
|||
noValue: !sigl= sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) |
|||
num: procedure; parse arg x .,f,q; if x=='' then return x; if isNum(x) then return x/1; x=space(translate(x,,','),0); if \isNum(x) then x=$sfxf(x); if isNum(x) then return x/1; if q==1 then return x; if q=='' then call er 53,x f;call erx 53,x f |
|||
p: return word( arg(1), 1) |
|||
s: if arg(1)==1 then return arg(3); return word( arg(2) 's', 1) |
|||
shorten: procedure; parse arg a,n; return left(a, max(0, length(a) - p(n 1) ) ) |
|||
syntax: !sigl= sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl) |
|||
</lang> |
|||
[[Category:REXX library routines]] |
[[Category:REXX library routines]] |
||
Revision as of 00:10, 30 January 2020
The SCRSIZE.REX is a REXX program to emulate the scrsize BIF (which is available under some REXXes).
The help for the SCRSIZE REXX program is included here ──► SCRSIZE.HEL.
<lang rexx>/*REXX pgm finds the SCRSIZE (screen size) of the console (terminal), returns 2 values.*/ */
trace off
parse arg ! if !all(arg()) then exit if !cms then address
signal on halt signal on noValue signal on syntax
/*┌────────────────────────────────────────────────────────────────────┐
┌─┘ └─┐
│ The SCRSIZE function is used to return the screen size (depth and │
│ width) for those REXX interpreters that don't support the SCRSIZE │
│ built-in function (BIF). │
│ │
│ │
│ [PC/REXX, PERSONAL REXX, R4, and ROO support the SCRSIZE BIF.] │
│ │
│ Method: to save time, this program first attempts to find the DOS │
│ environmental variable LINES and COLUMNS. │
│ │
│ Failing that (in whole or in part), it then parses the results from │
│ the MODE CON (DOS) command and scans for the LINES and COLUMNS │
│ parameters. │
└─┐ ┌─┘
└────────────────────────────────────────────────────────────────────┘*/
if !cms then do /*if CMS, use $QWHAT program.*/
'$QWHAT SCRDEPTH , 24'; sd= rc /*get the sd, default to 24.*/
'$QWHAT SCRWIDTH , 80'; sw= rc /*get the sw, default to 80.*/
return sd sw /*return depth and width. */
end
if \!dos then return 24 80 /*not DOS? Return default. */
tfid= /*name of a temporary FID. */ @abc= 'abcdefghijklmnopqrstuvwxyz' /*lowercase for options. */
@erase = 'ERASE' /*point to DOS ERASE command*/ @find = 'FIND' /* " " " FIND " */ @mode = 'MODE' /* " " " MODE " */
@pipe = '|' /*variable for pipe symbol. */ @find_s = '/i "s:"' /*find record with s: */
/*the /i ignores the case. */
findCols= 1 findRows= 1 sd= 0 sw= 0
parse var !! _ . '(' ops ')' __ if _\== | __\== then call er 59 ops= space(ops)
do while ops\==
parse var ops _1 2 1 _ . 1 _o ops
upper _
select
when _==',' then nop
when _1==. & pos("=",_)\==0 then tops= tops _o
when abbn('SCRWIDths' ) | ,
abbn('WIDths' ) | ,
abbn('WIDes' ) | ,
abbn('WIDs' ) | ,
abbn('COLums' ) | ,
abbn('COLs' ) then findcols= no()
when abbn('SCRWIDTHs' ) | ,
abbn('DEPTHs' ) | ,
abbn('DEPs' ) | ,
abbn('ROWs' ) | ,
abbn('LINEs' ) | ,
abbn('LINESizes' ) then findrows= no()
otherwise call er 55,_o
end /*select*/
end /*while*/
if !regina then call addr_with
else call hard_way
return sd sw /*return depth and width. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
hard_way: /*The (DOS) MODE command */
/* (writes to a temp file). */
call gettfid, '$$$' /*get a TEMP id: !fn $$$ */
@mode 'con: |' @find @find_s '>' tfid /*find lines with s: */
call linein tfid, 1, 0 /*point to record 1. */
do while sd==0 | sw==0 /*read file while sw|sw =0. */
if lines(tfid)==0 then leave /*No lines left? We're done. */
_= translate( linein(tfid), , '=:') /*translate = : ──> blanks. */
parse upper var _ yname yval . /*parse with name value. */
if yname=='COLUMNS' & sw==0 then sw=yval /*if COLUMNS, it's width. */
if yname=='LINES' & sd==0 then sd=yval /* " LINES, " depth. */
end /*while*/
call lineout tfid /*close the (now) input file.*/
@erase tfid /*erase the temporary file. */
if sd==0 then sd= 50 /*just in case MODE failed.*/
if sw==0 then sw= 80 /* " " " " " */
return
/*──────────────────────────────────────────────────────────────────────────────────────*/
addr_with: @.= /*prepare stem, just in case.*/
signal . /*do an old fashioned GO TO */
.: where= sigL + 3 /*point to ADDRESS statement.*/
/*this blank line must exist.*/
address system @mode 'CON:' @pipe @find @find_s with output stem @.
/*the above cmd only works with Regina.*/
if rc\==0 then do /*did a DOS error happen? */
parse source . . xfid /*obtain the program's name. */
say
say '***error*** from: ' xfid /*tell where/what this is. */
say 'return code ' rc " from the REXX statement number " where
say 'REXX statement:'
say copies('-', 77)
say strip ( sourceLine(where) ) /*show the source line of pgm*/
say copies('-', 77)
say
exit rc /*exit with the return code. */
end
if @.0== then @.0= 0 /*just in case MODE failed. */
do j=1 for @.0 /*traipse through the output.*/
_= translate( @.j, , '=:') /*translate = : ──> blanks.*/
parse upper var _ yname yval . /*parse with name value. */
if yname=='COLUMNS' then sw= yval /*if COLUMNS, it's width. */
if yname=='LINES' then sd= yval /*if LINES, it's depth. */
end /*j*/
if sd==0 | \datatype(sd, 'W') then sd= 50 /*just in case MODE failed.*/
if sw==0 | \datatype(sw, 'W') then sw= 80 /* " " " " " */
return
/*──────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────*/
!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) )
$fact!: procedure; parse arg x _ .; l= length(x); n= l - length( strip(x, 'T', "!") ); if n<=-n|_\==|arg()\==1 then return x; z=left(x,l-n); if z<0|\isInt(z) then return x; return $fact(z, n)
$fact: procedure; parse arg x _ .; arg ,n ! .; n= p(n 1); if \isInt(n) then n=0; if x<-n | \isInt(x) | n<1 | _ || !\== | arg()>2 then return x || copies("!", max(1,n)); !=1; s=x//n; if s==0 then s= n; do j=s to x by n; !=!*j; end; return !
$sfxa: parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isNum(_) then return m*_; leave; end; return arg(1)
$sfxf: parse arg y;if right(y,1)=='!' then y=$fact!(y); if \isNum(y) then y= $sfxz(); if isNum(y) then return y; return $sfxm(y)
$sfxm: parse arg z; arg w; b=1000; if right(w, 1)=='I' then do; z= shorten(z); w=z; upper w; b=1024; end; p= pos( right(w, 1), 'KMGTPEZYXWVU'); if p==0 then return arg(1); n=shorten(z); r=num(n,f,1); if isNum(r) then return r*b**p; return arg(1)
$sfxz: return $sfxa( $sfxa( $sfxa( $sfxa( $sfxa( $sfxa(y,'PAIRs',2), 'DOZens', 12), 'SCore', 20), 'GREATGRoss', 1728), 'GRoss', 144), 'GOOGOLs', 1e100)
abb: arg abbu; parse arg abb; return abbrev( abbu, _, abbl(abb) )
abbl: return verify( arg(1)'a', @abc, 'M') - 1
abbn: parse arg abbn; return abb(abbn) | abb('NO'abbn)
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
err: call er '-'arg(1), arg(2); return
erx: call er '-'arg(1), arg(2); exit
getdtfid: tfid= p(!var("TMP") !var('TEMP') homedrive()"\"); if substr(tfid, 2, 1)==':' & substr(tfid, 3, 1)\=="\" then tfid= insert('\', t, 2); return strip(tfid, 'T', "\")'\'arg(1)'.'arg(2)
getTFID: if symbol('TFID')=='LIT' then tfid=; if tfid\== then return tfid; gfn=word(arg(1) !fn,1); gft=word(arg(2) 'ANS',1); tfid='TEMP';if !tso then tfid=gfn'.'gft;if !cms then tfid=gfn','gft",A4";if !dos then tfid=getdTFID(gfn,gft); return tfid
halt: call er .1
homedrive: if symbol('HOMEDRIVE')\=="VAR" then homedrive= p(!var('HOMEDRIVE') 'C:'); return homedrive
int: int= num(arg(1), arg(2)); if \isInt(int) then call er 92, arg(1) arg(2); return int/1
isInt: return datatype( arg(1), 'W')
isNum: return datatype( arg(1), 'N')
na: if arg(1)\== then call er 01, arg(2); parse var ops na ops; if na== then call er 35,_o; return na
nai: return int(na(), _o)
nan: return num(na(), _o)
no: if arg(1)\== then call er 01,arg(2); return left(_,2)\=='NO'
noValue: !sigl= sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl)
num: procedure; parse arg x .,f,q; if x== then return x; if isNum(x) then return x/1; x=space(translate(x,,','),0); if \isNum(x) then x=$sfxf(x); if isNum(x) then return x/1; if q==1 then return x; if q== then call er 53,x f;call erx 53,x f
p: return word( arg(1), 1)
s: if arg(1)==1 then return arg(3); return word( arg(2) 's', 1)
shorten: procedure; parse arg a,n; return left(a, max(0, length(a) - p(n 1) ) )
syntax: !sigl= sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)
</lang>