Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : UDFS1.ZIP
Filename : ERIN.PRG

**
** ERIN.PRG version 1.0
**
** Written by Joel Hassell.
**
** Each function has been documented thoroughly as to its
** description in a header block which precedes the actual
** code. The inline documentation varies from poor to good.
**
** Some of the functions reference functions developed in
** the commercial package "Tom Rettig's Library". This package
** is available from:
**
** Tom Rettig Associates
** 9300 Wilshire Blvd, Suite 470
** Beverly Hills, CA 90212-3237
**
** (213) 272-3784
**
** This package is excellent and I highly recommend it to any
** Clipper (or dBASE) programmer.
**
** If you do not have Rettig's library, there is alternate code
** which has been commented that may be used to make the functions
** operational. To find these search for 'Rettig' in this file
** and read the comments on how to change the code.
**
** Some of the functions also reference assembly functions which
** I have written. I have included the object files of
** these assembly functions, they are: SOFF5.OBJ, PUTWIN.OBJ,
** VID_MOVE.OBJ and GETWIN.OBJ.
**
** Please use or modify these in any way which will help. I
** desire no compensation, this is NOT shareware. I would,
** however, like to receive credit for the code. Please do so
** by giving credit to my daughter, Erin Hassell, without whom
** I might go crazy.
**


** COUNTSTR - Counts the number of substrings in a source.
**
** format: cnt = countstr(sub, src)
**
** cnt (N) - Count of occurances of sub in src.
** sub (C) - Substring to count.
** src (C) - Source string.
**
** Examples: Output
**
** countstr("/","12/20/87") 2
** countstr(";","12/27/87") 0
**
function countstr
parameters cl_delim,cl_str
return srch(1,1,len(cl_str),cl_str,cl_delim,1)
**
** COUNTSTR - End of function.




** INSECRET - Input secret information.
**
** format: scrt = insecret(row, col, len)
**
** scrt (C) - Information input secretly.
** row (N) - Row to input from.
** col (N) - Column to input from.
** len (N) - Maximum length of input.
**
** Example:
**
** @ 24,1 say "Enter password."
** password = insecret(4,10,8)
**
** Notes: Returns chr(27) if is hit instead of .
** All letters are returned in uppercase.
**
function insecret
parameter rw,cl,max_len
private ret_str,x
ret_str = ""
do while .t.
@ rw,cl say replicate([þ],len(ret_str))+space(max_len-len(ret_str))
@ rw,cl+len(ret_str) say ""
x = inkey(0)
do case
case x = 13
return upper(ret_str)+space(max_len-len(ret_str))
case x = 27 .or. x = -9
return chr(27)
case x = 8 .or. x = 127
ret_str = substr(ret_str,1,len(ret_str)-1)
otherwise
if x > 31 .and. x < 127
ret_str = substr(ret_str+chr(x),1,max_len)
endif
endcase
enddo
return ""
**
** INSECRET - End of function.




** MAKEFILE - Create a database file according to array contents.
**
** format: makefile( arry, file, fcnt )
**
** arry (C) - The name of the array.
** file (C) - The name of the file.
** fcnt (N) - The number of fields in the file.
**
** Example:
** declare FLDS[3]
** FLDS[1] = "FIELD_1 C 10"
** FLDS[2] = "FIELD_2 N 12 6"
** FLDS[3] = "FIELD_3 L 1"
** makefile( "FLDS", "TEST", 3 ) && Builds TEST.DBF
**
** Notes: Each element of the array should have the following form:
**
** "NNNNNNNNNN TLLL D"
** |________| ||_| |
** field name___| | | |
** field type__________| | | Note: Types = C, N, D or L
** field length__________| |
** field decimal count______| NOTE: MUST!!! be zero or blank for type=C
**
function makefile
parameter M_array,file_name,field_cnt
private x,i
s = str(select(),2) && Get current select area.
select 0 && Select next free area.
create _E_r_i_n && Create temp file.
use _E_r_i_n
for i = 1 to field_cnt
x = &M_array.[i]
append blank
replace field_name with substr(x,1,10),;
field_type with substr(x,12,1),;
field_len with val(substr(x,13,3)),;
field_dec with val(substr(x,17,1))
next i
use
create &file_name from _E_r_i_n && Create the file.
erase _E_r_i_n.dbf && Erase the temp file.
use
select &s
return .T.
**
** MAKEFILE - End of function.




