Return to %ufxxx.m CVS log

Up to [Coherent Logic Development] / freem / contrib

FreeM

    1: %ufxxx ; File i/o Library - version 0.5.0.1
    2:  ; A.Trocha [1999/02/01-20:20:05]
    3:  ; Utility common file handling subroutines ; Jon Diamond ; 1999-02-18
    4:  ; $Source: /home/cvsroot/freem/contrib/%ufxxx.m,v $
    5:  ; $Revision: 1.1.1.1 $ $Date: 2025/01/19 02:04:04 $
    6:  Q
    7:  ; 
    8:  ; 
    9: direx(path) ;--- test if directory exists
   10:  ;        0 = does not exist     1 = success
   11:  ; 
   12:  S $ZT="%direx99^"_$ZN
   13:  N tmp
   14:  S tmp=$V(2)
   15:  V 2:path
   16:  V 2:tmp
   17:  Q 1
   18:  Q
   19: %direx99 ;--- error
   20:  Q 0
   21:  ; 
   22:  ; 
   23: mkdir(path) ;--- create directory
   24:  ;        0 = error      1 = ok
   25:  ; 
   26:  N exec
   27:  S exec="!mkdir "_path_">/dev/null"
   28:  X exec
   29:  Q $$direx(path)
   30:  ; 
   31:  ; 
   32: rmdir(path) ;--- delete directory   "rm -r"
   33:  ; **** take care ****
   34:  N exec
   35:  S exec="!rm -r "_path_">/dev/null"
   36:  X exec
   37:  Q '$$direx(path)
   38:  ; 
   39:  ; SELECT DEVICE
   40:  ; 
   41: select(device,type,params) 
   42:  n error,d,ntype
   43:  s d=$g(device),type=$g(type),params=$g(params) i type="" s type="in"
   44: %select1 
   45:  s device=d,error=$$readn^%uxxxx($s(type="in":"Input",type="in/out":"Input/Output",1:"Output")_" device: ",.device)
   46:  i error<0 q error
   47:  s ntype=type
   48:  ; 
   49:  ; **** add stuff for parameters etc.??????
   50:  ; **** is it possible to validate for a device name???
   51:  ; **** may want to output to pseudo-device, e.g. global/file
   52: %select2 
   53:  s error=$$open(device,ntype,params,0)
   54:  i error'<0 q "0,select^%ufxxx"
   55:  i +error=-1 q error
   56:  i +error'=-103 s a=$$write(""," - "_error) g %select1
   57:  ; 
   58:  ; Now try again if we didn't try and open the file as a new one
   59:  i ntype'="in",ntype'="new" s ntype="new" g %select2
   60:  s a=$$rerror^%uxxxx("Device not available")
   61:  g %select1
   62:  ; 
   63:  ; 
   64:  ; OPEN DEVICE
   65:  ; 
   66: open(device,type,params,timeout) 
   67:  ; ***** error trapping probably needed here to allow for
   68:  ; ***** device selection
   69:  ; ***** and parameters to be incorrect in some way
   70:  s device=$g(device),params=$g(params)
   71:  i device=""!(device=0)!(device=$i) q "0,open^%ufxxx"
   72:  s timeout=$g(timeout)
   73:  ; ***** handle types = in, in/out, out
   74:  s type=$g(type,"in")
   75:  i type'="out" s params="R"_params
   76:  i type'="in" s params="W"_params
   77:  i type="new" s params="N"_params
   78:  i timeout="" o device:params
   79:  e  o device:params:timeout e  q "-103,open^%ufxxx"
   80:  q "0,open^%ufxxx"
   81:  ; 
   82:  ; 
   83:  ; CLOSE DEVICE
   84: close(device) 
   85:  s device=$g(device)
   86:  i device=""!(device=0)!(device=$i) q "0,close"
   87:  ; ***** do we need to add parameters on close here???
   88:  c device
   89:  q "0,close^%ufxxx"
   90:  ; 
   91:  ; READ WITH PROMPT
   92:  ; 
   93: read(device,prompt,result,length,PX,PY,X,Y,timeout) 
   94:  n a,error
   95:  i '$d(%ulang) s error=$$init^%uxxxx()
   96:  s dev=$i,device=$g(device)
   97:  s prompt=$g(prompt)
   98:  i prompt'="" s error=$$write(device,$$lprompt^%uxxx(prompt),$g(PX),$g(PY)) i error q error
   99:  i dev'=device,device'=0,device'="" u device
  100:  i $g(result)'="" s error=$$write(device," <"_result_"> ") i error q error
  101:  ; 
  102:  ; move to X,Y ********
  103:  i $g(X)'="" s $x=$g(X)
  104:  i $g(Y)'="" s $y=$g(Y)
  105:  i $g(timeout)="" d
  106:  . r a
  107:  e  d
  108:  . r a:$g(timeout)
  109:  ; 
  110:  ; **** hitting escape or escape sequence processing???
  111:  u dev
  112:  i a'="" s result=a
  113:  i a="@" s result=""
  114:  i $g(length),$l(result)>length q "-101,read"
  115:  ; 
  116:  q "0,read^%ufxxx"
  117:  ; 
  118:  ; 
  119:  ; WRITE TEXT
  120: write(device,text,X,Y) 
  121:  n error
  122:  i '$d(%ulang) s error=$$init() i error q error
  123:  s dev=$i,device=$g(device)
  124:  i dev'=device,device'=0,device'="" u device
  125:  ; 
  126:  ; move to X,Y ********
  127:  i $g(X)'="" s $x=$g(X)
  128:  i $g(Y)'="" s $y=$g(Y)
  129:  w text,!
  130:  u dev
  131:  q "0,write^%ufxxx"
  132:  ; 
  133:  ; Write header
  134: header(device,type,comment) 
  135:  n error
  136:  s error=$$write^%ufxxx(device,"**** "_type_" ~ "_$$^%uxdat($h,1)_" ****") i error<0 q error
  137:  s error=$$write^%ufxxx(device,"**** "_$g(comment)_" ****") i error q error
  138:  q "0,header^%ufxxx"
  139:  ; 
  140:  ; Write trailer
  141: trailer(device,type) 
  142:  n a,error
  143:  s a="**** "_$g(type)_" ~ "_$$^%uxdat($h,1)_" ****"
  144:  s error=$$write^%ufxxx(device,"") i error<0 q error
  145:  s error=$$write^%ufxxx(device,a) i error q error
  146:  q "0,header^%ufxxx"
  147: