Category : Files from Magazines
Archive   : DBMS9104.ZIP
Filename : LEIFXTRA.LST

/*
CBTEST.PRG
Various code snippets demonstrating the use
and abuse of the much maligned CODE BLOCKS!
Greg Lief -- for DBMS Magazine
Compile instructions: clipper cbtest /n/w/a
*/

#include "inkey.ch"
#include "memoedit.ch"
#include "box.ch"

#define TEST // to compile test program

// test program begins here
#ifdef TEST

/*
main stub to call the other guys
*/
function main
local x
for x := 1 to 13
cls
qout("test #" + ltrim(str(x)))
eval( &("{ | | test" + ltrim(str(x)) + "() }") )
next
return nil

#endif

// test program ends -- examples begin

/*
basic evaluation of a code block
*/
function test1
local myblock := { | | mvar }, mvar := 500, x
x := eval(myblock)
? x // output: 500
return inkey(0)


/*
evaluation of a code block with QOUT() call
*/
function test2
local myblock := { | | qout(mvar) }, mvar := 500
eval(myblock) // output: 500
return inkey(0)


/*
evaluation of a code block with multiple expressions
and assignment of rightmost expression to variable
*/
function test3
local myblock := { | | qout(var1), qqout(var2), 500 }
local var1 := "Mister ", var2 := "Grump", x
x := eval(myblock) // output: "Mister Grump"
? x // output: 500
return inkey(0)


/*
code block that increments a variable
*/
function test4
local myblock := { | | x++ }, x := 1, y
for y := 1 to 100
eval(myblock)
next
? x // output: 101
return inkey(0)


/*
code block that calls a UDF - no parameters
*/
function test5
local myblock := { | | BlueFunc() }
eval(myblock) // calls BlueFunc() which displays a message
return nil

static function bluefunc
? "here we are in a BlueFunc() - will we ever escape?"
inkey(5)
return nil


/*
code block with parameters
*/
function test6
local myblock := { | a, b, c | max(a, max(b, c)) }
? eval(myblock, 20, 100, 30) // output: 100
return inkey(0)


/*
code block that calls a UDF with a parameter
*/
function test7
local myblock := { | x | BlueFunc2(x) }
eval(myblock, 20) // calls BlueFunc2() and will wait 20 seconds
return nil

static function bluefunc2(delay)
? "we're in a BlueFunc() for " + ltrim(str(delay)) + " seconds"
inkey(delay)
return nil


/*
code block with less parameters than arguments
and assignment (of NIL) to a variable
*/
function test8
local myblock := { | a, b, c | qout(a, b, c) }, x
eval(myblock, 1, 2, 3) // output: 1 2 3
x := eval(myblock, 1, 2) // output: 1 2 NIL
? x // output: NIL
return inkey(0)


/*
AEVAL() to determine max, min, and sum of array elements
Also increments and displays all array elements
*/
function test9
local myarray := { 75, 100, 2, 200, .25, -25, 40, 52 }, ;
nmax, nmin, nsum := 0
nmax := nmin := myarray[1]
? "Current array elements"
aeval(myarray, { | a, b | nmax := max(nmax, a), nmin := min(nmin, a),;
nsum += a, qout("Element #", ltrim(str(b)), a) } )
devpos(row() + 1, 0)
? "Maximum value:", nmax // 200
? "Minimum value:", nmin // -25
? "Total amount: ", nsum // 444.25
inkey(0)
devpos(row() + 1, 0)
aeval(myarray, { | a, b | myarray[b]++ } )
? "Array elements after incrementing"
aeval(myarray, { | a, b | qout("Element #", ltrim(str(b)), a) } )
return inkey(0)


/*
DBEVAL() example to determine total and maximum balance
*/
function test10
// create test database on-the-fly
local ntotal := 0, nmax := 0, x
dbcreate("test", { { "BALANCE", "N", 2, 0 } } )
use test
for x := 1 to 40
append blank
fieldput(1, recno())
next
DBEval( { | | ntotal += test->balance, nmax := max(nmax, test->balance) } )
? "Total: ", ntotal
? "Maximum:", nmax
use
ferase("test.dbf") // stop me before I kill again
return inkey(0)


/*
case-insensitive ASCAN()
*/
function test11
local myarray := { "gReG", "Justin", "Jennifer", "Traci", "Don" }
local mvar := "jEnNiFeR", ele
? "searching for " + mvar
ele := ascan(myarray, { | a | if(valtype(a) == "C", ;
upper(a) = upper(mvar), .F.) } )
? "located at element #" + ltrim(str(ele)), "(" + myarray[ele] + ")"
return inkey(0)