** MAKETIME - Try to decipher a time.
**
** format: good = maketime( odd [,low [,high]] )
**
** good (C) - Time in format -> "hh:mm AM" | "hh:mm PM"
** odd (C) - Time in some weird format.
** low (N) - Earliest valid time in minutes.
** high (N) - Latest valid time in minutes.
**
** Examples: Output
**
** maketime("12P") "12:00 PM"
** maketime("212",4*60) " 2:12 PM"
** maketime("0") "12:00 AM"
**
** Notes: If the function fails it returns an error message
** in the form of "E ", where = 01-04 and
** describes the error.
**
function maketime
parameter the_time,low,high
private i,j,hr,min,aop_f,dig,x

dig = [0123456789] && List of digits.

** Make sure that we have a high and a low.
**
if type([low]) = [U]
low = 0
endif
if type([high]) = [U]
high = 1439
endif

** Get time.
**
x = ltrim(trim(upper(the_time))) && Get rid of spaces.
aop_f = [A]$x .or. [P]$x && AM/PM flag

** Check for a colon, if yes then get hours.
**
if ":"$x
i = at(":",x)
hr = val(substr(x,1,i-1))
if hr < 0 .or. ((hr = 0 .or. hr > 12) .and. aop_f)
return "E01 Invalid time format."
endif
x = ltrim(substr(x,i+1))
else

** No colon, so try to figure out the hour.
**
if aop_f && 12-hour format.

hr = substr(x,1,1) && Get first digit.

if hr$[01] && If < 2, then maybe two digits.
j = substr(x,2,1) && Get second digit.
if ((hr=[0] .and. j$dig) .or.;
(hr=[1] .and. j$[012])) .and.;
len(x) != 3 && Guard against "212" -> " 9:02 PM"
hr = hr+j && Add second digit.
endif
endif

x = ltrim(substr(x,len(hr)+1)) && Strip off hours.
hr = val(hr) && Turn into a number.

if hr = 0 && Make sure hours != 0.
return "E02 Hour must be from 1 to 12."
endif

else && 24-hour format.

hr = substr(x,1,1) && Get first digit.

if hr$[012] && If < 3, then maybe two digits.
j = substr(x,2,1) && Get second digit.
if (hr$[01] .and. j$dig) .or.;
(hr=[2] .and. j$[0123])
hr = hr+j && Add second digit.
endif
endif

x = ltrim(substr(x,len(hr)+1)) && Strip off hours.
hr = val(hr) && Turn into a number.

endif
endif

** Figure out the number of minutes.
**
min = substr(x,1,1) && Get first digit.
if min$dig
if min$[012345] && If < 6, then maybe two digits.
j = substr(x,2,1) && Get second digit.
if j$dig && If a digit, then
min = min+j && Add second digit.
endif
endif

x = ltrim(substr(x,len(min)+1)) && Strip off minutes.
min = val(min) && Turn into a number.

else
min = 0 && Set minutes to 0.
endif


** Validate am/pm indicator.
**
if aop_f
i = substr(x,1,1) && Get first letter.
if ! i+"/"$[A/P/] && Check letter.
return "E01 Invalid time format."
endif

x = substr(x,2) && Strip off letter.
if empty(x) .or. x=[M]
hr = hr%12+if(i=[P],12,0) && Add in PM hours.
else
return "E01 Invalid time format."
endif
else
if ! empty(x) && Make sure there is no more.
return "E01 Invalid time format."
endif

** If no AM/PM but number is too low maybe they meant PM.
**
if hr*60+min < low .and. hr > 0 .and. hr < 13
hr = hr+12
endif
endif

** Check against low and high.
**
i = hr*60+min
if i < low
return "E03 Time too early."
endif
if i > high
return "E04 Time too late."
endif
return str(hr%12+if(hr%12=0,12,0),2)+":"+substr(str(100+min,3),2)+" "+if(hr>11,"PM","AM")
**
** MAKETIME - End of function.



** MINTOSTR - Convert minutes to a time string.
**
** format: time = mintostr( mins )
**
** time (C) - Time string.
** mins (N) - Number of minutes since midnight.
**
** Examples: Output
**
** mintostr(5) "12:05 AM"
** mintostr(120) " 2:00 AM"
**
function mintostr
parameter mins
private h
h = int(mins/60)
return str(h%12+if(h%12=0,12,0),2)+":"+substr(str(mins%60+100,3),2,2)+" "+if(h<12,"AM","PM")
**
** MINTOSTR - End of function.




