home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / clipper / nannws31.arc / NETGET.PRG < prev    next >
Encoding:
Text File  |  1988-08-09  |  7.4 KB  |  276 lines
  1. * Program: NetGet.prg
  2. * Author:  David Morgan
  3. * Version: Clipper Summer '87
  4. * Copyright (c) 1988 Nantucket Corp.
  5. *
  6. * Notes:   Clipper UDF to demonstrate a feedback mechanism
  7. *           for use while two or more network workstations are
  8. *           GETting data (into memvars) for the same fields.
  9. *           UDF mirrors other users' changes to the data being
  10. *           edited on your screen.  UDF used in VALID clause,
  11. *           so feedback occurs field-by-field each time you
  12. *           transition GET-to-GET.
  13. *
  14.  
  15. orig_color = SETCOLOR()
  16. CLEAR
  17. SET PROCEDURE TO LOCKS
  18. SET EXCLUSIVE OFF
  19.  
  20. t = 2
  21. l = 2
  22. @ 3, 0 SAY "Coordinates:"
  23. @ 5, 5 SAY "Top_____________________" GET t RANGE 0,23
  24. @ 6, 5 SAY "Left____________________" GET l RANGE 0,79
  25. READ
  26. CLEAR
  27.  
  28. DECLARE files[ADIR("*.DBF")]
  29. ADIR("*.DBF",files)
  30. @ 0,0 TO 10,14
  31. @ 16,1 SAY "Select a file, or ESC to default to NG_Exmpl.dbf"
  32. file = ACHOICE(1,1,9,13,files)
  33. IF file = 0
  34.    USE ng_exmpl
  35.    DECLARE fname[5]
  36.    fname[1] = "st_abbrev"
  37.    fname[2] = "st_name"
  38.    fname[3] = "st_capital"
  39.    fname[4] = "st_bird"
  40.    fname[5] = "st_flower"
  41.    DECLARE cues[5]
  42.    cues[1] = "Here's the abbreviation"
  43.    cues[2] = "Here's the state"
  44.    cues[3] = "Here's the capital city"
  45.    cues[4] = "And the state bird"
  46.    cues[5] = "... and you write the prompts!"
  47. ELSE
  48.    USE (files[file])
  49.    DECLARE fname[FCOUNT()]
  50.    AFIELDS(fname)
  51.    cues = ''
  52. END
  53. CLEAR
  54. DO WHILE net_get(t,l,fname,cues) .AND. LASTKEY() # 27
  55. ENDDO
  56. SETCOLOR(orig_color)
  57. CLEAR
  58. *================================================================
  59.  
  60. FUNCTION Net_get
  61. *
  62. *
  63. PARAMETERS start_row, start_col, names, promts
  64. PRIVATE dimension, p_count
  65. p_count = PCOUNT()
  66. dimension = LEN(names)
  67. PRIVATE  back_color, border_color, f, get_col, get_color, ;
  68.  get_width, old_color, say_color, unsel_color
  69. PRIVATE  current[dimension], last_seen[dimension], ;
  70.  proposed[dimension], they_altered[dimension]
  71. IF IIF( p_count = 3, ;
  72.         .T., ;
  73.         TYPE("promts")#"A")
  74.  
  75.    PRIVATE promts[dimension]
  76.    ACOPY(names,promts)
  77. ELSE
  78.    IF  TYPE("names") # "A" .OR. TYPE("promts") # "A"
  79.       RETURN (.F.)
  80.    END
  81.    IF  LEN(promts) # dimension
  82.       RETURN (.F.)
  83.    END
  84. END
  85. max_promt = LEN(promts[1])
  86. FOR f = 2 TO dimension
  87.    max_promt = MAX(LEN(promts[f]),max_promt)
  88. NEXT
  89. get_col = start_col + max_promt + 3
  90. IF get_col + maxn() > 79
  91.    RETURN(.F.)
  92. END
  93. get_width = LTRIM(STR(80-(get_col+2)))
  94.  
  95. REC_LOCK(0)
  96. scatter(current,names)
  97. UNLOCK
  98. ACOPY(current,last_seen)
  99. ACOPY(current,proposed)
  100. AFILL(they_altered,.F.)
  101. DO Store_colors
  102.  
  103. DO Nget_SAYs()
  104. DO Nget_GETs()
  105. READ
  106. RETURN (.T.)
  107. *----------------------------------------------------------------
  108.  
  109. FUNCTION Ed_sens
  110. *
  111. *
  112. PARAMETERS gf
  113. PRIVATE I_changed, mvar, they_changed, winbuff
  114. STORE .F. TO I_changed, they_changed
  115.  
  116. *** Check for changes by me ***
  117. I_changed = .NOT.(last_seen[gf] == proposed[gf])
  118.  
  119. *** Check for changes by others ***
  120. REC_LOCK(0)
  121. scatter(current,names)            && Do a fresh take on the disk.
  122. they_changed = .NOT.(asame(current,last_seen))
  123.  
  124. IF I_changed
  125.    *** write immediately then unlock
  126.    mvar = names[gf]
  127.    REPLACE &mvar. WITH proposed[gf]
  128.    COMMIT
  129.    UNLOCK              && Unlock immediately once writing is over.
  130.    current[gf] = proposed[gf]      && Keep current[] abreast.
  131.    last_seen[gf] = proposed[gf]    && Keep last_seen[] abreast.
  132.    they_altered[gf] = .F.    && Suppress display of their changes
  133.                              && to this field below, if any.
  134.    SETCOLOR(get_color + get_color + border_color + back_color + ;
  135.          unsel_color)
  136.    resay(proposed,gf)
  137.    SETCOLOR(old_color)
  138. END
  139. UNLOCK
  140.  
  141. IF they_changed
  142.    winbuff = SAVESCREEN(0,0,1,79)
  143.    SET CURSOR OFF
  144.    SETCOLOR(get_color + "*" + get_color + border_color + ;
  145.          back_color + unsel_color)
  146.    @ 0,0 SAY '   ==> Field(s) have been changed by another...'+ ;
  147.          'press any key to continue. <==   '
  148.    FOR f = 1 TO dimension
  149.       IF they_altered[f]
  150.          resay(current,f)
  151.       END
  152.    NEXT
  153.    INKEY(0)
  154.    SET CURSOR ON
  155.    RESTSCREEN(0,0,1,79,winbuff)
  156.    SETCOLOR(get_color + get_color + border_color + back_color + ;
  157.          unsel_color)
  158.    FOR f = 1 TO dimension
  159.       IF they_altered[f]
  160.          resay(current,f)
  161.      END
  162.    NEXT
  163.    SETCOLOR(old_color)
  164.    ACOPY(current,last_seen)    && Bring "last_seen" up to date.
  165.    ACOPY(current,proposed)
  166.    AFILL(they_altered,.F.)
  167. END
  168. RETURN (.T.)
  169. *----------------------------------------------------------------
  170.  
  171. FUNCTION Asame
  172. *
  173. * Determine whether two arrays have identical contents.
  174. * Along the way, track which individual elements do not.
  175. * Initialize they_altered[] to all .F. before calling.
  176. *
  177. PARAMETERS array1,array2
  178. PRIVATE f, g
  179. FOR f = 1 TO dimension
  180.    IF .NOT.(array1[f]==array2[f])
  181.       they_altered[f] = .T.
  182.       FOR g = f+1 TO dimension
  183.          they_altered[g] = .NOT.(array1[g]==array2[g])
  184.       NEXT
  185.       RETURN(.F.)
  186.    END
  187. NEXT
  188. RETURN (.T.)
  189. *----------------------------------------------------------------
  190.  
  191. PROCEDURE Nget_SAYs
  192. *
  193. *
  194. FOR f = 1 TO dimension
  195.    @ start_row+f-1,start_col SAY promts[f]+': '
  196. NEXT
  197. RETURN
  198. *----------------------------------------------------------------
  199.  
  200. PROCEDURE Nget_GETs
  201. *
  202. *
  203. FOR f = 1 TO dimension
  204.    f_str = ltrim(str(f))
  205.  
  206.    IF   IIF( TYPE("proposed[f]") = 'C', ;
  207.            LEN(proposed[f]) > VAL(get_width), ;
  208.            .F. )
  209.    @ start_row+f-1,get_col GET proposed[f] ;
  210.          PICTURE '@S&get_width.';
  211.          VALID ed_sens(&f_str.)
  212.    ELSE
  213.       ** Summer '87 trick follows: submit f to ed_sens laundered
  214.       ** thru macro &f_str. to allow READ to distinguish one GET
  215.       **  from the next by subscript.
  216.       @ start_row+f-1,get_col GET proposed[f] ;
  217.          VALID ed_sens(&f_str.)
  218.    END
  219. NEXT
  220. RETURN
  221. *----------------------------------------------------------------
  222.  
  223. PROCEDURE Store_colors
  224. old_color =    SETCOLOR()
  225. say_color =    SUBSTR(old_color,1,AT(",",old_color)-1)
  226. old_color =    SUBSTR(old_color,AT(",",old_color)+1)
  227. get_color =    SUBSTR(old_color,1,AT(",",old_color)-1)
  228. old_color =    SUBSTR(old_color,AT(",",old_color)+1)
  229. border_color = SUBSTR(old_color,1,AT(",",old_color)-1)
  230. old_color =    SUBSTR(old_color,AT(",",old_color)+1)
  231. back_color =   SUBSTR(old_color,1,AT(",",old_color)-1)
  232. unsel_color =  SUBSTR(old_color,AT(",",old_color)+1)
  233. old_color =    SETCOLOR()
  234. RETURN
  235. *----------------------------------------------------------------
  236.  
  237. FUNCTION Scatter
  238. *
  239. * Make array image of a record.
  240. * Requires successful RLOCK() before calling.
  241. *
  242. PARAMETERS c_array,f_array    && contents array and fields array
  243. PRIVATE f, mvar
  244. FOR f = 1 TO LEN(f_array)
  245.  mvar = f_array[f]
  246.  c_array[f] = &mvar.
  247. NEXT
  248. RETURN (.T.)
  249. *----------------------------------------------------------------
  250.  
  251. FUNCTION Maxn
  252. * Return length of longest numeric field in current DBF.
  253. PRIVATE f, i, fieldt[FCOUNT()], fieldw[FCOUNT()], mn
  254. AFIELDS('',fieldt,fieldw)
  255. STORE 0 TO i, mn
  256. f = FCOUNT()
  257. DO WHILE i < f
  258.    i = ASCAN(fieldt,"N",i+1)
  259.    IF i = 0
  260.       EXIT
  261.    END
  262.    mn = MAX(fieldw[i],mn)
  263. END
  264. RETURN(mn)
  265. *----------------------------------------------------------------
  266.  
  267. FUNCTION Resay
  268. PARAMETERS array, ff
  269. IF TYPE("array[ff]") = 'C'
  270.    @ start_row+ff-1,get_col SAY SUBSTR(array[ff],1,VAL(get_width))
  271. ELSE
  272.    @ start_row+ff-1,get_col SAY array[ff]
  273. END
  274. RETURN (.T.)
  275. *================================================================
  276.