/*
descending ASORT()
*/
function test12
local myarray := { "GREG", "JUSTIN", "JENNIFER", "TRACI", "DON" }
asort(myarray,,, { | x, y | x > y } )
aeval(myarray, { | a | qout(a) } )
return inkey(0)


/*
directory sorted by file date then name
*/
function test13
local files_ := directory("*.*")
asort(files_,,, { | x, y | if( x[3] = y[3], x[1] < y[1], ;
x[3] < y[3] ) } )
// note optional parameters to limit AEVAL() to first
// 20 elements of array -- so we don't scroll off the screen
aeval(files_, { | a | qout(padr(a[1], 14), a[3]) }, 1, 20)
return inkey(0)


/*
Other Miscellaneous Examples of Code Blocks
*/


/*
STRUCT() -- demonstration of using FIELDBLOCK() to
retrieve field values
Syntax: STRUCT()
*/
function struct(dbf_file)
local struct, x
if dbf_file == NIL
qout("Syntax: struct ")
elseif ! file(dbf_file) .and. ! file(dbf_file + ".dbf")
qout("Could not open " + dbf_file)
else
use (dbf_file)
struct := dbstruct()
qout("Field Name Type Len Dec Contents of First Record")
for x := 1 to len(struct)
qout(padr(struct[x, 1], 10), padr(struct[x, 2], 4), ;
str(struct[x, 3], 3), str(struct[x, 4], 3), ;
eval(fieldblock(struct[x, 1])) )
next
/*
you could also cram that into one AEVAL() like so:

aeval(dbstruct(), { | a | qout(padr(a[1], 10), padr(a[2], 4), ;
str(a[3], 3), str(a[4], 3), eval(fieldblock(a[1]))) } )
*/
use
endif
return nil

*-----------------------------------------------------------*

/*
Example of scatter/gather using FIELDBLOCK()
*/

#define mNAME scatter_[1]
#define mTITLE scatter_[2]
#define mDATE scatter_[3]
#define mKEYWORDS scatter_[4]
#define mFILENAME scatter_[5]
#define mCODEFILE scatter_[6]
#define mREAD scatter_[7]
#define mCOMMENTS scatter_[8]

function fbtest(mode)
memvar getlist
local scatter_ := {}, oldcurs, marker
local fieldnames_ := { 'NAME', 'TITLE', 'DATE', 'KEYWORDS', ;
'FILENAME', 'CODEFILE', 'READ', 'COMMENTS'}
if ! file('test.dbf')
dbcreate('test', { { "NAME", "C", 20, 0 } , ;
{ "TITLE", "C", 50, 0 } , ;
{ "DATE", "D", 8, 0 } , ;
{ "KEYWORDS", "C", 50, 0 } , ;
{ "FILENAME", "C", 12, 0 } , ;
{ "CODEFILE", "C", 12, 0 } , ;
{ "READ", "L", 1, 0 } , ;
{ "COMMENTS", "C", 50, 0 } } )
endif
use test
/* if file is empty, switch to Add mode */
if lastrec() = 0
mode := "A"
endif
/* display static text */
setcolor('+W/B,+W/N,,,+W/B')
@ 9, 33 say [NAME]
@ 10, 32 say [TITLE]
@ 11, 33 say [DATE]
@ 12, 29 say [KEYWORDS]
@ 13, 29 say [FILENAME]
@ 14, 29 say [CODEFILE]
@ 15, 33 say [READ]
@ 16, 29 say [COMMENTS]

// use the phantom record to grab initial values if adding
if mode = 'A'
marker := recno()
go bottom
skip
endif
/* initialize memory variables using FIELDBLOCK() */
aeval(fieldnames_, { | a | aadd(scatter_, eval(fieldblock(a))) } )
// go GET 'em
@ 9, 39 get mNAME picture 'XXXXXXXXXXXXXXXXXXXX'
@ 10, 39 get mTITLE picture '@S35'
@ 11, 39 get mDATE picture 'XXXXX'
@ 12, 39 get mKEYWORDS picture '@S35'
@ 13, 39 get mFILENAME picture 'XXXXXXXXXXXX'
@ 14, 39 get mCODEFILE picture 'XXXXXXXXXXXX'
@ 15, 39 get mREAD picture 'Y'
@ 16, 39 get mCOMMENTS picture '@S35'
oldcurs := setcursor(if(mode = 'V', 0, 1))
if mode != 'V'
read
else
clear gets
inkey(0)
endif
setcursor(oldcurs)
// do the replaces if they didn't escape out
if lastkey() != K_ESC
if mode = 'A'
append blank
endif
/* assign memvar values to fields using FIELDBLOCK() */
aeval(fieldnames_, { | a, x | eval(fieldblock(a), scatter_[x]) } )
else
// if in add mode, must reset record pointer
if mode = 'A'
go marker
endif
endif
return nil

*-----------------------------------------------------------*

/*
demonstration of FIELDWBLOCK()
*/
function fwbtest
dbcreate("customer", { { "LNAME", "C", 10, 0 } })
dbcreate("vendor", { { "LNAME", "C", 10, 0 } })
use customer new
append blank
customer->lname := "CUSTOMER1"
use vendor new
append blank
vendor->lname := "VENDOR1"
? eval(fieldwblock("LNAME", select("customer"))) // CUSTOMER1
? eval(fieldwblock("LNAME", select("vendor"))) // VENDOR1
? eval(fieldwblock("LNAME", select("vendor")), "Grumpfish")
? vendor->lname // Grumpfish
close data
ferase("customer.dbf") // stop me before I kill again
ferase("vendor.dbf") // too late! I killed again!!
return nil

*-----------------------------------------------------------*

/*
GINKEY()
INKEY() wait state
Author: Greg Lief
Copyright (c) 1990 Greg Lief
Excerpted from the Grumpfish Library
*/
function ginkey(waittime)
local key := inkey(waittime), cblock
cblock := setkey(key)
if cblock != NIL // there is a code block for this keypress
eval(cblock, procname(1), procline(1), 'ginkey')
endif
return key

*-----------------------------------------------------------*

/*
Demonstration of SETKEY(), including saving, resetting,
and restoring F1 hot key, and an INKEY() wait state
*/


function hotkeytest
local key, bblock
setkey(K_F1, { | | hotkey1() } )
? "Press F1 now to enter first hot key procedure"
key := inkey(0)
if (bblock := setkey(key)) != NIL
eval(bblock)
endif
return nil
/*---------------------------------------------------*/
static function hotkey1()
local old_f1 := setkey(K_F1, { | | hotkey2() } )
? "Now in first hot key function"
wait "Press F1 to jump to second hot key function"
setkey(K_F1, old_f1) // restore F1 hot key
? "Returning to main function"
return nil
/*---------------------------------------------------*/
static function hotkey2()
local old_f1 := setkey(K_F1, NIL ) // turn off F1 hot key
? "Now in second hot key function"
wait
setkey(K_F1, old_f1) // restore F1 hot key
? "Returning to first hot key function"
return nil

*-----------------------------------------------------------*

/*
MEMEDIT()
Generic memo-editing function
Excerpted from Grumpfish Library
Syntax: MEMEDIT(, , , , )

is a character string representing the name of the
memo field or variable to be editing. This must be surrounded
by quotes, unless you want to edit a STATIC or LOCAL variable
(in which case you should omit the quotes.)

, , , are numerics representing
the box coordinates.
*/

// begin preprocessor directives

#command DEFAULT TO => ;
:= IF( == NIL, , )

// end preprocessor directives

function memedit(cfield, ntop, nleft, nbottom, nright)
local oldcolor := setcolor("+w/r"), oldscrn, ret_val := .t., ;
memo, oldexact := set(_SET_EXACT, .T.), oldcurs := setcursor(3)
default ntop to 5
default nleft to 10
default nbottom to 19
default nright to 69
oldscrn := savescreen(ntop, nleft, nbottom, nright)
@ ntop, nleft, nbottom, nright box B_DOUBLE + chr(32)
@ nbottom, nleft + INT(nright - nleft) / 2 - 8 SAY '^W save, Esc exit'
setcolor("+w/n")
scroll(ntop + 1, nleft + 1, nbottom - 1, nright - 1, 0)
/*
if we are editing a field, FIELDBLOCK() will not return NIL.
if we are editing a PUBLIC or PRIVATE variable, MEMVARBLOCK() will
not return NIL. Thus, if they both return NIL, we know that we
are editing a STATIC or LOCAL variable.
*/
if (memo := fieldblock(cfield)) = NIL .and. (memo := memvarblock(cfield)) = NIL
memo := cfield
else
memo := eval(memo) // retrieve the starting value from the code block
endif
memo := memoedit(memo, ntop + 1, nleft + 1, nbottom - 1, nright - 1, ;
.t., 'editfunc', , 3)
if lastkey() != K_ESC
do case