** OPTION - Display a window to select an option from an array.
**
** format: slct = option(arry,tr,tc,br,bc,bcol,tcol,hcol[,ma])
**
** slct (N) - Array element number, -1 = and -2 = error.
** arry (C) - Name of array to display.
** tr (N) - Top right row.
** tc (N) - Top right column.
** br (N) - Bottom right row.
** bc (N) - Bottom right column.
** bcol (C) - Border color.
** tcol (C) - Text color.
** hcol (C) - Highlight color.
** ma (N) - Maximum array element.
**
** Example:
** declare my_array[3]
** my_array[1] = "Choice 1"
** my_array[2] = "Choice 2"
** my_array[3] = "Choice 3"
** choice = option("MY_ARRAY",4,10,8,21,"W+/B","GR+/B","B/W")
**
** Notes: The cursor keys, Home, End, PgUp, and PgDn all work as
** expected. The function takes care of scrolling too.
**
function option
parameter array,tr,tc,br,bc,bcol,tcol,hcol,ma
private cur_line,top_entry,max_lines,x,max_array,hld_win,ln

** Initialize some stuff.
cur_line = 0 && Set current line to top.
top_entry = 1 && Point to first element.
max_lines = br-tr-1
if type("ma") = [U]
max_array = len(&array.)
else
max_array = ma
endif

if max_array < max_lines && Resize window if needed.
br = tr+max_array+1
max_lines = max_array
endif

** Make sure the window will be large enough.
**
if max_lines = 0 .or. tr+1>=br .or. tc+2>=bc .or. br>24 .or. bc>79
return -2
endif

** Pull current text off of window and draw window.
**
hld_win = getwin(tr,tc,br,bc)
set color to &bcol
@ tr,tc,br,bc box [ÚÄ¿³ÙÄÀ³ ]
ln = bc-tc-3

** Display all options.
**
disp_print()

** Loop forever.
**
do while .t.
x = inkey(0) && Get user input.
do case
case x = 13 && - Select item.
putwin(hld_win)
return top_entry+cur_line

case x = 27 && - Abort.
putwin(hld_win)
return -1

case x = 5 && Up
if cur_line > 0
cur_line = cur_line - 1
set color to &tcol
@tr+2+cur_line,tc+2 say substr(&array.[top_entry+cur_line+1],1,ln)
set color to &hcol
@tr+1+cur_line,tc+2 say substr(&array.[top_entry+cur_line],1,ln)
else
if top_entry > 1

** If you have Rettig functions then do this:

set color to &tcol
@tr+1+cur_line,tc+2 say substr(&array.[top_entry+cur_line],1,ln)
top_entry = top_entry - 1
call scroll with tr+1,tc+2,br-1,bc-1,1,"D"
set color to &hcol
@tr+1+cur_line,tc+2 say substr(&array.[top_entry+cur_line],1,ln)

** Else
** top_entry = top_entry - 1
** disp_print()

endif
endif

case x = 24 && Down
if cur_line < max_lines - 1
cur_line = cur_line + 1
set color to &tcol
@tr+cur_line,tc+2 say substr(&array.[top_entry+cur_line-1],1,ln)
set color to &hcol
@tr+1+cur_line,tc+2 say substr(&array.[top_entry+cur_line],1,ln)
else

if top_entry < max_array - max_lines + 1

** If you have Rettig functions then do this:

set color to &tcol
@tr+1+cur_line,tc+2 say substr(&array.[top_entry+cur_line],1,ln)
top_entry = top_entry + 1
call scroll with tr+1,tc+2,br-1,bc-1,1,"U"
set color to &hcol
@tr+1+cur_line,tc+2 say substr(&array.[top_entry+cur_line],1,ln)

** Else
** top_entry = top_entry + 1
** disp_print()

endif
endif

case x = 1 && Home
cur_line = 0
top_entry = 1
disp_print()

case x = 6 && End
cur_line = max_lines - 1
top_entry = max_array - max_lines + 1
disp_print()

case x = 18 && PgUp
if top_entry = 1
if cur_line != 0
cur_line = 0
disp_print()
endif
else
top_entry = top_entry - max_lines
if top_entry < 1
top_entry = 1
cur_line = 0
endif
disp_print()
endif

case x = 3 && PgDn
if top_entry = max_array - max_lines + 1
if cur_line != max_lines - 1
cur_line = max_lines - 1
disp_print()
endif
else
top_entry = top_entry + max_lines
if top_entry > max_array - max_lines + 1
top_entry = max_array - max_lines + 1
cur_line = max_lines - 1
endif
disp_print()
endif
endcase
enddo

