Return to %uxxxx.m CVS log

Up to [Coherent Logic Development] / freem / contrib

FreeM

    1: %uxxxx ; FreeM %u utility library - version 0.5.0.1
    2:  ; Jon Diamond - 1999-03-31
    3:  q
    4:  ; 
    5:  ; INITIALISATION
    6: init() n a
    7:  i $d(^%uparams) s a="^%uparams"
    8:  e  s a="^uparams"
    9:  s %ulang=$g(@a@("lang")) i %ulang="" s %ulang=0
   10:  s %uprompt=$g(@a@("prompt")) i %uprompt="" s %uprompt="^ulang"
   11:  s %uwork=$g(@a@("work")) i %uwork="" s %uwork="^uwork("""_$j_""")"
   12:  ; Really should be as below, but needs $system to be implemented
   13:  ;s %uwork=$g(@a@("work"),"^uwork("""_$system_""","""_$j_""")")
   14:  q "0,init^%uxxxx"
   15:  ; 
   16:  ; 
   17:  ; READ WITH PROMPT
   18: read(prompt,result,length,PX,PY,X,Y,timeout) 
   19:  n a,error
   20:  i '$d(%ulang) s error=$$init
   21:  s prompt=$g(prompt)
   22: %read1 i prompt'="" s error=$$write($$lprompt(prompt),$g(PX),$g(PY)) i error q error
   23:  i $g(result)'="" s error=$$write(" <"_result_"> ") i error q error
   24:  ; 
   25:  ; move to X,Y ********
   26:  i $g(X)'="" s $x=$g(X)
   27:  i $g(Y)'="" s $y=$g(Y)
   28:  i $g(timeout)="" d
   29:  . r a
   30:  e  d
   31:  . r a:$g(timeout)
   32:  ; 
   33:  ; **** hitting escape or escape sequence processing???
   34:  i a'="" s result=a
   35:  i a="@" s result=""
   36:  i a="^" q "-1,read^%uxxxx" ; *** Standard abort
   37:  i $g(length),$l(result)>length s error=$$error("Too many characters") g %read1
   38:  ; 
   39:  q "0,read^%uxxxx"
   40:  ; 
   41:  ; 
   42:  ; READ WITH NEWLINE FIRST
   43: readn(prompt,result,length,PX,PY,X,Y,timeout) 
   44:  n error
   45:  i '$d(%ulang) s error=$$init i error q error
   46:  s error=$$writep($g(prompt)) i error q error
   47:  q $$read("",.result,$g(length),"","",$g(X),$g(Y),$g(timeout))
   48:  ; 
   49:  ; 
   50:  ; READN FOR YES/NO
   51: readyn(prompt,result) 
   52:  n error,res,def
   53:  s def=$g(result),def=$$lprompt($s(def=1:"Y",def=0:"N",1:""))
   54:  i '$d(%ulang) s error=$$init i error q error
   55: %readyn1 s res=def
   56:  s error=$$readn(prompt,.res) i error<0 q error
   57:  s res=$$upper(res)
   58:  i res=$$lprompt("Y") s result=1
   59:  e  i res=$$lprompt("N") s result=0
   60:  e  s error=$$write(" - "_$$lprompt("Enter Y or N")) g %readyn1
   61:  q "0,readyn^%uxxxx"
   62:  ; 
   63:  ; Application Validation Error display after Read (of any kind)
   64: rerror(err)  i err?1"?".e q $$write(" "_err)
   65:  q $$write(" - "_$$lprompt(err))
   66:  ; 
   67:  ; WRITE TEXT
   68: write(text,X,Y) 
   69:  n error
   70:  i '$d(%ulang) s error=$$init i error q error
   71:  ; 
   72:  ; move to X,Y ********
   73:  i $g(X)'="" s $x=$g(X)
   74:  i $g(Y)'="" s $y=$g(Y)
   75:  w text
   76:  q "0,write^%uxxxx"
   77:  ; 
   78:  ; 
   79:  ; WRITE WITH NEWLINE
   80: writen(text) 
   81:  w !,text
   82:  q "0,writen^%uxxxx"
   83:  ; 
   84:  ; 
   85:  ; WRITE WITH NEWLINE/PROMPT
   86: writep(text) 
   87:  n error
   88:  i '$d(%ulang) s error=$$init() i error q error
   89:  w !,$$lprompt(text)
   90:  q "0,writep^%uxxxx"
   91:  ; 
   92:  ; 
   93:  ; WRITE WITH FORMAT
   94: writef(format,text) 
   95:  n error,a
   96:  i '$d(%ulang) s error=$$init i error q error
   97:  s format=$g(format)
   98:  f  q:format=""  s a=$p(format,","),format=$p(format,",",2,$l(format,",")) i a?."#"."!"!(a?1"?"1.n) x "w "_a
   99:  w $g(text)
  100:  q "0,writef^%uxxxx"
  101:  ; 
  102:  ; 
  103:  ; Create+write Error message
  104: error(error) 
  105:  i +error=-1 q $$writep("User abort")
  106:  s error=$$writep("Error - "_$$lprompt(error))
  107:  q error
  108:  ; 
  109:  ; LANGUAGE CONVERSION
  110: lprompt(prompt) i $g(prompt)="" q ""
  111:  ; Remove trailing spaces before look-up and re-apply after
  112:  ; Also everything after first -
  113:  ; Everything before ~ is left unchanged and ~ replaced by -
  114:  n s,t,u
  115:  s u="" i prompt["~" s u=$p(prompt,"~")_" - ",prompt=$p(prompt,"~",2,$l(prompt,"~"))
  116:  s t=$f(prompt,"-")-2
  117:  i 't s t=$l(prompt)
  118:  f t=t:-1 q:$e(prompt,t)'=" "
  119:  s s=$e(prompt,t,$l(prompt)),prompt=$e(prompt,1,t-1)
  120:  i prompt'="" s t=$g(@%uprompt@(%ulang,prompt)) i t'="" s prompt=t
  121:  q u_prompt_s
  122:  ; 
  123:  ; ********** UPPER/LOWER CONVERSION NEED TO HANDLE DIFFERENT LANGUAGES/CHARACTERS
  124: upper(text) 
  125:  s text=$tr(text,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  126:  q text
  127:  ; 
  128: lower(text) 
  129:  s text=$tr(text,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
  130:  q text
  131: