SCRSIZE.REX

From Rosetta Code

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>