** Display option list - DISP_PRINT.
** Used in OPTION function only!

function disp_print
private eye
for eye = 0 to max_lines - 1
if cur_line = eye
set color to &hcol
else
set color to &tcol
endif
@tr+1+eye,tc+2 say substr( &array.[top_entry+eye], 1 , ln )
next
return .t.
**
** OPTION - End of function.




** PARSESTR - Parses out a specified element from a string.
**
** format: dest = parsestr(num, delm, src)
**
** dest (C) - Parsed element.
** num (N) - Delimited item number to be extracted.
** del (C) - Single character delimiter.
** src (C) - Source string.
**
** Examples: Output
**
** parsestr(1,"/","12/20/87") "12"
** parsestr(2,"/","12/20/87") "20"

** parsestr(5,"/","12/20/87") ""
**
function parsestr
parameters cl_num,cl_delim,cl_str
private cl_result,cl_pos,cl_cnt

** Insure that the string is surrounded by the delimiter.
**
cl_result = if( substr(cl_str,1,len(cl_delim)) != cl_delim,cl_delim,'') + cl_str
cl_result = cl_result + if( substr(cl_str,len(cl_str)-len(cl_delim)+1) != cl_delim,cl_delim,'')

** Parse.
cl_pos = 0
for cl_cnt = 1 to cl_num
cl_pos = if(cl_delim$substr(cl_result,cl_pos+1), at(cl_delim,substr(cl_result,cl_pos+1))+cl_pos+len(cl_delim), 0)
if cl_pos=0
cl_cnt = cl_num+1
endif
next
return if(cl_pos=0,'',substr(cl_result,cl_pos,at(cl_delim,substr(cl_result,cl_pos))-1))
**
** PARSESTR - End of function.




** QSORT - Sorts an array.
**
** format: qsort( strt, end, arry )
**
** strt (N) - First element to sort.
** end (N) - Last element to sort.
** arry (C) - Name of array to sort.
**
** Examples:
** qsort( 1, len(srt_array), "srt_array" ) - sorts all of srt_array
** qsort( 6, 20, "array1" ) - sorts elements 6-20 of array
**
** Notes: This is fairly fast, not as fast as Rettig's sort
** routine; it will, however, sort character arrays.
**
function qsort
parameter _m,_n,_k
private _i,_j,_ln,_g

** What can I say! It works.
**
if _m < _n
_ln = _n - _m + 1
_g = int(_ln/2)
do while _g > 0
_i = _g
do while _i < _ln
_j = _i-_g
do while _j>=0
if &_k.[_j+_m] > &_k.[_j+_m+_g]
_t = &_k.[_j+_m]
&_k.[_j+_m] = &_k.[_j+_m+_g]
&_k.[_j+_m+_g] = _t
_j = _j-_g
else
exit
endif
enddo
_i = _i+1
enddo
_g = int(_g/2)
enddo
endif
return .t.
**
** QSORT - End of function.




** SPACEFILL - Space fills a source string.
**
** format: dest = spacefill(src, len)
**
** dest (C) - Destination string.
** src (C) - Source string to be space filled.
** len (N) - Length of string after space fill.
**
** Examples: Output
**
** spacefill("ABC",5) "ABC "
** spacefill("ABC",1) "A"
**
** Note: This routine will truncate a string which is longer than len.
**
function spacefill
parameter cl_str,cl_ln
return substr(cl_str+space(cl_ln),1,cl_ln)
**
** SPACEFILL - End of function.




** STRTOMIN - Convert time string to minutes.
**
** format: mins = STRTOMIN( time )
**
** mins (N) - Number of minutes since midnight.
** time (C) - Time string.
**
** Example: Output
**
** strtomin("12:00 PM") 720
**
function strtomin
parameter s
return (val(substr(s,1,2))%12)*60+val(substr(s,4,2))+if(substr(s,7,1)="P",720,0)
**
** STRTOMIN - End of function.




** ZEROFILL - Fills a number with leading zeros.
**
** format: dest = zerofill(num, cnt)
**
** dest (C) - Destination string.
** num (N) - Number to be filled (must be an integer).
** cnt (N) - Width of number.
**
** Examples: Output
** zerofill(4,3) "003"
** zerofill(100,3) "100"
** zerofill(1234,2) "34"
**
function zerofill
parameter cl_n,cl_l
private eye
eye = replicate("0",cl_l)+ltrim(str(cl_n,cl_l))
return substr(eye,len(eye)-cl_l+1)
**
** ZEROFILL - End of function.