/* we edited a field */
case fieldblock(cfield) != NIL
if rlock()
eval( fieldblock(cfield) , memo)
unlock
else
err_msg("Could not lock record - edits not saved")
ret_val := .f.
endif

/* we edited a private or public variable */
case memvarblock(cfield) != NIL
eval( memvarblock(cfield) , memo)

/* we edited a local or static variable */
otherwise
cfield := memo
endcase
else
ret_val := .f.
endif
setcursor(oldcurs)
restscreen(ntop, nleft, nbottom, nright, oldscrn)
setcolor(oldcolor)
set(_SET_EXACT, oldexact)
return ret_val

* end function MemEdit()
*--------------------------------------------------------------------*


/*
EditFunc() -- alters "ABORT Y/N" msg if Esc is hit during
the Memoedit above (only if changes have been made)
Note that this function cannot be declared STATIC. This
is because MEMOEDIT() uses macro substitution to run an
attached UDF, and STATIC functions do not have entries
in the symbol table (and thus cannot be macro substituted).
*/
function EscFunc(stat, line, col)
local buffer
if lastkey() = K_ESC .and. stat = 2
buffer := savescreen(0, 60, 0, 75)
@ 0,60 say 'MEMO NOT UPDATED'
tone(440, 1)
tone(440, 1)
inkey(1)
restscreen(0, 60, 0, 75, buffer)
else
endif
return ME_DEFAULT

* end function EditFunc()
*--------------------------------------------------------------------*


/*
Demonstration of passing LOCAL variables to another function
via a code block. This example enables changing the value
of a LOCAL variable inside a hot key function via passing the
variable by reference.
*/

function cbvartest
local mvalue := space(7), oldaltv, x
memvar getlist
if ! file("lookup.dbf")
dbcreate("lookup", { { "LNAME", "C", 7, 0 } } )
use lookup
for x := 1 to 9
append blank
/* note use of unnamed array -- it works just fine this way */
replace lookup->lname with { "BOOTH", "DONNAY", "FORCIER", ;
"LIEF", "MAIER", "MEANS", "NEFF", "ROUTH", "YELLICK" }[x]
next
else
use lookup
endif
oldaltv := setkey( K_ALT_V, {| | View_Vals(@mvalue)} )
setcolor('+gr/b')
cls
@ 4, 28 say "Enter last name:" get mvalue
setcolor('+w/b')
@ 5, 23 say '(press Alt-V for available authors)'
read
quit
/*--------------------------------------------------------------*/
static function view_vals(v)
local browse, column, key, marker := recno(), ;
oldscrn := savescreen(8, 35, 20, 44, 2), ;
oldcolor := setcolor("+W/RB"), oldcursor := setcursor(0), ;
oldblock := setkey( K_ALT_V, NIL ) // turn off ALT-V
@ 8, 35, 20, 44 box B_SINGLE + chr(32)
browse := TBrowseDB(9, 36, 19, 43)
browse:headSep := "Í"
browse:colorSpec := '+W/RB, +W/N'
column := TBColumnNew( "Author", FieldBlock("lname") )
browse:addColumn(column)
go top
do while .t.
do while ! browse:stabilize() .and. (key := inkey()) = 0
enddo
if browse:stable
key := inkey(0)
endif
do case
case key == K_UP
browse:up()
case key == K_DOWN
browse:down()
case key == K_CTRL_PGUP
browse:goTop()
case key == K_CTRL_PGDN
browse:goBottom()
case key == K_PGUP .or. key == K_HOME
browse:pageUp()
case key == K_PGDN .or. key == K_END
browse:pageDown()
case key == K_ESC .or. key == K_ENTER
exit
endcase
enddo
if lastkey() != K_ESC
/*
because we passed the variable BY REFERENCE in the code block,
any changes we make here are being made to the actual variable,
and that is the key to this whole mess working the way it does!
*/
v := eval(fieldblock('lname'))
endif
go marker
restscreen(8, 35, 20, 44, oldscrn)
setcolor(oldcolor)
setcursor(oldcursor)
setkey(K_ALT_V, oldblock) // reset Alt-V for next time
return nil

* eof: cbtest.prg