home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / DBMS9104.ZIP / LEIFXTRA.LST < prev    next >
Encoding:
File List  |  1991-03-01  |  16.1 KB  |  590 lines
  1. /*
  2.    CBTEST.PRG
  3.    Various code snippets demonstrating the use
  4.    and abuse of the much maligned CODE BLOCKS!
  5.    Greg Lief -- for DBMS Magazine
  6.    Compile instructions: clipper cbtest /n/w/a
  7. */
  8.  
  9. #include "inkey.ch"
  10. #include "memoedit.ch"
  11. #include "box.ch"
  12.  
  13. #define TEST          // to compile test program
  14.  
  15. // test program begins here
  16. #ifdef TEST
  17.  
  18. /*
  19.    main stub to call the other guys
  20. */
  21. function main
  22. local x
  23. for x := 1 to 13
  24.    cls
  25.    qout("test #" + ltrim(str(x)))
  26.    eval( &("{ | | test" + ltrim(str(x)) + "() }") )
  27. next
  28. return nil
  29.  
  30. #endif
  31.  
  32. // test program ends -- examples begin
  33.  
  34. /*
  35.    basic evaluation of a code block
  36. */
  37. function test1
  38. local myblock := { | | mvar }, mvar := 500, x
  39. x := eval(myblock)
  40. ? x                        // output: 500
  41. return inkey(0)
  42.  
  43.  
  44. /*
  45.    evaluation of a code block with QOUT() call
  46. */
  47. function test2
  48. local myblock := { | | qout(mvar) }, mvar := 500
  49. eval(myblock)              // output: 500
  50. return inkey(0)
  51.  
  52.  
  53. /*
  54.    evaluation of a code block with multiple expressions
  55.    and assignment of rightmost expression to variable
  56. */
  57. function test3
  58. local myblock := { | | qout(var1), qqout(var2), 500 }
  59. local var1 := "Mister ", var2 := "Grump", x
  60. x := eval(myblock)              // output: "Mister Grump"
  61. ? x                             // output: 500
  62. return inkey(0)
  63.  
  64.  
  65. /*
  66.    code block that increments a variable
  67. */
  68. function test4
  69. local myblock := { | | x++ }, x := 1, y
  70. for y := 1 to 100
  71.    eval(myblock)
  72. next
  73. ? x              // output: 101
  74. return inkey(0)
  75.  
  76.  
  77. /*
  78.    code block that calls a UDF - no parameters
  79. */
  80. function test5
  81. local myblock := { | | BlueFunc() }
  82. eval(myblock)   // calls BlueFunc() which displays a message
  83. return nil
  84.  
  85. static function bluefunc
  86. ? "here we are in a BlueFunc() - will we ever escape?"
  87. inkey(5)
  88. return nil
  89.  
  90.  
  91. /*
  92.    code block with parameters
  93. */
  94. function test6
  95. local myblock := { | a, b, c | max(a, max(b, c)) }
  96. ? eval(myblock, 20, 100, 30)    // output: 100
  97. return inkey(0)
  98.  
  99.  
  100. /*
  101.    code block that calls a UDF with a parameter
  102. */
  103. function test7
  104. local myblock := { | x | BlueFunc2(x) }
  105. eval(myblock, 20)   // calls BlueFunc2() and will wait 20 seconds
  106. return nil
  107.  
  108. static function bluefunc2(delay)
  109. ? "we're in a BlueFunc() for " + ltrim(str(delay)) + " seconds"
  110. inkey(delay)
  111. return nil
  112.  
  113.  
  114. /*
  115.    code block with less parameters than arguments
  116.    and assignment (of NIL) to a variable
  117. */
  118. function test8
  119. local myblock := { | a, b, c | qout(a, b, c) }, x
  120. eval(myblock, 1, 2, 3)       // output: 1 2 3
  121. x := eval(myblock, 1, 2)     // output: 1 2 NIL
  122. ? x                          // output: NIL
  123. return inkey(0)
  124.  
  125.  
  126. /*
  127.    AEVAL() to determine max, min, and sum of array elements
  128.    Also increments and displays all array elements
  129. */
  130. function test9
  131. local myarray := { 75, 100, 2, 200, .25, -25, 40, 52 }, ;
  132.       nmax, nmin, nsum := 0
  133. nmax := nmin := myarray[1]
  134. ? "Current array elements"
  135. aeval(myarray, { | a, b | nmax := max(nmax, a), nmin := min(nmin, a),;
  136.       nsum += a, qout("Element #", ltrim(str(b)), a) } )
  137. devpos(row() + 1, 0)
  138. ? "Maximum value:", nmax         // 200
  139. ? "Minimum value:", nmin         // -25
  140. ? "Total amount: ", nsum         // 444.25
  141. inkey(0)
  142. devpos(row() + 1, 0)
  143. aeval(myarray, { | a, b | myarray[b]++ } )
  144. ? "Array elements after incrementing"
  145. aeval(myarray, { | a, b | qout("Element #", ltrim(str(b)), a) } )
  146. return inkey(0)
  147.  
  148.  
  149. /*
  150.    DBEVAL() example to determine total and maximum balance
  151. */
  152. function test10
  153. // create test database on-the-fly
  154. local ntotal := 0, nmax := 0, x
  155. dbcreate("test", { { "BALANCE", "N", 2, 0 } } )
  156. use test
  157. for x := 1 to 40
  158.    append blank
  159.    fieldput(1, recno())
  160. next
  161. DBEval( { | | ntotal += test->balance, nmax := max(nmax, test->balance) } )
  162. ? "Total:  ", ntotal
  163. ? "Maximum:", nmax
  164. use
  165. ferase("test.dbf")   // stop me before I kill again
  166. return inkey(0)
  167.  
  168.  
  169. /*
  170.    case-insensitive ASCAN()
  171. */
  172. function test11
  173. local myarray := { "gReG", "Justin", "Jennifer", "Traci", "Don" }
  174. local mvar := "jEnNiFeR", ele
  175. ? "searching for " + mvar
  176. ele := ascan(myarray, { | a | if(valtype(a) == "C", ;
  177.                        upper(a) = upper(mvar), .F.) } )
  178. ? "located at element #" + ltrim(str(ele)), "(" + myarray[ele] + ")"
  179. return inkey(0)
  180.  
  181.  
  182. /*
  183.    descending ASORT()
  184. */
  185. function test12
  186. local myarray := { "GREG", "JUSTIN", "JENNIFER", "TRACI", "DON" }
  187. asort(myarray,,, { | x, y | x > y } )
  188. aeval(myarray, { | a | qout(a) } )
  189. return inkey(0)
  190.  
  191.  
  192. /*
  193.    directory sorted by file date then name
  194. */
  195. function test13
  196. local files_ := directory("*.*")
  197. asort(files_,,, { | x, y | if( x[3] = y[3], x[1] < y[1], ;
  198.                                x[3] < y[3] ) } )
  199. // note optional parameters to limit AEVAL() to first
  200. // 20 elements of array -- so we don't scroll off the screen
  201. aeval(files_, { | a | qout(padr(a[1], 14), a[3]) }, 1, 20)
  202. return inkey(0)
  203.  
  204.  
  205. /*
  206.    Other Miscellaneous Examples of Code Blocks
  207. */
  208.  
  209.  
  210. /*
  211.    STRUCT() -- demonstration of using FIELDBLOCK() to
  212.                retrieve field values
  213.    Syntax: STRUCT(<dbffile>)
  214. */
  215. function struct(dbf_file)
  216. local struct, x
  217. if dbf_file == NIL
  218.    qout("Syntax: struct <dbf_name>")
  219. elseif ! file(dbf_file) .and. ! file(dbf_file + ".dbf")
  220.    qout("Could not open " + dbf_file)
  221. else
  222.    use (dbf_file)
  223.    struct := dbstruct()
  224.    qout("Field Name Type Len Dec Contents of First Record")
  225.    for x := 1 to len(struct)
  226.       qout(padr(struct[x, 1], 10), padr(struct[x, 2], 4), ;
  227.            str(struct[x, 3], 3), str(struct[x, 4], 3),    ;
  228.            eval(fieldblock(struct[x, 1])) )
  229.    next
  230.    /*
  231.        you could also cram that into one AEVAL() like so:
  232.  
  233.        aeval(dbstruct(), { | a | qout(padr(a[1], 10), padr(a[2], 4), ;
  234.              str(a[3], 3), str(a[4], 3), eval(fieldblock(a[1]))) } )
  235.    */
  236.    use
  237. endif
  238. return nil
  239.  
  240. *-----------------------------------------------------------*
  241.  
  242. /*
  243.    Example of scatter/gather using FIELDBLOCK()
  244. */
  245.  
  246. #define mNAME         scatter_[1]
  247. #define mTITLE        scatter_[2]
  248. #define mDATE         scatter_[3]
  249. #define mKEYWORDS     scatter_[4]
  250. #define mFILENAME     scatter_[5]
  251. #define mCODEFILE     scatter_[6]
  252. #define mREAD         scatter_[7]
  253. #define mCOMMENTS     scatter_[8]
  254.  
  255. function fbtest(mode)
  256. memvar getlist
  257. local scatter_ := {}, oldcurs, marker
  258. local fieldnames_ := { 'NAME', 'TITLE', 'DATE', 'KEYWORDS', ;
  259.                        'FILENAME', 'CODEFILE', 'READ', 'COMMENTS'}
  260. if ! file('test.dbf')
  261.    dbcreate('test', { { "NAME",  "C", 20, 0 }    , ;
  262.                       { "TITLE", "C", 50, 0 }    , ;
  263.                       { "DATE",  "D",  8, 0 }    , ;
  264.                       { "KEYWORDS", "C", 50, 0 } , ;
  265.                       { "FILENAME", "C", 12, 0 } , ;
  266.                       { "CODEFILE", "C", 12, 0 } , ;
  267.                       { "READ", "L", 1, 0 }      , ;
  268.                       { "COMMENTS", "C", 50, 0 } } )
  269. endif
  270. use test
  271. /* if file is empty, switch to Add mode */
  272. if lastrec() = 0
  273.    mode := "A"
  274. endif
  275. /* display static text */
  276. setcolor('+W/B,+W/N,,,+W/B')
  277. @  9, 33 say [NAME]
  278. @ 10, 32 say [TITLE]
  279. @ 11, 33 say [DATE]
  280. @ 12, 29 say [KEYWORDS]
  281. @ 13, 29 say [FILENAME]
  282. @ 14, 29 say [CODEFILE]
  283. @ 15, 33 say [READ]
  284. @ 16, 29 say [COMMENTS]
  285.  
  286. // use the phantom record to grab initial values if adding
  287. if mode = 'A'
  288.    marker := recno()
  289.    go bottom
  290.    skip
  291. endif
  292. /* initialize memory variables using FIELDBLOCK() */
  293. aeval(fieldnames_, { | a | aadd(scatter_, eval(fieldblock(a))) } )
  294. // go GET 'em
  295. @  9, 39 get mNAME picture 'XXXXXXXXXXXXXXXXXXXX'
  296. @ 10, 39 get mTITLE picture '@S35'
  297. @ 11, 39 get mDATE picture 'XXXXX'
  298. @ 12, 39 get mKEYWORDS picture '@S35'
  299. @ 13, 39 get mFILENAME picture 'XXXXXXXXXXXX'
  300. @ 14, 39 get mCODEFILE picture 'XXXXXXXXXXXX'
  301. @ 15, 39 get mREAD picture 'Y'
  302. @ 16, 39 get mCOMMENTS picture '@S35'
  303. oldcurs := setcursor(if(mode = 'V', 0, 1))
  304. if mode != 'V'
  305.    read
  306. else
  307.    clear gets
  308.    inkey(0)
  309. endif
  310. setcursor(oldcurs)
  311. // do the replaces if they didn't escape out
  312. if lastkey() != K_ESC
  313.    if mode = 'A'
  314.       append blank
  315.    endif
  316.    /* assign memvar values to fields using FIELDBLOCK() */
  317.    aeval(fieldnames_, { | a, x | eval(fieldblock(a), scatter_[x]) } )
  318. else
  319.    // if in add mode, must reset record pointer
  320.    if mode = 'A'
  321.       go marker
  322.    endif
  323. endif
  324. return nil
  325.  
  326. *-----------------------------------------------------------*
  327.  
  328. /*
  329.    demonstration of FIELDWBLOCK()
  330. */
  331. function fwbtest
  332. dbcreate("customer", { { "LNAME", "C", 10, 0 } })
  333. dbcreate("vendor", { { "LNAME", "C", 10, 0 } })
  334. use customer new
  335. append blank
  336. customer->lname := "CUSTOMER1"
  337. use vendor new
  338. append blank
  339. vendor->lname := "VENDOR1"
  340. ? eval(fieldwblock("LNAME", select("customer"))) // CUSTOMER1
  341. ? eval(fieldwblock("LNAME", select("vendor")))   // VENDOR1
  342. ? eval(fieldwblock("LNAME", select("vendor")), "Grumpfish")
  343. ? vendor->lname                                  // Grumpfish
  344. close data
  345. ferase("customer.dbf")          // stop me before I kill again
  346. ferase("vendor.dbf")            // too late!  I killed again!!
  347. return nil
  348.  
  349. *-----------------------------------------------------------*
  350.  
  351. /*
  352.    GINKEY(<delay>)
  353.    INKEY() wait state
  354.    Author: Greg Lief
  355.    Copyright (c) 1990 Greg Lief
  356.    Excerpted from the Grumpfish Library
  357. */
  358. function ginkey(waittime)
  359. local key := inkey(waittime), cblock
  360. cblock := setkey(key)
  361. if cblock != NIL  // there is a code block for this keypress
  362.    eval(cblock, procname(1), procline(1), 'ginkey')
  363. endif
  364. return key
  365.  
  366. *-----------------------------------------------------------*
  367.  
  368. /*
  369.    Demonstration of SETKEY(), including saving, resetting,
  370.    and restoring F1 hot key, and an INKEY() wait state
  371. */
  372.  
  373.  
  374. function hotkeytest
  375. local key, bblock
  376. setkey(K_F1, { | | hotkey1() } )
  377. ? "Press F1 now to enter first hot key procedure"
  378. key := inkey(0)
  379. if (bblock := setkey(key)) != NIL
  380.    eval(bblock)
  381. endif
  382. return nil
  383. /*---------------------------------------------------*/
  384. static function hotkey1()
  385. local old_f1 := setkey(K_F1, { | | hotkey2() } )
  386. ? "Now in first hot key function"
  387. wait "Press F1 to jump to second hot key function"
  388. setkey(K_F1, old_f1)                // restore F1 hot key
  389. ? "Returning to main function"
  390. return nil
  391. /*---------------------------------------------------*/
  392. static function hotkey2()
  393. local old_f1 := setkey(K_F1, NIL )  // turn off F1 hot key
  394. ? "Now in second hot key function"
  395. wait
  396. setkey(K_F1, old_f1)                // restore F1 hot key
  397. ? "Returning to first hot key function"
  398. return nil
  399.  
  400. *-----------------------------------------------------------*
  401.  
  402. /*
  403.     MEMEDIT()
  404.     Generic memo-editing function
  405.     Excerpted from Grumpfish Library
  406.     Syntax:  MEMEDIT(<field>, <top>, <left>, <bottom>, <right>)
  407.  
  408.     <field> is a character string representing the name of the
  409.     memo field or variable to be editing.  This must be surrounded
  410.     by quotes, unless you want to edit a STATIC or LOCAL variable
  411.     (in which case you should omit the quotes.)
  412.  
  413.     <top>, <left>, <bottom>, <right> are numerics representing
  414.     the box coordinates.
  415. */
  416.  
  417. // begin preprocessor directives
  418.  
  419. #command DEFAULT <param> TO <value> => ;
  420.          <param> := IF(<param> == NIL, <value>, <param>)
  421.  
  422. // end preprocessor directives
  423.  
  424. function memedit(cfield, ntop, nleft, nbottom, nright)
  425. local oldcolor := setcolor("+w/r"), oldscrn, ret_val := .t., ;
  426.       memo, oldexact := set(_SET_EXACT, .T.), oldcurs := setcursor(3)
  427. default ntop to 5
  428. default nleft to 10
  429. default nbottom to 19
  430. default nright to 69
  431. oldscrn := savescreen(ntop, nleft, nbottom, nright)
  432. @ ntop, nleft, nbottom, nright box B_DOUBLE + chr(32)
  433. @ nbottom, nleft + INT(nright - nleft) / 2 - 8 SAY '^W save, Esc exit'
  434. setcolor("+w/n")
  435. scroll(ntop + 1, nleft + 1, nbottom - 1, nright - 1, 0)
  436. /*
  437.    if we are editing a field, FIELDBLOCK() will not return NIL.
  438.    if we are editing a PUBLIC or PRIVATE variable, MEMVARBLOCK() will
  439.    not return NIL.  Thus, if they both return NIL, we know that we
  440.    are editing a STATIC or LOCAL variable.
  441. */
  442. if (memo := fieldblock(cfield)) = NIL .and. (memo := memvarblock(cfield)) = NIL
  443.    memo := cfield
  444. else
  445.    memo := eval(memo)   // retrieve the starting value from the code block
  446. endif
  447. memo := memoedit(memo, ntop + 1, nleft + 1, nbottom - 1, nright - 1, ;
  448.                  .t., 'editfunc', , 3)
  449. if lastkey() != K_ESC
  450.    do case
  451.  
  452.       /* we edited a field */
  453.       case fieldblock(cfield) != NIL
  454.          if rlock()
  455.             eval( fieldblock(cfield) , memo)
  456.             unlock
  457.          else
  458.             err_msg("Could not lock record - edits not saved")
  459.             ret_val := .f.
  460.          endif
  461.  
  462.       /* we edited a private or public variable */
  463.       case memvarblock(cfield) != NIL
  464.          eval( memvarblock(cfield) , memo)
  465.  
  466.       /* we edited a local or static variable */
  467.       otherwise
  468.          cfield := memo
  469.    endcase
  470. else
  471.    ret_val := .f.
  472. endif
  473. setcursor(oldcurs)
  474. restscreen(ntop, nleft, nbottom, nright, oldscrn)
  475. setcolor(oldcolor)
  476. set(_SET_EXACT, oldexact)
  477. return ret_val
  478.  
  479. * end function MemEdit()
  480. *--------------------------------------------------------------------*
  481.  
  482.  
  483. /*
  484.   EditFunc() -- alters "ABORT Y/N" msg if Esc is hit during
  485.   the Memoedit above (only if changes have been made)
  486.   Note that this function cannot be declared STATIC.  This
  487.   is because MEMOEDIT() uses macro substitution to run an
  488.   attached UDF, and STATIC functions do not have entries
  489.   in the symbol table (and thus cannot be macro substituted).
  490. */
  491. function EscFunc(stat, line, col)
  492. local buffer
  493. if lastkey() = K_ESC .and. stat = 2
  494.    buffer := savescreen(0, 60, 0, 75)
  495.    @ 0,60 say 'MEMO NOT UPDATED'
  496.    tone(440, 1)
  497.    tone(440, 1)
  498.    inkey(1)
  499.    restscreen(0, 60, 0, 75, buffer)
  500. else
  501. endif
  502. return ME_DEFAULT
  503.  
  504. * end function EditFunc()
  505. *--------------------------------------------------------------------*
  506.  
  507.  
  508. /*
  509.    Demonstration of passing LOCAL variables to another function
  510.    via a code block.  This example enables changing the value
  511.    of a LOCAL variable inside a hot key function via passing the
  512.    variable by reference.
  513. */
  514.  
  515. function cbvartest
  516. local mvalue := space(7), oldaltv, x
  517. memvar getlist
  518. if ! file("lookup.dbf")
  519.    dbcreate("lookup", { { "LNAME", "C", 7, 0 } } )
  520.    use lookup
  521.    for x := 1 to 9
  522.       append blank
  523.       /* note use of unnamed array -- it works just fine this way */
  524.       replace lookup->lname with { "BOOTH", "DONNAY", "FORCIER", ;
  525.             "LIEF", "MAIER", "MEANS", "NEFF", "ROUTH", "YELLICK" }[x]
  526.    next
  527. else
  528.    use lookup
  529. endif
  530. oldaltv := setkey( K_ALT_V, {| | View_Vals(@mvalue)} )
  531. setcolor('+gr/b')
  532. cls
  533. @ 4, 28 say "Enter last name:" get mvalue
  534. setcolor('+w/b')
  535. @ 5, 23 say '(press Alt-V for available authors)'
  536. read
  537. quit
  538. /*--------------------------------------------------------------*/
  539. static function view_vals(v)
  540. local browse, column, key, marker := recno(),                   ;
  541.       oldscrn := savescreen(8, 35, 20, 44, 2),                  ;
  542.       oldcolor := setcolor("+W/RB"), oldcursor := setcursor(0), ;
  543.       oldblock := setkey( K_ALT_V, NIL )  // turn off ALT-V
  544. @ 8, 35, 20, 44 box B_SINGLE + chr(32)
  545. browse := TBrowseDB(9, 36, 19, 43)
  546. browse:headSep := "═"
  547. browse:colorSpec := '+W/RB, +W/N'
  548. column := TBColumnNew( "Author", FieldBlock("lname") )
  549. browse:addColumn(column)
  550. go top
  551. do while .t.
  552.    do while ! browse:stabilize() .and. (key := inkey()) = 0
  553.    enddo
  554.    if browse:stable
  555.       key := inkey(0)
  556.    endif
  557.    do case
  558.       case key == K_UP
  559.          browse:up()
  560.       case key == K_DOWN
  561.          browse:down()
  562.       case key == K_CTRL_PGUP
  563.          browse:goTop()
  564.       case key == K_CTRL_PGDN
  565.          browse:goBottom()
  566.       case key == K_PGUP .or. key == K_HOME
  567.          browse:pageUp()
  568.       case key == K_PGDN .or. key == K_END
  569.          browse:pageDown()
  570.       case key == K_ESC .or. key == K_ENTER
  571.          exit
  572.    endcase
  573. enddo
  574. if lastkey() != K_ESC
  575.    /*
  576.       because we passed the variable BY REFERENCE in the code block,
  577.       any changes we make here are being made to the actual variable,
  578.       and that is the key to this whole mess working the way it does!
  579.    */
  580.    v := eval(fieldblock('lname'))
  581. endif
  582. go marker
  583. restscreen(8, 35, 20, 44, oldscrn)
  584. setcolor(oldcolor)
  585. setcursor(oldcursor)
  586. setkey(K_ALT_V, oldblock)   // reset Alt-V for next time
  587. return nil
  588.  
  589. * eof: cbtest.prg
  590.