Appendix D

Function Library

The following is a all-purpose function library that is used by the 
DBUPlus utility program outlined in Appendix C. This object module may 
be used for applications other than the DBUPlus utility program.

GENFUNC.PRG

   1 : /* File:        GENFUNC.prg
   2 :    Notice:      Copyright(c) 1991-1994 Sirius Software Development, Inc.
   3 :                 All Rights Reserved
   4 :    Project:     The Plieades
   5 :
   6 : */
   7 : // Standard Clipper header information
   8 : #define CLIPPER
   9 :
  10 : #include "FILEIO.ch"
  11 : #include "ERROR.ch"
  12 : #include "DIRECTRY.ch"
  13 : #include "GETEXIT.ch"
  14 :
  15 : // Power Tools header file information
  16 : #include "PTColor.ch"
  17 : #include "PTValue.ch"
  18 : #include "PTFuncs.ch"
  19 : #include "PTVerbs.ch"
  20 : #include "PTInkey.ch"
  21 :
  22 : // Special header file for the Plieades stuff
  23 : #include "DBPMenu.ch"
  24 :
  25 : // And now for some file-wide static variables
  26 : memvar getlist
  27 :
  28 : static _TEMPGET
  29 : static _AT
  30 : static _RET
  31 :
  32 :
  33 : /* Function Errorbeep
  34 :    --------------------------------------
  35 :    Syntax:  Errorbeep()
  36 :    Example: if <error condition> ; Errorbeep() ; endif
  37 :    Returns: NIL
  38 :    Notes:   Sounds an error tone
  39 : */
  40 : function Errorbeep
  41 :   tone(50,.5)
  42 :   tone(50,.5)
  43 :   tone(50,.5)
  44 :   VOID
  45 :
  46 : /* Function YNmsg
  47 :    --------------------------------------
  48 :    Syntax:  YNmsg(<aParams>)
  49 :    Example: if YNmsg({clr_norm," Do you want to quit? "})
  50 :    Returns: .t. if user indicates YES, .f. if NO or ESC
  51 :    Notes:   aParams is a three element array.
  52 :
  53 :             Element 1:    A two element array: element 1,1 is the color
  54 :                           for the box, 1,2 is the attribute to use in
  55 :                           shadowing the box.
  56 :
  57 :             Element 2:    An array of text to display.  The first two
  58 :                           elements may be numeric, and if so, will be used
  59 :                           for row/col coordinates
  60 :             Element 3:    Optional starting prompt
  61 : */
  62 :
  63 : function YNmsg(aParams)
  64 :
  65 :   local cScrsave     // To restore after we are done
  66 :   local nNumpassed              as int      // Number of parameters passed
  67 :   local nGeneral                as int      // General worker
  68 :   local lNewrow                 as logical  // Whether we are passed a row to start on
  69 :   local lNewcol                 as logical  // Whether we are passed a col to start on
  70 :   local nMaxwidth               as int      // Max width of box
  71 :   local nCurstat := setcursor() as int      // Status of cursor
  72 :   local cClrold  := setcolor()  as char     // Current status of color
  73 :   local aText2disp              as array    // Array of text to display
  74 :   local nParmchar               as int      // Number of parameter that is element of message
  75 :   local nToprow                 as int      // Top row of display box
  76 :   local nTopcol                 as int      // Top left col of display box
  77 :   local nNumlines               as int      // Number of text lines in the message array
  78 :   local nUsrkey                 as int      // Keystroke pressed by user
  79 :   local cChrshad                as char     // Attribute byte for shadowing
  80 :   local nPromptcol              as int      // Column to prompt message on
  81 :   local cDevice := set( pDEVICE,"SCREEN" ) as char  // Current DEVICE setting
  82 :
  83 :   // Find out if they passed a color
  84 :   do case
  85 :   case len(aParams) == 1
  86 :     setcolor(ColorCentral("Message"))
  87 :     cChrshad := ColorCentral("Shadow")
  88 :     aText2disp := aParams[1]
  89 :     nUsrkey := 1
  90 :
  91 :   case len(aParams) == 2
  92 :     IF aParams[2] IS pARRAY
  93 :       // color combo in 1, text in 2
  94 :       setcolor(aParams[1,1])
  95 :       cChrshad := aParams[1,2]
  96 :       aText2disp := aParams[2]
  97 :       nUsrkey := 1
  98 :     else
  99 :       // Text in 1, prompt in 2
 100 :       setcolor(ColorCentral("Message"))
 101 :       cChrshad := ColorCentral("Shadow")
 102 :       aText2disp := aParams[1]
 103 :       nUsrkey := aParams[2]
 104 :     endif
 105 :
 106 :   otherwise  // all three passed
 107 :     setcolor(aParams[1,1])
 108 :     cChrshad := aParams[1,2]
 109 :     aText2disp := aParams[2]
 110 :     nUsrkey := aParams[3]
 111 :
 112 :   endcase
 113 :
 114 :   setcursor(pCURSOR_OFF)
 115 :   nNumpassed := len(aText2disp)
 116 :   lNewrow := !(valtype(aText2disp[1]) == "N")
 117 :   lNewcol := if(len(aText2disp)>1,!(valtype(aText2disp[2]) == "N"),pTRUE)
 118 :
 119 :   //  Handle situation where they passed row and/or col
 120 :   nParmchar := 1
 121 :   nParmchar += if(lNewrow, 0, 1)
 122 :   nParmchar += if(lNewcol, 0, 1)
 123 :   nNumlines := nNumpassed - (nParmchar-1)
 124 :
 125 :   // Find the max width - start with a number wide enough to accomodate
 126 :   // the YES/NO prompt
 127 :   nMaxwidth := 9
 128 :   nGeneral := nParmchar
 129 :   aeval(aText2disp, ;
 130 :         {|aEle| nMaxwidth := max(nMaxwidth,len(aEle)), nGeneral++},;
 131 :                 nGeneral,nNumpassed)
 132 :
 133 :   //  Determine the upper-left row and column
 134 :   if lNewrow
 135 :     nToprow := (maxrow() -nNumlines) /2
 136 :   else
 137 :     nToprow := aText2disp[1]
 138 :   endif
 139 :   if lNewcol
 140 :     nTopcol := (maxcol() -nMaxwidth) /2
 141 :   else
 142 :     nTopcol := aText2disp[2]
 143 :   endif
 144 :
 145 :   //  Save screen plus area for shadow.
 146 :   //  Then clear the area and draw a box with a shadow.
 147 :
 148 :   cScrsave := savescreen(nToprow -1, nTopcol -1, nToprow +nNumlines +4,;
 149 :               nTopcol +nMaxwidth +3)
 150 :
 151 :   dispbox(nToprow -1, nTopcol -1, ;
 152 :           nToprow +nNumlines+3, nTopcol +nMaxwidth+1, pSBAR)
 153 :
 154 :   // Shadow Bottom
 155 :   Newcolor(nToprow +nNumlines+4,nTopcol,nToprow +nNumlines+4,;
 156 :            nTopcol +nMaxwidth+1,cChrshad)
 157 :   // Shadow Side
 158 :   Newcolor(nToprow,nTopcol +nMaxwidth+2,nToprow +nNumlines+4,;
 159 :            nTopcol +nMaxwidth+2,cChrshad)
 160 :
 161 :   //  Display the text-lines and wait for a keystroke
 162 :   nGeneral := nParmchar
 163 :   aeval(aText2disp,{|cEle| devpos(nToprow + (nGeneral - nParmchar), nTopcol),;
 164 :                            devout(cEle),nGeneral++}, nParmchar, nNumpassed)
 165 :
 166 :   // now prompt the "YES    NO"
 167 :   nPromptcol := int((nMaxwidth - 9) / 2)
 168 :   @ nToprow + (nNumpassed - nParmchar)+1, nTopcol+ nPromptcol prompt "YES"
 169 :   @ nToprow + (nNumpassed - nParmchar)+1, nTopcol+ nPromptcol +7 prompt "NO"
 170 :   menu to nUsrkey
 171 :
 172 :   restscreen(nToprow -1, nTopcol -1, nToprow +nNumlines +4, nTopcol +nMaxwidth +3,cScrsave)
 173 :   setcursor(nCurstat)
 174 :   setcolor(cClrold)
 175 :   set( pDEVICE, cDevice )
 176 :
 177 :   return( nUsrkey == 1 )
 178 :
 179 : /* Function PressKeyMsg
 180 :    --------------------------------------
 181 :    Syntax:  PressKeyMsg(<aParams>)
 182 :    Example: PressKeyMsg(aMsgarray)
 183 :    Returns: Inkey() value of the key pressed to exit
 184 :    Notes:   aParams is an array.  If one element, it is the text to
 185 :             display.  If two, the first element is a color pair, the
 186 :             second an array of text to display.
 187 : */
 188 :
 189 : function PressKeyMsg(aParams)
 190 :
 191 :   local cScrsave   as char    // To restore after we are done
 192 :   local nNumpassed as int     // Number of parameters passed
 193 :   local nGeneral   as int     // General worker
 194 :   local lNewrow    as logical // Whether we are passed a row to start on
 195 :   local lNewcol    as logical // Whether we are passed a col to start on
 196 :   local lNewcolors as logical // Whether colors were passed
 197 :   local nMaxwidth  as int     // Max width of box
 198 :   local nCurstat   as int     // Status of cursor
 199 :   local cClrold    as char    // Current status of color
 200 :   local aText2disp as array   // Array of text to display
 201 :   local nParmchar  as int     // Number of parameter that is element of message
 202 :   local nToprow    as int     // Top row of display box
 203 :   local nTopcol    as int     // Top left col of display box
 204 :   local nNumlines  as int     // Number of text lines in the message array
 205 :   local nUsrkey    as int     // Keystroke pressed by user
 206 :   local cChrshad   as char    // Attribute byte for shadowing
 207 :   local cDevice    as char    // Set device setting
 208 :
 209 :   nCurstat := setcursor()
 210 :   cClrold  := setcolor()
 211 :   cDevice  := set(_SET_DEVICE,"SCREEN")
 212 :   // Find out if they passed a color
 213 :   if len(aParams) > 1
 214 :     setcolor(aParams[1,1])
 215 :     cChrshad := aParams[1,2]
 216 :     aText2disp := aParams[2]
 217 :   else
 218 :     setcolor(ColorCentral("Message"))
 219 :     cChrshad := ColorCentral("Shadow")
 220 :     aText2disp := aParams[1]
 221 :   endif
 222 :   setcursor(pCURSOR_OFF)
 223 :   nNumpassed := len(aText2disp)
 224 :   lNewrow := (valtype(aText2disp[1]) <> "N")
 225 :   lNewcol := if(len(aText2disp)>1,(valtype(aText2disp[2]) <> "N"),pTRUE)
 226 :
 227 :   //  Handle situation where they passed row and/or col
 228 :   nParmchar := 1
 229 :   nParmchar += if(lNewrow, 0, 1)
 230 :   nParmchar += if(lNewcol, 0, 1)
 231 :   nNumlines := nNumpassed - (nParmchar-1)
 232 :
 233 :   // Find the max length
 234 :   nMaxwidth := 0
 235 :   nGeneral := nParmchar
 236 :   aeval(aText2disp, ;
 237 :        <%-2>{|ele| nMaxwidth := max(nMaxwidth,len(ele)), nGeneral++},nGeneral,nNumpassed)<%0>
 238 :
 239 :   //  Determine the upper-left row and column
 240 :   if lNewrow
 241 :     nToprow := (maxrow() -nNumlines) /2
 242 :   else
 243 :     nToprow := aText2disp[1]
 244 :   endif
 245 :   if lNewcol
 246 :     nTopcol := (maxcol() -nMaxwidth) /2
 247 :   else
 248 :     nTopcol := aText2disp[2]
 249 :   endif
 250 :
 251 :   //  Save screen plus two char either direction for shadow.
 252 :   //  Then clear the area and draw a box with a shadow.
 253 :
 254 :   cScrsave := savescreen(nToprow -1, nTopcol -1, nToprow +nNumlines +2,;
 255 :                          nTopcol +nMaxwidth +3)
 256 :
 257 :   dispbox( nToprow -1, nTopcol -1, ;
 258 :            nToprow +nNumlines+1, nTopcol +nMaxwidth+1, pSBAR)
 259 :   // Shadow Bottom
 260 :   Newcolor(nToprow +nNumlines+2,nTopcol,nToprow +nNumlines+2,;
 261 :            nTopcol +nMaxwidth+1,cChrshad)
 262 :   // Shadow Side
 263 :   Newcolor(nToprow,nTopcol +nMaxwidth+2,nToprow +nNumlines+2,;
 264 :            nTopcol +nMaxwidth+2,cChrshad)
 265 :   //  Display the text-lines and wait for a keystroke
 266 :   nGeneral := nParmchar
 267 :   aeval(aText2disp,{|arr| devpos(nToprow + (nGeneral - nParmchar), nTopcol), ;
 268 :                           devout(aText2disp[nGeneral]), nGeneral++}, nGeneral, nNumpassed)
 269 :   @ nToprow +(nGeneral-nParmchar), nTopcol say "...any key"
 270 :   inkey(0)
 271 :   nUsrkey := lastkey()
 272 :
 273 :   restscreen(nToprow -1, nTopcol -1, nToprow +nNumlines +2,;
 274 :              nTopcol +nMaxwidth +3,cScrsave)
 275 :   setcursor(nCurstat)
 276 :   setcolor(cClrold)
 277 :   set(_SET_DEVICE,cDevice)
 278 :
 279 :   return(nUsrkey)
 280 :
 281 : /* Function Pickit
 282 :    --------------------------------------
 283 :    Syntax:  Pickit(<aParams>)
 284 :    Example: ans := Pickit({{"Choice 1, Choice 2, Choice 3}})
 285 :    Returns: Number element in choice array that the user picked
 286 :    Notes:
 287 :
 288 :             Element 1:    A two element array: element 1,1 is the color
 289 :                           for the box, 1,2 is the attribute to use in
 290 :                           shadowing the box.
 291 :
 292 :             Element 2:    An array of prompts to display.  The first two
 293 :                           elements may be numeric, and if so, will be used
 294 :                           for row/col coordinates
 295 : */
 296 :
 297 : function Pickit(aParams)
 298 :
 299 :   local cScrsave   as char     // To restore after we are done
 300 :   local nNumpassed as int      // Number of parameters passed
 301 :   local nGeneral   as int      // General worker
 302 :   local lNewrow    as logical  // Whether we are passed a row to start on
 303 :   local lNewcol    as logical  // Whether we are passed a col to start on
 304 :   local nMaxwidth  as int      // Max width of box
 305 :   local nCurstat   as int      // Status of cursor
 306 :   local cClrold    as char     // Current status of color
 307 :   local aText2menu as array    // Array of text to MENU ... TO
 308 :   local nParmchar  as int      // Number of parameter that is element of message
 309 :   local nToprow    as int      // Top row of display box
 310 :   local nTopcol    as int      // Top left col of display box
 311 :   local nNumlines  as int      // Number of text lines in the message array
 312 :   local nUsrkey    as int      // Keystroke pressed by user
 313 :   local cChrshad   as char     // Attribute byte for shadowing
 314 :
 315 :   nCurstat := setcursor()
 316 :   cClrold  := setcolor()
 317 :
 318 :   if len(aParams) > 1
 319 :     setcolor(aParams[1,1])
 320 :     cChrshad := aParams[1,2]
 321 :     aText2menu := aParams[2]
 322 :   else
 323 :     setcolor(ColorCentral("Message"))
 324 :     cChrshad := ColorCentral("Shadow")
 325 :     aText2menu := aParams[1]
 326 :   endif
 327 :
 328 :   setcursor(pCURSOR_OFF)
 329 :   nNumpassed := len(aText2menu)
 330 :   lNewrow := (valtype(aText2menu[1]) <> "N")
 331 :   lNewcol := if(len(aText2menu)>1,(valtype(aText2menu[2]) <> "N"),pTRUE)
 332 :
 333 :   //  Handle situation where they passed row and/or col
 334 :   nParmchar := 1
 335 :   nParmchar += if(lNewrow, 0, 1)
 336 :   nParmchar += if(lNewcol, 0, 1)
 337 :   nNumlines := nNumpassed - (nParmchar-1)
 338 :
 339 :   // Find the max width
 340 :   nMaxwidth := 30
 341 :   nGeneral := nParmchar
 342 :   aeval(aText2menu, {|ele| nMaxwidth := max(nMaxwidth,len(ele)), ;
 343 :                            nGeneral++},nGeneral,nNumpassed)
 344 :
 345 :   //  Determine the upperleft row and column
 346 :   if lNewrow
 347 :     nToprow := (maxrow() -nNumlines) /2
 348 :   else
 349 :     nToprow := aText2menu[1]
 350 :   endif
 351 :   if lNewcol
 352 :     nTopcol := (maxcol() -nMaxwidth) /2
 353 :   else
 354 :     nTopcol := aText2menu[2]
 355 :   endif
 356 :
 357 :   //  Save screen plus area for shadow.
 358 :   //  Then clear the area and draw a box with a shadow.
 359 :
 360 :   cScrsave := savescreen(nToprow -1, nTopcol -1,;
 361 :                          nToprow +nNumlines +3, nTopcol +nMaxwidth +3)
 362 :
 363 :   dispbox( nToprow -1, nTopcol -1, ;
 364 :            nToprow +nNumlines+1, nTopcol +nMaxwidth+1, pDBAR )
 365 :
 366 :   // Shadow Bottom
 367 :   Newcolor(nToprow +nNumlines+2,nTopcol,nToprow +nNumlines+2,;
 368 :            nTopcol +nMaxwidth+1,cChrshad)
 369 :   // Shadow Side
 370 :   Newcolor(nToprow,nTopcol +nMaxwidth+2,nToprow +nNumlines+2,;
 371 :            nTopcol +nMaxwidth+2,cChrshad)
 372 :   //  Display the text-lines and wait for a keystroke
 373 :   for nGeneral := nParmchar to nNumpassed
 374 :     @ nToprow + (nGeneral - nParmchar), nTopcol prompt aText2menu[nGeneral]
 375 :   next
 376 :   // now get the response
 377 :   <%-2>@ nToprow + (nGeneral - nParmchar)+1, nTopcol+1 say " Up/Down arrows, RETURN, ESC "<%0>
 378 :   menu to nUsrkey
 379 :   restscreen(nToprow -1, nTopcol -1, nToprow +nNumlines +2,;
 380 :              nTopcol +nMaxwidth +3,cScrsave)
 381 :   setcursor(nCurstat)
 382 :   setcolor(cClrold)
 383 :
 384 :   return(nUsrkey)
 385 :
 386 : /* Function ColorCentral
 387 :    --------------------------------------
 388 :    Module:  PLEIADES
 389 :    Syntax:  ColorCentral(<nMonitor|cColor>)
 390 :    Example: ColorCentral(pMONO)     // Initialize array for mono
 391 :             ColorCentral("Normal") // Get color for normal color
 392 :    Returns: NIL if numeric parameter is passed in pMONO or pCOLOR
 393 :             meaning a color array was set up.  Otherwise, returns
 394 :             the color string matched to the character key passed.
 395 :
 396 :    Notes:   This function handles keeping a global color array.  If a
 397 :             numeric is passed, it is compared to value of pCOLOR, and
 398 :             if it passes, color settings are used, else mono settings
 399 :             are used.  If a character string is passed, a match is
 400 :             attempted by looking in the array.  If found, the value
 401 :             is returned, else value of SETCOLOR() is returned.
 402 : */
 403 :
 404 : function ColorCentral(xParam)
 405 :
 406 :   static aColors   as array
 407 :   static nMonitor  as int
 408 :
 409 :   local  xRetval   as usual
 410 :
 411 :   if !(valtype(xParam) == "C") .or. ;
 412 :       (valtype(xParam) == "C" .and. valtype(aColors) == "U")
 413 :     // Either parameter is a number (initialize on monitor type),
 414 :     // or the user mistakenly asked for a value before dictionary
 415 :     // initialized
 416 :     IF xParam IS pCHARACTER
 417 :       nMonitor := if(iscolor(),pCOLOR_MONITOR,pMONO_MONITOR)
 418 :     else
 419 :       nMonitor := if(xParam == pCOLOR_MONITOR,pCOLOR_MONITOR,pMONO_MONITOR)
 420 :     endif
 421 :     aColors := DictNew()
 422 :     DictPut(aColors,"Normal", GetColor(nMonitor,pCLR_NORM))
 423 :     DictPut(aColors,"Menu",   GetColor(nMonitor,pCLR_MENU))
 424 :     DictPut(aColors,"Inverse",GetColor(nMonitor,pCLR_INV ))
 425 :     DictPut(aColors,"Shadow", GetColor(nMonitor,pCHR_SHAD))
 426 :     DictPut(aColors,"Message",GetColor(nMonitor,pCLR_MESSAGE))
 427 :     DictPut(aColors,"Blinking",GetColor(nMonitor,pCLR_BLINK))
 428 :     DictPut(aColors,"BlinkInv",GetColor(nMonitor,pCLR_BINV))
 429 :     DictPut(aColors,"Bold",GetColor(nMonitor,pCLR_HIGH))
 430 :
 431 :     IF xParam IS pCHARACTER  // Now that it is initialized, go ahead and get color
 432 :       xRetval := DictAt(aColors,xParam)
 433 :     endif
 434 :   else
 435 :     xRetval := DictAt(aColors,xParam)
 436 :   endif
 437 :
 438 :   return( xRetval )
 439 :
 440 : /* Function GetColor
 441 :    --------------------------------------
 442 :    Syntax:  GetColor(<nType>,<nOffset>)
 443 :    Notes:   Stores color combinations - Mono, then color
 444 : */
 445 :
 446 : function GetColor(nType,nOffset)
 447 :
 448 : static aColor_arr := { ;
 449 :                       { ;
 450 :                         chr(07),            ;  // pCHR_NORM
 451 :                         chr(15),            ;  // pCHR_HIGH
 452 :                         chr(87),            ;  // pCHR_BLINK
 453 :                         chr(112),           ;  // pCHR_INV
 454 :                         chr(240),           ;  // pCHR_BINV
 455 :                         "W  /N , N/W, N,,N",;  // pCLR_SHAD
 456 :                         "W+ /N , N/W, N,,N",;  // pCLR_DATA
 457 :                         "W  /N , N/W, N,,N",;  // pCLR_TEXT
 458 :                         "W+ /N , N/W, N,,N",;  // pCLR_CALC
 459 :                         "N  /W , W/N, N,,N",;  // pCLR_INFLD
 460 :                         "W/N",              ;  // pCLR_NOCHX
 461 :                         "N/W",              ;  // pHOT_CHX
 462 :                         chr(07),            ;  // pCHR_SHAD
 463 :                         chr(15),            ;  // pCHR_DATA
 464 :                         chr(07),            ;  // pCHR_TEXT
 465 :                         chr(78),            ;  // pCHR_INFLD
 466 :                         "W  /N , N/W, N,,W",;  // pCLR_NORM
 467 :                         "W+ /N , N/W, N,,W",;  // pCLR_HIGH
 468 :                         "W* /N , N/W, N,,", ;  // pCLR_BLINK
 469 :                         "N  /W , W/N, N,,N",;  // pCLR_INV
 470 :                         "N* /W , W/N, N,,N",;  // pCLR_BINV
 471 :                         "W  /N , N/W, N,,N",;  // pCLR_MENU
 472 :                         chr(7),             ;  // pCHR_MENU
 473 :                         "W+ /N , N/W, N,,N",;  // pCLR_MESSAGE
 474 :                       },;
 475 :                       { ;
 476 :                         chr(31),              ;  // pCHR_NORM
 477 :                         chr(30),              ;  // pCHR_HIGH
 478 :                         chr(207),             ;  // pCHR_BLINK
 479 :                         chr(15),              ;  // pCHR_INV
 480 :                         chr(244),             ;  // pCHR_BINV
 481 :                         "W  /N ",             ;  // pCLR_SHAD
 482 :                         "GR+/B ,W+/N, B,,W+", ;  // pCLR_DATA
 483 :                         "W+ /B , W+/N, B,,W+",;  // pCLR_TEXT
 484 :                         "W+ /N , N/W, N,,N",  ;  // pCLR_CALC
 485 :                         "W+ /N ,W+/B, B,,W+", ;  // pCLR_INFLD
 486 :                         "N/GB",               ;  // pCLR_NOCHX
 487 :                         "B/BG",               ;  // pHOT_CHX
 488 :                         chr(07),              ;  // pCHR_SHAD
 489 :                         chr(30),              ;  // pCHR_DATA
 490 :                         chr(31),              ;  // pCHR_TEXT
 491 :                         chr(15),              ;  // pCHR_INFLD
 492 :                         "W+ /B , W+/N, B,,W+",;  // pCLR_NORM
 493 :                         "GR+/B ,W+/N, B,,W+", ;  // pCLR_HIGH
 494 :                         "W+*/R ,W+/N, B,,W+", ;  // pCLR_BLINK
 495 :                         "N  /W ,W+/B, B,,W+", ;  // pCLR_INV
 496 :                         "R* /W ,W+/N, B,,W+", ;  // pCLR_BINV
 497 :                         "W+ /BG,W+/N,B,,W/N",;  // pCLR_MENU
 498 :                         chr(63),              ;  // pCHR_MENU
 499 :                         "W+ /RB,W+/N,B,,W/N",;  // pCLR_MESSAGE
 500 :                       } ;
 501 :                     }   as array
 502 :
 503 :   return(aColor_arr[nType,nOffset])
 504 :
 505 : /* Function ShowPath
 506 :    --------------------------------------
 507 :    Syntax:  ShowPath(<cDrive>,<cSearch>[,nWidth][,xRow][,nCol])
 508 :    Returns: NIL
 509 :    Notes:   Displays search path on screen
 510 : */
 511 :
 512 : function ShowPath(cDrive,;  // Drive letter
 513 :                   cSearch,; // Path
 514 :                   nWidth,;  // Width of display area.. default of 40
 515 :                   xRow,;    // Optional row position, if not numeric no disp
 516 :                   nCol)     // Optional column
 517 :
 518 :   local cTemp      as char
 519 :   local cRetval    as char
 520 :   local nLenofBoth as int
 521 :   local lDisplay   as logical
 522 :
 523 :   // Validify the parameters
 524 :   DEFAULT nWidth TO 40, ;
 525 :           lDisplay TO pTRUE
 526 :
 527 :   lDisplay := if(valtype(xRow)=="L",xRow,pTRUE)
 528 :   xRow     := if(valtype(xRow)=="N",xRow,0)
 529 :   nCol     := if(valtype(nCol)=="N",nCol,maxcol()-nWidth)
 530 :
 531 :   nLenofBoth := len(cDrive+cSearch)
 532 :   if nLenofBoth > nWidth
 533 :     // output modified path, using a string composed of the
 534 :     // drive and search, no longer than nWidth - 5.  Note that
 535 :     // the substr() uses 6 b/c of the format of final padr() display
 536 :     cTemp := substr( right(cDrive + cSearch,nWidth-5), 1, nWidth-6)
 537 :     // Get to point of starting "\"
 538 :     cTemp := substr(cTemp,at("\",cTemp))
 539 :     cRetval := padr(cDrive+"\..."+cTemp,nWidth)
 540 :   else
 541 :     // remove last "\"
 542 :     if right(cDrive+cSearch,1) == "\"
 543 :       cRetval := padr( substr(cDrive + cSearch,1,len(cDrive+cSearch)-1), ;
 544 :                        nWidth)
 545 :     else
 546 :       cRetval := cDrive + cSearch
 547 :     endif
 548 :     cRetval := padr(cRetval,nWidth)
 549 :   endif
 550 :   if lDisplay
 551 :     devpos(xRow,nCol)
 552 :     devout(cRetval)
 553 :   endif
 554 :
 555 :   return(cRetval)
 556 :
 557 : *******************
 558 :
 559 : function NewColor( nTop, nLeft, nBottom, nRight, cChar)
 560 :
 561 :   local cScreen := savescreen( nTop, nLeft, nBottom, nRight )
 562 :   local nLength := len( cScreen )
 563 :
 564 :   restscreen(nTop, nLeft, nBottom, nRight, ;
 565 :              transform( cScreen, replicate("X"+cChar, nLength/2) ) )
 566 :
 567 :   VOID
 568 :
 569 : ********************
 570 :
 571 : function LoggedDrive()
 572 :
 573 :   local nFileHandle    as int
 574 :   local lRetval := ""  as logical
 575 :
 576 :   run dir *.>tk50ld
 577 :
 578 :   nFileHandle := fopen("tk50ld")
 579 :
 580 :   if nFileHandle > 4
 581 :     fseek(nFileHandle, 19, 0 )
 582 :     lRetval := freadstr(nFileHandle, 1) + ":"
 583 :     fclose( nFileHandle )
 584 :     ferase("tk50ld")
 585 :   else
 586 :     // Internal error setting
 587 :   endif
 588 :
 589 :   return( lRetval )
 590 :
 591 : ********************
 592 :
 593 : function Prompt( aStructure )
 594 :
 595 :    // The structure of the array used by this function is an array with
 596 :    // four elements in it.  The first element is an array of keystroke
 597 :    // options in ASCII value format.  The second element is an array of
 598 :    // prompts that will be displayed with each prompt selected.  The
 599 :    // third element is an array of return values.  The final element
 600 :    // is the ENTER key must be pressed to complete the entry.
 601 :
 602 :   local nRow    := row()  as int
 603 :   local nColumn := col()  as int
 604 :   local nKey              as int
 605 :   local nCounter          as int
 606 :   local lRetval := pTRUE  as logical
 607 :
 608 :   IF aStructure IS NOT pARRAY
 609 :     aStructure := BuildDefault()
 610 :   else
 611 :     if !( len( aStructure ) == 4 )
 612 :       aStructure := BuildDefault()
 613 :     endif
 614 :   endif
 615 :
 616 :   while ( nKey := inkey(0), !( aStructure[4] .AND. nKey == pENTER ) )
 617 :
 618 :     if valtype( setkey( nKey ) ) == pBLOCK
 619 :       eval( setkey( nKey ) )
 620 :       loop
 621 :     endif
 622 :
 623 :     for nCounter := 1 to len( aStructure[1] )
 624 :       if nKey == aStructure[1][nCounter]
 625 :         exit
 626 :       endif
 627 :     next
 628 :
 629 :     if nCounter <= len( aStructure[1] )
 630 :       @ nRow, nColumn say aStructure[2, nCounter]
 631 :       lRetval := aStructure[3, nCounter]
 632 :       if !aStructure[4]
 633 :         exit
 634 :       endif
 635 :     endif
 636 :   enddo
 637 :
 638 :   return( lRetval )
 639 :
 640 : ********************
 641 :
 642 : static function BuildDefault()
 643 :
 644 :    local aArray := {} as array
 645 :
 646 :    aadd( aArray, { asc("Y"), asc("y"), asc("N"), asc("n")} )
 647 :    aadd( aArray, { "Yes","Yes","No ","No "} )
 648 :    aadd( aArray, { pTRUE, pTRUE, pFALSE, pFALSE} )
 649 :    aadd( aArray, pTRUE )
 650 :
 651 :    return( aArray )
 652 :
 653 : ********************
 654 :
 655 : function Parse( cMainString, cSubString, lLeft2Right, nIterations )
 656 :
 657 :   local nOffset   as int
 658 :   local cTempBack as char
 659 :   local nWidth    as int
 660 :   local nCounter  as int
 661 :
 662 :   /* cMainString    == the string to be parsed
 663 :      cSubString     == the character to parse by
 664 :      lLeft2Right    == a logical toggle to decide if the function is to parse from
 665 :                       right-to-left or from left-to-right (which is the default)
 666 :      nIterations   == a numeric parameter telling how many nIterationsations to be performed.
 667 :                       The default number is 1
 668 :   */
 669 :
 670 :   if valtype(cMainString) == pCHARACTER .or. ;
 671 :     valtype(cMainString) == pMEMO
 672 :
 673 :     DEFAULT cSubString  TO "", ;
 674 :             lLeft2Right TO pTRUE, ;
 675 :             nIterations TO 1
 676 :
 677 :     for nCounter := 1 to nIterations
 678 :       nOffset := if( lLeft2Right, at(cSubString, cMainString), ;
 679 :                                  rat(cSubString, cMainString) )
 680 :       nWidth    := len( cSubString )
 681 :       if lLeft2Right
 682 :         cTempBack   := if( !empty(nOffset), ;
 683 :                            substr(cMainString, 1, nOffset -1), cMainString)
 684 :         cMainString := if( !empty(nOffset), ;
 685 :                            substr(cMainString, nOffset+nWidth), "")
 686 :       else
 687 :         cTempBack   := if( !empty(nOffset), ;
 688 :                            substr( cMainString, nOffset+1 ), cMainString)
 689 :         cMainString := if( !empty(nOffset), ;
 690 :                            substr( cMainString, 1, nOffset-1), "")
 691 :       endif
 692 :     next
 693 :
 694 :   else
 695 :     cTempBack := ""
 696 :   endif
 697 :
 698 :   return( cTempBack )
 699 :
 700 : ********************
 701 :
 702 : function Dispmessage( cString, nRow, nCol, cColor )
 703 :
 704 :    static nDisprow   as int
 705 :    static nDispcol   as int
 706 :    static cDispcolor as char
 707 :    static cScreen    as char
 708 :
 709 :    local lRetval := pTRUE as logical
 710 :
 711 :    if nDisprow == NIL .or. nDispcol == NIL .or. cDispcolor == NIL
 712 :      // a startup condition!
 713 :      DEFAULT nRow   TO maxrow(), ;
 714 :              nCol   TO 0, ;
 715 :              cColor TO colorset(nRow,nCol)
 716 :
 717 :      nDisprow   := nRow
 718 :      nDispcol   := nCol
 719 :      cDispcolor := cColor
 720 :
 721 :    else       // not a startup!
 722 :      IF nRow IS pNUMERIC
 723 :        nDisprow := nRow
 724 :      endif
 725 :      IF nCol IS pNUMERIC
 726 :        nDispcol := nCol
 727 :      endif
 728 :      IF cColor IS pCHARACTER
 729 :        cDispcolor := cColor
 730 :      endif
 731 :    endif
 732 :
 733 :    if !( cString == NIL )
 734 :      scroll(nDisprow, nDispcol, nDisprow, maxcol())
 735 :      @ nDisprow, nDispcol say cString color cDispcolor
 736 :    else
 737 :      nDisprow   := nRow
 738 :      nDispcol   := nCol
 739 :      cDispcolor := cColor
 740 :    endif
 741 :
 742 :    return( lRetval )
 743 :
 744 : ********************
 745 :
 746 : function RootName( cName )
 747 :
 748 :   local cRetval := ""    as char
 749 :   local nPosition := 0   as int
 750 :
 751 :   IF cName IS pCHARACTER
 752 :     nPosition := rat("\", cName )   // remove all of the roots from the name
 753 :
 754 :     if nPosition != 0
 755 :       cName := substr(cName, nPosition + 1)
 756 :     endif
 757 :
 758 :     nPosition := at(".", cName)
 759 :
 760 :     if !( nPosition == 0 )
 761 :        cName := left(cName, nPosition - 1 )
 762 :     endif
 763 :     cRetval := cName
 764 :   endif
 765 :
 766 :   return( cRetval )
 767 :
 768 : ********************
 769 :
 770 : function NewAlias( cName )
 771 :
 772 :   local lRetval := pTRUE as logical
 773 :   local nCount  := 0     as int
 774 :
 775 :   while ( ++nCount != 250 .and. lRetval )
 776 :     lRetval := !( alias(nCount) == cName )
 777 :   enddo
 778 :
 779 :   return( lRetval )
 780 :
 781 : **********************
 782 :
 783 : function GetRecord( nValue, nStart, nEnd )
 784 :
 785 :   local aArray  := {}      as array
 786 :   local nSetrec := recno() as int
 787 :   local nCount             as int
 788 :
 789 :   if !empty( ALIAS() )
 790 :
 791 :     DEFAULT nValue TO recno(), ;
 792 :             nStart TO 1, ;
 793 :             nEnd   TO fcount()
 794 :
 795 :     dbgoto( nValue )
 796 :     for nCount := nStart to nEnd
 797 :       aadd( aArray, fieldget( nCount ) )
 798 :     next
 799 :     dbgoto( nSetrec )
 800 :
 801 :   endif
 802 :
 803 :   return( aArray )
 804 :
 805 : ********************
 806 :
 807 : function DosStru( cDrive, lVisible, lReset, bExport )
 808 :
 809 :   // Typically called with only 2 parameters.  The value of the dir is
 810 :   // remembered unless told to RESET.  If so, then the dir array is
 811 :   // re-created!   No parameters, the current rememberence of the array
 812 :   // is returned!  bExport is the code block that will be performed in
 813 :   // lieu of the general operation.  This allows the AddDir()
 814 :   // function to add an element to this static array!
 815 :
 816 :   static aDir                                         as array
 817 :
 818 :   local nChoice                                       as int
 819 :   local nCounter                                      as int
 820 :   local aLook                                         as array
 821 :   local cScreen     := savescreen()                   as char
 822 :   local lWithExport := (valtype( bExport ) == pBLOCK) as logical
 823 :   local nCurs       := setcursor()                    as int
 824 :   local nStart
 825 :
 826 :   DEFAULT cDrive  TO "", ;
 827 :          lVisible TO pFALSE, ;
 828 :          lReset   TO pFALSE
 829 :
 830 :   if (lReset .and. !lWithExport) .or. aDir == NIL
 831 :     aDir := {}
 832 :   endif
 833 :
 834 :   if !lReset
 835 :     if lWithExport
 836 :       if eval( bExport, aDir )
 837 :         aDir := asort( aDir )
 838 :       endif
 839 :     else
 840 :
 841 :       if empty( aDir )
 842 :
 843 :         setcursor(pCURSOR_OFF)
 844 :         aDir := {"\"}
 845 :         // get initial directories off of root
 846 :         aeval( directory(cDrive + "\*.*", "D"),;
 847 :                {|aEle| if( aEle[F_ATTR] == "D", ;
 848 :                 aadd(aDir, "\" + aEle[F_NAME] + "\"), "" )} )
 849 :
 850 :         nCounter := 1
 851 :
 852 :         devpos( maxrow(), 0 )
 853 :         // now get all directories underneath root.  All will have
 854 :         // two directory files that need to be deleted - '.', and '..'
 855 :         while ++nCounter <= len( aDir )
 856 :           if lVisible
 857 :             outstd(chr(13)+padr(aDir[nCounter], maxcol()) )
 858 :           endif
 859 :
 860 :           // Code duped here for speed form GetDirs()
 861 :           <%-2>if !empty( ( aLook  := directory(cDrive + aDir[nCounter] + "*.*", "D") ) )<%0>
 862 :             // add directories only, don't include the first two, as
 863 :             // they are "." and "..".  On some networks, these
 864 :             // files are not included, so check for them
 865 :             nStart := if(aLook[1,F_NAME] == "." .or. ;
 866 :                          aLook[1,F_NAME] == "..",3,1)
 867 :             aeval( aLook,{|aEle| if( aEle[F_ATTR] == "D",  ;
 868 :             aadd(aDir, aDir[nCounter] + aEle[F_NAME] + "\"), "" )},nStart)
 869 :           endif
 870 :
 871 :         enddo
 872 :
 873 :         asort(aDir)
 874 :
 875 :       endif
 876 :
 877 :     endif
 878 :
 879 :   endif
 880 :
 881 :   restscreen(,,,,cScreen)
 882 :   setcursor( nCurs )
 883 :   return( aDir )
 884 :
 885 : *******************
 886 :
 887 : static function Getdirs( cDrive, cPattern, lShow )
 888 :
 889 :   local aRetval := {}          as array
 890 :   local nCursor := setcursor() as int
 891 :
 892 :   setcursor(pCURSOR_OFF)
 893 :   if lShow
 894 :     aeval( directory(cDrive + cPattern + "*.*", "D"),;
 895 :            {|x| ;
 896 :                if(x[F_ATTR] == "D" .and. !("."==x[F_NAME] .or. ;
 897 :                                            ".."==x[F_NAME]),;
 898 :                    ( ;
 899 :                      outstd(chr(13)+padr(cPattern+x[F_NAME]+"\", maxcol())),;
 900 :                      aadd(aRetval, cPattern + x[F_NAME] + "\") ;
 901 :                    ),;
 902 :                    "" ;
 903 :                  ) ;
 904 :             } ;
 905 :           )
 906 :   else
 907 :     aeval( directory(cDrive + cPattern + "*.*", "D"),;
 908 :            {|x| if( x[F_ATTR] == "D" .and. ;
 909 :                     !("."==x[F_NAME] .or. ".."==x[F_NAME]),;
 910 :                   aadd(aRetval, cPattern + x[1] + "\"), "" )} )
 911 :   endif
 912 :   setcursor(nCursor)
 913 :
 914 :   return( aRetval )
 915 :
 916 : **********************
 917 :
 918 : function ValidDrPath( cDrive, cPath )
 919 :
 920 :   local nFhandle          as int
 921 :   local cFile             as char
 922 :   local lRetval := pFALSE as logical
 923 :
 924 :   DEFAULT cDrive TO "", ;
 925 :           cPath  TO "\", ;
 926 :           cFile  TO "DUMMY$$$.$$$"
 927 :
 928 :   nFhandle := fcreate( cFile )
 929 :
 930 :   if nFhandle > 4 .and. empty( ferror() )
 931 :     fclose( nFhandle )
 932 :     ferase( cFile )
 933 :     lRetval := pTRUE
 934 :   endif
 935 :
 936 :   return( lRetval )
 937 :
 938 : /* Function FileList
 939 :    --------------------------------------
 940 :    Syntax:  FileList([xVariable],[cPath],[aStru],[lTagging])
 941 :    Returns: File that the user picked.
 942 :    Notes:   Used to allow users to pick a file
 943 :
 944 :    The goal is to display a listbox of file names, and allow user to
 945 :    choose.
 946 :
 947 :    xVariable     File name they picked, including path, OR it could be
 948 :                  a code block.  If a block, then the file they pick is
 949 :                  passed to it and EVAL'd.
 950 :
 951 :    cPath         Path they want to use to see the file
 952 :
 953 :    aStru         Structure of the list box mechanism itself
 954 :                  The Array will have the construction of:
 955 :
 956 :                  aStru[1] := Array of 4 coordinates
 957 :                  aStru[2] := Window width
 958 :                  aStru[3] := Color
 959 :                  aStru[4] := File Specs
 960 :
 961 :
 962 :    lTagging      Whether to allow multiple tagging of files.
 963 :
 964 : */
 965 :
 966 : function FileList( xVariable, cPath, aStru, lTagging)
 967 :
 968 :   local cFileSpec                 as char
 969 :   local cScreen                   as char
 970 :   local cOldColor := setcolor()   as char
 971 :   local nCursor    := setcursor() as int
 972 :   local aTheFiles                 as array
 973 :   local oObject                   as object
 974 :   local oColumn                   as object
 975 :   local nPointer   := 1           as int
 976 :   local nTheKey                   as int
 977 :   local cSelection := ""          as char
 978 :   local xRetval    := pTRUE       as logical
 979 :   local cString    := ""          as char
 980 :   local cKey                      as char
 981 :   local nPos                      as int
 982 :   local nSkipval                  as int
 983 :
 984 :   #define pCOORD    1
 985 :   #define pWIDTH    2
 986 :   #define pBOXCOLOR 3
 987 :   #define pSKELETON 4
 988 :   #define pTAGGED   6
 989 :
 990 :   DEFAULT lTagging TO pFALSE, ;
 991 :           cPath    TO "\"+curdir()+"\"
 992 :
 993 :   cPath := if( len(cPath) < 1, "\"+curdir()+"\", cPath )
 994 :
 995 :   IF aStru IS NOT pARRAY
 996 :     cFileSpec := if( (valtype( aStru ) == pCHARACTER), aStru, "*.*" )
 997 :     aStru    := {}
 998 :     aadd(aStru, {5,40,20,76})
 999 :     aadd(aStru, 35)
1000 :     aadd(aStru, setcolor() )
1001 :     aadd(aStru, cFileSpec)
1002 :   endif
1003 :
1004 :   cScreen := savescreen( aStru[pCOORD,1], aStru[pCOORD,2], ;
1005 :                          aStru[pCOORD,3], aStru[pCOORD,4] )
1006 :
1007 :   setcolor( aStru[pBOXCOLOR] )
1008 :   setcursor( pCURSOR_UPPER )
1009 :   dispbox(aStru[pCOORD,1], aStru[pCOORD,2], aStru[pCOORD,3], ;
1010 :                                             aStru[pCOORD,4], pDBAR)
1011 :
1012 :   if len( aTheFiles := directory(cPath + aStru[pSKELETON]) ) > 0
1013 :     if lTagging
1014 :        aeval( aTheFiles, {|x| aadd(x, chr(32))} )
1015 :     endif
1016 :
1017 :     oObject         := TBROWSENEW(aStru[pCOORD,1]+1, aStru[pCOORD,2]+1,;
1018 :                                   aStru[pCOORD,3]-1, aStru[pCOORD,4]-1)
1019 :     oObject:skipblock     := {|n| nSkipval := ;
1020 :                                   ArraySkip(n, nPointer, len(aTheFiles)), ;
1021 :                                                nPointer += nSkipval, nSkipval }
1022 :     oObject:goTopBlock    := {|| nPointer := 1}
1023 :     oObject:goBottomBlock := {|| nPointer := len( aTheFiles )}
1024 :     oObject:headSep       := chr(205)
1025 :     if lTagging
1026 :       oColumn       := tbcolumnnew( chr(16), {|| aTheFiles[nPointer,pTAGGED]} )
1027 :       oColumn:width := 2
1028 :       oObject:addColumn( oColumn )
1029 :     endif
1030 :
1031 :     oColumn         := tbcolumnnew("Files in;"+cPath, ;
1032 :                                    {|| aTheFiles[nPointer,F_NAME]})
1033 :     oColumn:width    := aStru[pWIDTH] - if( lTagging, 7, 0 )
1034 :     oObject:addColumn( oColumn )
1035 :
1036 :     if lTagging
1037 :       oObject:colPos := 2
1038 :     endif
1039 :
1040 :     PROCESS
1041 :
1042 :       if IsStable( oObject )
1043 :         do case
1044 :         case oObject:hittop
1045 :            oObject:GoBottom()
1046 :            IsStable( oObject )
1047 :         case oObject:hitbottom
1048 :            oObject:GoTop()
1049 :            IsStable( oObject )
1050 :         endcase
1051 :
1052 :         @ aStru[1,3], aStru[1,2]+1 say ;
1053 :           padr(cString, (aStru[1,4]-aStru[1,2]-3), chr(205))
1054 :         devpos( aStru[1,3], aStru[1,2]+1 + len(cString) )
1055 :
1056 :         cKey := chr(nTheKey  := inkey(0))
1057 :
1058 :         do case
1059 :         case ( nTheKey == pDOWN_ARROW )
1060 :           oObject:down()
1061 :
1062 :         case ( nTheKey == pUP_ARROW )
1063 :           oObject:up()
1064 :
1065 :         case ( nTheKey == pEND )
1066 :           oObject:gobottom()
1067 :
1068 :         case ( nTheKey == pPGUP )
1069 :           oObject:pageUp()
1070 :
1071 :         case ( nTheKey == pPGDN )
1072 :           oObject:pageDown()
1073 :
1074 :         case ( nTheKey == pHOME )
1075 :           oObject:gotop()
1076 :
1077 :         case ( nTheKey == pENTER )
1078 :           if lTagging
1079 :             aTheFiles[nPointer,pTAGGED] := ;
1080 :             if( aTheFiles[nPointer,pTAGGED] == chr(16), chr(32), chr(16) )
1081 :             oObject:refreshcurrent()
1082 :             oObject:down()
1083 :           else
1084 :             cSelection := cPath + aTheFiles[nPointer,F_NAME]
1085 :             exit
1086 :           endif
1087 :
1088 :         case ( nTheKey == pBKSP )
1089 :           if !empty(cString)
1090 :             cString := left( cString, len(cString)-1 )
1091 :             nPos := ascan(aTheFiles, {|x| upper(x[F_NAME]) == upper(cString)} )
1092 :             if !empty( nPos )
1093 :               nPointer := nPos
1094 :               oObject:refreshall()
1095 :             endif
1096 :           endif
1097 :
1098 :         case ( nTheKey == pESC )
1099 :           exit
1100 :
1101 :         otherwise
1102 :           if lTagging
1103 :             if nTheKey == pF10
1104 :               exit
1105 :             endif
1106 :           else
1107 :
1108 :             if nTheKey > 31 .and. nTheKey < 128
1109 :               cString += cKey
1110 :               if !empty(cString)
1111 :                 nPos := ascan(aTheFiles,{|x| upper(x[F_NAME]) == ;
1112 :                                              upper(cString)})
1113 :                 if !empty(  nPos )
1114 :                   nPointer := nPos
1115 :                   oObject:refreshall()
1116 :                 endif
1117 :               endif
1118 :
1119 :             endif
1120 :           endif
1121 :
1122 :         endcase
1123 :
1124 :       endif
1125 :
1126 :     END PROCESS
1127 :
1128 :   endif
1129 :
1130 :   if !lTagging
1131 :     if !empty( cSelection )
1132 :       if valtype( xVariable ) == pBLOCK  // In case the element was passed by a
                                                   code block
1133 :         eval(xVariable, cSelection)
1134 :       else                 // In case the element was passed by reference
1135 :         xVariable := cSelection
1136 :       endif
1137 :
1138 :     endif
1139 :
1140 :   else
1141 :     xRetval := {}
1142 :     if !( lastkey() == pESC )
1143 :       aeval(aTheFiles, {|x| if( (x[pTAGGED] == chr(16)),;
1144 :       <%-2>aadd(xRetval, {x[F_NAME], x[F_SIZE], x[F_DATE], x[F_TIME], x[F_ATTR]}), "" )} )<%0>
1145 :     endif
1146 :
1147 :   endif
1148 :
1149 :   restscreen( aStru[pCOORD,1], aStru[pCOORD,2], aStru[pCOORD,3], ;
1150 :                                                 aStru[pCOORD,4], cScreen )
1151 :   setcolor( cOldcolor )
1152 :   setcursor( nCursor )
1153 :
1154 :   #undef pCOORD
1155 :   #undef pWIDTH
1156 :   #undef pBOXCOLOR
1157 :   #undef pSKELETON
1158 :   #undef pTAGGED
1159 :
1160 :   return( xRetval )
1161 :
1162 : *******************
1163 :
1164 : function IsStable( oP, lForce )
1165 :
1166 :   local nThekey := 0 as int
1167 :
1168 :   lForce := if(pcount() < 2, pFALSE, lForce)
1169 :
1170 :   if !lForce
1171 :
1172 :     while ( !oP:stabilize() )
1173 :       nThekey := inkey()
1174 :       if !empty( nThekey )
1175 :         exit
1176 :       endif
1177 :     enddo
1178 :
1179 :   else
1180 :
1181 :     while ( !oP:stabilize() )
1182 :     enddo
1183 :
1184 :   endif
1185 :
1186 :   return( empty( nThekey ) .and. oP:stable )
1187 :
1188 : *******************
1189 :
1190 : function DirList(aDrive, lRebuild, lShowit)
1191 :
1192 :   local cScreen                    as char
1193 :   local cColor := setcolor()       as char
1194 :   local nPointer := 1              as int
1195 :   local oObject                    as object
1196 :   local oColumn                    as object
1197 :   local nTheKey                    as int
1198 :   local cSelection := ""           as char
1199 :   local cTemp                      as char
1200 :   local cString := ""              as char
1201 :   local cKey                       as char
1202 :   local nCursor := setcursor()     as int
1203 :   local aDirs                      as array
1204 :   local nPos                       as int
1205 :   local nSkipval                   as int
1206 :   local bDispblock                 as block
1207 :   local nOccur                     as int
1208 :   local cTempName                  as char
1209 :
1210 :   IF aDrive IS NOT pARRAY
1211 :     cTemp := if( valtype( aDrive ) == pCHARACTER, aDrive, "" )
1212 :     aDrive := {}
1213 :     aadd(aDrive, {5,40,20,76} )
1214 :     aadd(aDrive, 35)
1215 :     aadd(aDrive, setcolor() )
1216 :     aadd(aDrive, cTemp)
1217 :   endif
1218 :
1219 :   cScreen := savescreen( aDrive[1,1], aDrive[1,2], aDrive[1,3], aDrive[1,4] )
1220 :
1221 :   DEFAULT lRebuild TO pFALSE, ;
1222 :           lShowit  TO pFALSE
1223 :
1224 :   setcolor( aDrive[3] )
1225 :   dispbox(aDrive[1,1], aDrive[1,2], aDrive[1,3], aDrive[1,4], pDBAR)
1226 :
1227 :   @ aDrive[1,1]+1, aDrive[1,2]+1 say left("One Moment...", aDrive[2])
1228 :   @ aDrive[1,1]+2, aDrive[1,2]+3 say left("building directory...", aDrive[2])
1229 :   if lRebuild
1230 :     // b/c DirList can be written in with a FALSE for rebuild, but if
1231 :     // it is the first time, should be rebuilt anyway
1232 :      DosStru(,lShowit,pTRUE)
1233 :   endif
1234 :   aDirs := DosStru(aDrive[4],lShowit)
1235 :
1236 :   oObject         := tbrowsenew(aDrive[1,1]+1, aDrive[1,2]+1, ;
1237 :                                 aDrive[1,3]-1, aDrive[1,4]-1)
1238 :   oObject:skipblock     := {|n| nSkipval := ArraySkip(n, nPointer, ;
1239 :                                 len(aDirs)), nPointer += nSkipval, nSkipval }
1240 :   oObject:goTopBlock    := {|| nPointer := 1}
1241 :   oObject:goBottomBlock := {|| nPointer := len( aDirs )}
1242 :   oObject:headSep       := chr(205)
1243 :
1244 :   bDispblock := {|| if(npointer == 1,aDirs[nPointer],;
1245 :                         (nOccur := OCCURRENCE("\",aDirs[nPointer] )-1,;
1246 :                          cTempName := substr(aDirs[nPointer],1,;
1247 :                                     len(aDirs[nPointer])-1),;
1248 :                          space(nOccur*2)+substr(cTempName,;
1249 :                                          rat("\",cTempName)+1)))}
1250 :
1251 :   oColumn := tbcolumnnew( "Drive: "+aDrive[4], bDispblock )
1252 :   oColumn:width    := aDrive[2]
1253 :   oObject:addColumn( oColumn )
1254 :   setcursor( pCURSOR_UPPER )
1255 :
1256 :   REPEAT
1257 :
1258 :     if IsStable( oObject )
1259 :       do case
1260 :       case oObject:hittop
1261 :         oObject:GoBottom()
1262 :         IsStable( oObject )
1263 :       case oObject:hitbottom
1264 :         oObject:GoTop()
1265 :         IsStable( oObject )
1266 :       endcase
1267 :
1268 :       @ aDrive[1,3], aDrive[1,2]+1 say ;
1269 :                      padr(cString, (aDrive[1,4] - aDrive[1,2]-3), chr(205))
1270 :       devpos( aDrive[1,3], aDrive[1,2]+1 + len(cString) )
1271 :
1272 :       cKey := chr(nTheKey := inkey(0))
1273 :
1274 :       if !O_DefaultKeys( nTheKey, oObject )  // The keystroke pressed is NOT
                                                       default set
1275 :         do case
1276 :         case ( nTheKey == pBKSP )
1277 :           if !empty(cString)
1278 :              cString := left( cString, len(cString)-1 )
1279 :              nPos := ascan(aDirs, {|x| upper(x) == upper(cString)} )
1280 :              if !empty( nPos )
1281 :                 nPointer := nPos
1282 :                 oObject:refreshall()
1283 :              endif
1284 :           endif
1285 :
1286 :         case ( nTheKey == pENTER )
1287 :           cSelection := aDrive[4] + aDirs[nPointer]
1288 :           exit
1289 :
1290 :         otherwise
1291 :           if nTheKey > 31 .and. nTheKey < 128
1292 :
1293 :             cString += cKey
1294 :
1295 :             if !empty(cString)
1296 :
1297 :               nPos := ascan(aDirs, {|x| upper(x) == upper(cString)} )
1298 :               if !empty( nPos )
1299 :                 nPointer := nPos
1300 :                 oObject:refreshall()
1301 :               endif
1302 :
1303 :             endif
1304 :           endif
1305 :
1306 :         endcase
1307 :
1308 :       endif
1309 :
1310 :     endif
1311 :
1312 :   UNTIL ( lastkey() == pESC )
1313 :
1314 :   restscreen( aDrive[1,1], aDrive[1,2], aDrive[1,3], aDrive[1,4], cScreen )
1315 :   setcolor( cColor )
1316 :   setcursor( nCursor )
1317 :
1318 :   return( cSelection )
1319 :
1320 : ********************
1321 :
1322 : function ErrorMessage( cString, nRow, nCol, cColor )
1323 :
1324 :   static nErrorRow    as int
1325 :   static nErrorCol    as int
1326 :   static cErrorColor  as char
1327 :
1328 :   local lRetval := pTRUE as logical
1329 :   local cScreen          as char
1330 :
1331 :   if nErrorRow == NIL .or. nErrorCol == NIL .or. cErrorColor == NIL
1332 :      // A startup condition!
1333 :      DEFAULT nRow TO maxrow(), ;
1334 :              nCol TO 0, ;
1335 :              cCOlor TO ColorSet(nRow,nCol)
1336 :
1337 :      nErrorRow   := nRow
1338 :      nErrorCol   := nCol
1339 :      cErrorColor := cColor
1340 :
1341 :   else
1342 :      // Not a startup!
1343 :      if valtype( nRow ) == pNUMERIC
1344 :         nErrorRow := nRow
1345 :      endif
1346 :      if valtype( nCol ) == pNUMERIC
1347 :         nErrorCol := nCol
1348 :      endif
1349 :      if valtype( cColor ) == pCHARACTER
1350 :         cErrorColor := cColor
1351 :      endif
1352 :
1353 :   endif
1354 :
1355 :   if !(cString == NIL)
1356 :     cScreen := savescreen(nErrorRow, nErrorCol, nErrorRow, maxcol() )
1357 :     scroll(nErrorRow, nErrorCol, nErrorRow, maxcol())
1358 :     ErrorTone()
1359 :     @ nErrorRow, nErrorCol say cString
1360 :     inkey(3)
1361 :     restscreen(nErrorRow, nErrorCol, nErrorRow, maxcol(), cScreen )
1362 :   endif
1363 :
1364 :   return( lRetval )
1365 :
1366 : ********************
1367 :
1368 : procedure ErrorTone( aArray )
1369 :
1370 :   IF aArray IS NOT pARRAY
1371 :     aArray := {}
1372 :     aadd( aArray, {264.80, 4} )
1373 :     aadd( aArray, {230, 1} )
1374 :   endif
1375 :
1376 :   aeval( aArray, {|x| tone(x[1], x[2])} )
1377 :
1378 : *********************
1379 :
1380 : function PutRecord( nValue, nStart, nEnd, array )
1381 :
1382 :   local nSetrec := recno() as int
1383 :   local nCount             as int
1384 :   local nCounter := 1      as int
1385 :   local lSuccess := pTRUE  as logical
1386 :
1387 :   if !empty( alias() )
1388 :     DEFAULT nValue TO recno(), ;
1389 :             nStart TO 1, ;
1390 :             nEnd   TO fcount()
1391 :
1392 :     dbgoto( nValue )
1393 :     for nCount := nStart to nEnd
1394 :       if !(lSuccess := !(fieldput( nCount, array[nCounter] ) != ;
1395 :                                    array[nCounter++]))
1396 :         exit
1397 :       endif
1398 :     next
1399 :     dbgoto( nSetrec )
1400 :
1401 :   endif
1402 :
1403 :   return( lSuccess )
1404 :
1405 : *********************
1406 :
1407 : function O_DefaultKeys( nThekey, oObject )
1408 :
1409 :   local lRetval := pTRUE as logical
1410 :
1411 :   do case
1412 :   case ( nThekey == pDOWN_ARROW )
1413 :     oObject:down()
1414 :
1415 :   case ( nThekey == pUP_ARROW )
1416 :     oObject:up()
1417 :
1418 :   case ( nThekey == pEND )
1419 :     oObject:gobottom()
1420 :
1421 :   case ( nThekey == pPGUP )
1422 :     oObject:pageUp()
1423 :
1424 :   case ( nThekey == pPGDN )
1425 :     oObject:pageDown()
1426 :
1427 :   case ( nThekey == pHOME )
1428 :     oObject:gotop()
1429 :
1430 :   otherwise
1431 :     lRetval := pFALSE
1432 :
1433 :   endcase
1434 :
1435 :   return( lRetval )
1436 :
1437 : ********************
1438 :
1439 : function ColorSet( nRow, nCol )
1440 :
1441 :   local nVal1                 as int
1442 :   local nVal2                 as int
1443 :   local cRetval := setcolor() as char
1444 :   local cAttribute            as char
1445 :
1446 :   DEFAULT nRow TO row(), ;
1447 :           nCol TO col()
1448 :
1449 :   cAttribute := asc(substr(savescreen(nRow, nCol, nRow, nCol), 2, 1))
1450 :
1451 :   nVal1 := val(transform( cAttribute % 16, "99"))
1452 :   nVal2 := val(transform( cAttribute / 16 , "99"))
1453 :
1454 :   if nVal1 > 7
1455 :     cRetval := ltrim(trim(transform(nVal1 - 8, "99"))) + ;
1456 :                 "+/" + ltrim(trim(transform(nVal2 - 1, "99"))) + ", " + ;
1457 :                 ltrim(trim(transform(nVal2 - 1, "99"))) + "/" + ;
1458 :                 ltrim(trim(transform(nval1 - 8, "99")))
1459 :   else
1460 :     cRetval := ltrim(trim(transform(nVal1, "99"))) + "/" + ;
1461 :                ltrim(trim(transform(nVal2, "99"))) + ", " + ;
1462 :                ltrim(trim(transform(nVal2, "99"))) + "/" + ;
1463 :                ltrim(trim(transform(nval1, "99")))
1464 :   endif
1465 :
1466 :   return( cRetval )
1467 :
1468 : *******************
1469 :
1470 : function IndexActive( cName )
1471 :
1472 :   // first get the file name of the index file, open it up and look
1473 :   // for the first 250 characters beginning at byte 22
1474 :   // then search all of the orders and see if it matches.  If so,
1475 :   // return a true; otherwise, a false.
1476 :
1477 :   local lRetval := pFALSE as logical
1478 :   local nFhandle          as int
1479 :   local cBuffer           as char
1480 :   local nCount            as int
1481 :
1482 :   IF cName IS pCHARACTER
1483 :     nFhandle := fopen( alltrim(cName) )
1484 :     if nFhandle > 4                     // we have a file
1485 :       fseek( nFhandle, 22, 0 )
1486 :       cBuffer := upper( alltrim( freadstr(nFhandle, 250) ) )
1487 :       fclose( nFhandle )
1488 :       for nCount := 1 to 15
1489 :         if upper( indexkey(nCount) ) == cBuffer
1490 :           lRetval := pTRUE
1491 :           exit
1492 :         endif
1493 :       next
1494 :     endif
1495 :   endif
1496 :
1497 :   return( lRetval )
1498 :
1499 : ********************
1500 :
1501 : function ArraySkip( nRequest, nPointer, nLength )
1502 :
1503 :   local nCount
1504 :
1505 :   nCount := if( abs(nRequest) >= if(nRequest >= 0, ;
1506 :                 nLength-nPointer, nPointer-1 ), ;
1507 :                 if(nRequest >= 0, nLength-nPointer, 1-nPointer), nRequest )
1508 :
1509 :   nPointer += nCount
1510 :
1511 :   return( nCount )
1512 :
1513 : ********************
1514 :
1515 : function Modulus( nNumber1, nNumber2 )
1516 :
1517 :   local nRetval as int
1518 :   local nTemp   as int
1519 :
1520 :   DEFAULT nNumber1 TO 0, ;
1521 :           nNumber2 TO 0
1522 :
1523 :   if nNumber2 == 0
1524 :     nRetval := nNumber1
1525 :   else
1526 :     nTemp := nNumber1 % nNumber2
1527 :     nRetval := if( nNumber2 == 0, nNumber1, ;
1528 :                    if(nTemp * nNumber2 < 0, nTemp + nNumber2, nTemp) )
1529 :   endif
1530 :
1531 :   return( nRetval )
1532 :
1533 : *********************
1534 :
1535 : function CopyFIle( cSource, cDestination, lOverRight )
1536 :
1537 :    local lRetval := pFALSE  as logical
1538 :
1539 :    DEFAULT lOverRight TO pFALSE
1540 :
1541 :    IF cSource IS pCHARACTER
1542 :      if file( cSource )  // The file is there
1543 :        if cDestination IS pCHARACTER
1544 :          if ( lOverRight .and. file( cDestination ) ) .or. ;
1545 :               !file( cDestination )
1546 :            COPYFILE( cSource, cDestination )
1547 :            if file( cDestination )  // The file is at least there
1548 :              lRetval := (FileSize( cSource ) == FileSize( cDestination))
1549 :            endif
1550 :          endif
1551 :        endif
1552 :      endif
1553 :    endif
1554 :
1555 :    return( lRetval )
1556 :
1557 : *********************
1558 :
1559 : function FileSize( cFileName )
1560 :
1561 :   local nFileHandle     as int
1562 :   local nRetval := 0    as int
1563 :
1564 :   if cFileName IS pCHARACTER
1565 :     if (nFileHandle := fopen( cFileName )) > 4
1566 :       nRetval := fseek(nFileHandle, 0, 2)
1567 :       fclose( nFileHandle )
1568 :     endif
1569 :   endif
1570 :
1571 :   return( nRetval )
1572 :
1573 : *************************
1574 :
1575 : function AList( xVariable, aArray, aStru, lTagging, lRettoggle )
1576 :
1577 :     //  The goal is to replace ACHOICE with this Alist() function.  If
1578 :     //  an item is picked, and "xVariable" is filled, then store it.
1579 :     //  If the VARIABLE is a code block, then pass it as an eval().  The
1580 :     //  return value of the function will also be either the indiivual
1581 :     //  element that was picked OR the array of tagged elements.
1582 :
1583 :     //  The ARRAY is the array of items to be displayed.
1584 :
1585 :      //  The STRU is the structure of the listbox.
1586 :      //     Stru[1] := Array of 4 coordinates
1587 :      //     Stru[2] := Window width
1588 :      //     Stru[3] := Color
1589 :
1590 :      //  Tagged is to be used if lTagging is included!
1591 :
1592 :      // if RETTOGGLE is a logical false, then the return value from this
1593 :      //    function will be the element chosen or the array of elements
1594 :      //    tagged.  If TAGGING is set to true, then the value of RETTOGGLE
1595 :      //    is not important.  However, if the value is a logical TRUE (default)
1596 :      //    then the return value of the function will be the element position
1597 :      //    chosen, with 0 being no pick!
1598 :
1599 :
1600 :   local cScreen                 as char
1601 :   local aTagmark := {}          as array
1602 :   local nPointer := 1           as int
1603 :   local oObject                 as object
1604 :   local oColumn                 as object
1605 :   local cString  := ""          as char
1606 :   local cKey                    as char
1607 :   local nThekey                 as int
1608 :   local nPos                    as int
1609 :   local cOldcolor := setcolor() as char
1610 :   local xSelection              as usual
1611 :   local nCount                  as int
1612 :   local xRetval := NIL          as usual
1613 :   local nSkipval                as int
1614 :
1615 :   IF aArray IS pARRAY
1616 :     if !empty( aArray )
1617 :       DEFAULT lTagging TO pFALSE, ;
1618 :               lRettoggle TO pTRUE
1619 :
1620 :       IF aStru IS NOT pARRAY
1621 :         aStru    := {}
1622 :         aadd(aStru, {5,40,20,76})
1623 :         aadd(aStru, 35)
1624 :         aadd(aStru, setcolor() )
1625 :       endif
1626 :
1627 :       cScreen := savescreen(aStru[1,1], aStru[1,2], aStru[1,3], aStru[1,4])
1628 :
1629 :       setcolor( aStru[3] )
1630 :       dispbox(aStru[1,1], aStru[1,2], aStru[1,3], aStru[1,4], pDBAR)
1631 :
1632 :       if lTagging
1633 :         aeval( aArray, {|x| aadd(aTagmark, chr(32)) } )
1634 :       endif
1635 :       oObject               := tbrowsenew(aStru[1,1]+1, aStru[1,2]+1,;
1636 :                                           aStru[1,3]-1, aStru[1,4]-1)
1637 :       oObject:skipblock     := {|n| nSkipval := ArraySkip(n, nPointer, ;
1638 :                                     len( aArray )), nPointer += nSkipval, ;
1639 :                                     nSkipval}
1640 :       oObject:goTopBlock    := {|| nPointer := 1}
1641 :       oObject:goBottomBlock := {|| nPointer := len( aArray )}
1642 :       oObject:headSep       := chr(205)
1643 :
1644 :       if lTagging
1645 :         oColumn       := tbcolumnnew( chr(16), {|| aTagmark[nPointer]} )
1646 :         oColumn:width := 2
1647 :         oObject:addColumn( oColumn )
1648 :       endif
1649 :
1650 :       oColumn          := tbcolumnnew("Items to;pick", {|| aArray[nPointer]})
1651 :       oColumn:width    := aStru[2] - if( lTagging, 7, 0 )
1652 :       oObject:addColumn( oColumn )
1653 :
1654 :       if lTagging
1655 :         oObject:colPos := 2
1656 :       endif
1657 :
1658 :       PROCESS
1659 :
1660 :         if IsStable( oObject )
1661 :           do case
1662 :           case oObject:hittop
1663 :              oObject:GoBottom()
1664 :              IsStable( oObject )
1665 :           case oObject:hitbottom
1666 :              oObject:GoTop()
1667 :              IsStable( oObject )
1668 :           endcase
1669 :
1670 :           @ aStru[1,3], aStru[1,2]+1 say ;
1671 :             padr(cString, (aStru[1,4]-aStru[1,2]-3), chr(205))
1672 :           devpos( aStru[1,3], aStru[1,2]+1+len(cString) )
1673 :
1674 :           ckey := chr(nThekey := inkey(0))
1675 :
1676 :           do case
1677 :           case ( nThekey == pDOWN_ARROW )
1678 :             oObject:down()
1679 :
1680 :           case ( nThekey == pUP_ARROW )
1681 :             oObject:up()
1682 :
1683 :           case ( nThekey == pEND )
1684 :             oObject:gobottom()
1685 :
1686 :           case ( nThekey == pPGUP )
1687 :             oObject:pageUp()
1688 :
1689 :           case ( nThekey == pPGDN )
1690 :             oObject:pageDown()
1691 :
1692 :           case ( nThekey == pHOME )
1693 :             oObject:gotop()
1694 :
1695 :           case ( nThekey == pENTER )
1696 :             if lTagging
1697 :               aTagmark[nPointer] := if( aTagmark[nPointer] == chr(16), ;
1698 :                                         chr(32), chr(16) )
1699 :               oObject:refreshcurrent()
1700 :               oObject:down()
1701 :             else
1702 :               if lRettoggle
1703 :                 xRetval := nPointer
1704 :               else
1705 :                 xRetval := xSelection := aArray[nPointer]
1706 :               endif
1707 :               exit
1708 :             endif
1709 :
1710 :           case ( nThekey == pBKSP )
1711 :             if !empty(cString)
1712 :               cString := left( cString, len(cString)-1 )
1713 :               if !empty( nPos := ascan(aArray, ;
1714 :                                  {|x| upper(x) == upper(cString)} ) )
1715 :                 nPointer := nPos
1716 :                 oObject:refreshall()
1717 :               endif
1718 :             endif
1719 :
1720 :           case ( nThekey == pESC ) .or. ( nThekey == pF10 )
1721 :             if !lRettoggle
1722 :               xRetval := 0
1723 :             endif
1724 :             exit
1725 :
1726 :           otherwise
1727 :             if nThekey > 31 .and. nThekey < 128
1728 :               cString += ckey
1729 :               if !empty(cString)
1730 :                 if !empty( ( nPos := ascan(aArray, {|x| x == cString} )) )
1731 :                   nPointer := nPos
1732 :                   oObject:refreshall()
1733 :                 endif
1734 :               endif
1735 :             endif
1736 :           endcase
1737 :         endif
1738 :
1739 :       END PROCESS
1740 :
1741 :       if !lTagging
1742 :         if !empty( xSelection )
1743 :           if xVariable IS pBLOCK  // In case the element was passed by a code block
1744 :             eval(xVariable, xSelection)
1745 :           else                    // In case the element was passed by reference
1746 :             xVariable := xSelection
1747 :           endif
1748 :
1749 :         endif
1750 :       else
1751 :         xRetval := {}
1752 :         for nCount := 1 to len( aTagmark ) // This should be a for ... next loop
1753 :           if aTagmark[nCount] == chr(16)   // rather than an aeval() since the
1754 :             aadd(xRetval, aArray[nCount])  // loop is controlled by TAGMARKER yet
1755 :           endif                            // the desired evaluation is on ARRAY
1756 :         next
1757 :       endif
1758 :
1759 :       restscreen( aStru[1,1], aStru[1,2], aStru[1,3], aStru[1,4], cScreen )
1760 :
1761 :     endif
1762 :   endif
1763 :
1764 :   setcolor( cOldcolor )
1765 :
1766 :   return( xRetval )
1767 :
1768 : ********************
1769 :
1770 : function MustFill( xExpression, nRow, nCol, cSaying, cColor, bErrorTone )
1771 :
1772 :   local lRetvalue := pTRUE as logical
1773 :
1774 :   if !( lastkey() == pUP_ARROW )
1775 :
1776 :     lRetValue := !empty( xExpression )
1777 :
1778 :     DEFAULT nRow       TO maxrow(), ;
1779 :             nCol       TO 0, ;
1780 :             cSaying    TO "This MUST be filled!", ;
1781 :             cColor     TO ColorSet( nRow, nCol ), ;
1782 :             bErrorTone TO {|| NIL}
1783 :
1784 :     setpos( nRow, nCol )
1785 :     if empty( xExpression )
1786 :       eval( bErrorTone )
1787 :       devout( cSaying, cColor )
1788 :
1789 :     else
1790 :       devout( space(len(cSaying)), cColor )
1791 :
1792 :     endif
1793 :
1794 :   endif
1795 :
1796 :   return( lRetvalue )
1797 :
1798 : #define DI_KEY      1
1799 : #define DI_VAL     2
1800 :
1801 : // hash machinery
1802 : #define KEY_HASH(key)         ( bin2w(key) + bin2w( substr(trim(key), -2) ) )
1803 : #define HASH_VAL(key, size)   ( ( KEY_HASH(key) % size ) + 1 )
1804 :
1805 : #define DEFAULT_HASH_SIZE     31
1806 : #define MAX_ARRAY_LEN         4096
1807 :
1808 : /***
1809 : *  DictNew()
1810 : */
1811 :
1812 : function DictNew()
1813 :
1814 :   local nCount as int
1815 :   local aDict  as array
1816 :
1817 :   aDict := array(DEFAULT_HASH_SIZE)
1818 :
1819 :   for nCount := 1 to DEFAULT_HASH_SIZE
1820 :     aDict[nCount] := {}
1821 :   next
1822 :
1823 :   return ( aDict )
1824 :
1825 : /***
1826 : *  DictAt()
1827 : *  Return the value for a particular key.
1828 : */
1829 :
1830 : function DictAt( aDict, ;  // Array of the dictionary
1831 :                  cKey )    // Characer key to be used
1832 :
1833 :   local aBucket   as array // array of possible matches for hash value of key
1834 :   local xRetVal   as usual
1835 :   local nPosition as int
1836 :
1837 :   aBucket := aDict[ HASH_VAL(cKey, len(aDict)) ]
1838 :
1839 :   // if length is greater than 16, use binary search; otherwise,
1840 :   // use ascan
1841 :   if len( aBucket ) <= 16
1842 :     nPosition := ascan( aBucket, { |aAssoc| aAssoc[ DI_KEY ] == cKey } )
1843 :   else
1844 :     nPosition := DictBinSrch( aBucket,cKey )
1845 :   endif
1846 :
1847 :   if !( nPosition == 0 )
1848 :     xRetVal := aBucket[nPosition,DI_VAL]
1849 :   endif
1850 :
1851 :   return( xRetVal )  // Default is a NIL value
1852 :
1853 : /***
1854 : *  DictPut()
1855 : *  Add or replace the value for a particular key.
1856 : *  Returns the value being added.
1857 : */
1858 :
1859 : function DictPut( aDict, ;  // Dictionary of values
1860 :                    cKey, ;  // Character string as tag/key to add
1861 :                    xVal )   // Item to be added
1862 :
1863 :   DictPutPair( aDict, {cKey, xVal} )
1864 :
1865 :   return (xVal)
1866 :
1867 :
1868 : /***
1869 : *  DictPutPair()
1870 : *  Add or replace cKey/value pair for a particular cKey.
1871 : *  Returns the pair being added.
1872 : */
1873 :
1874 : function DictPutPair( aDict, ;  // Dictionary name to be worked on
1875 :                       aPair )   // Array of tag and value to be added
1876 :
1877 :   local aBucket   as array
1878 :   local cKey      as char
1879 :   local nPosition as int     // Position of tag in dictionary
1880 :
1881 :   cKey := aPair[ DI_KEY ]
1882 :
1883 :   aBucket := aDict[ HASH_VAL(cKey, len(aDict)) ]
1884 :
1885 :   if len( aBucket ) <= 16
1886 :     nPosition := ascan( aBucket, { |aAssoc| aAssoc[ DI_KEY ] == cKey } )
1887 :   else
1888 :     nPosition := DictBinSrch( aBucket,cKey )
1889 :   endif
1890 :
1891 :   if ( nPosition == 0 )
1892 :     aadd( aBucket, aPair )
1893 :     nPosition := len( aBucket )
1894 :     // Now sort the aBucket
1895 :     asort( aBucket,,,{|aFirst, aSecond| aFirst[DI_KEY] < aSecond[DI_KEY]})
1896 :   else
1897 :     aBucket[nPosition] := aPair
1898 :   end
1899 :
1900 :   // Increase size to 128
1901 :   if ( nPosition > 127 .and. len(aDict) < MAX_ARRAY_LEN )
1902 :     // this aBucket is big, grow aDict so that mathematically,
1903 :     // less change for key collision
1904 :     DictResize(aDict)
1905 :   end
1906 :
1907 :   return ( aPair )
1908 :
1909 : /***
1910 : *  DictRemove()
1911 : *  Remove the cKey/value pair for a particular cKey.
1912 : *  Returns a reference to the dictionary.
1913 : */
1914 :
1915 : function DictRemove( aDict, ; // Dictionary to be worked on
1916 :                      cKey )   // Name of the tag of item to remove
1917 :
1918 :   local aBucket   as array
1919 :   local nPosition as int   // Position of item in dictionary
1920 :
1921 :   aBucket := aDict[ HASH_VAL(cKey, len(aDict)) ]
1922 :   nPosition := ascan( aBucket, { |aAssoc| aAssoc[ DI_KEY ] == cKey } )
1923 :
1924 :   if !( nPosition == 0 )
1925 :     adel( aBucket, nPosition )
1926 :     asize( aBucket, len(aBucket) - 1 )
1927 :   endif
1928 :
1929 :   return ( aDict )
1930 :
1931 : /***
1932 : *  DictEval()
1933 : *  Evaluate block against each pair in dictionary. Pair is passed to
1934 : *  block.
1935 : *  Returns reference to dict.
1936 : */
1937 :
1938 : function DictEval( aDict, ;  // Array of dictionary to work on
1939 :                bOperation )  // Code block to eval against every item
1940 :
1941 :   aeval( aDict, ;
1942 :     { |aBucket| aeval( aBucket, { |aAssoc| eval(bOperation, aAssoc) } ) } )
1943 :
1944 :   return ( aDict )
1945 :
1946 : /***
1947 : *  DictResize()
1948 : *
1949 : *  Service. Grows dict hash table.
1950 : *
1951 : *  NOTE: rehashes, invalidating any direct indexes into dict held
1952 : *  by caller across this call.
1953 : */
1954 :
1955 : static function DictResize( aDict )
1956 :
1957 :   local aOld   as int
1958 :   local nSize  as int
1959 :   local nCount as int // for the FOR...NEXT loop
1960 :
1961 :   // make copy of old aDict
1962 :   aOld := array( len(aDict) )
1963 :   acopy( aDict, aOld )
1964 :
1965 :   // resize and clear aDict
1966 :   nSize := min( len(aDict) * 2 - 1, MAX_ARRAY_LEN )
1967 :   asize( aDict, nSize )
1968 :
1969 :   for nCount := 1 to nSize
1970 :     aDict[nCount] := {}
1971 :   next
1972 :
1973 :   // rehash pairs into aDict
1974 :   aeval( aOld, ;
1975 :     { |aBucket| aeval( aBucket, ;
1976 :       { |aAssoc| DictPutPair( aDict, aAssoc ) } ) } )
1977 :
1978 :   return ( aDict )
1979 :
1980 : /***
1981 : *  DictBinSrch( aBucket )
1982 : *
1983 : *  Performs binary search on array
1984 : *
1985 : */
1986 :
1987 : function DictBinSrch( aBucket,cKey )
1988 :
1989 :   local nLow  := 1                   as int    // Low value
1990 :   local nHigh := len( aBucket )      as int    // High element value
1991 :   local nMid  := int((nLow+nHigh)/2) as int    // Mid value
1992 :   local nRetval                      as int    // Element found
1993 :
1994 :   // while not found and more to search for. search between low and high
1995 :   // values
1996 :   while !(aBucket[nMid,DI_KEY] == cKey) .and. (nLow < nHigh)
1997 :
1998 :     if cKey > aBucket[nMid,DI_KEY]
1999 :       // must be in the right hand side of the binary tree
2000 :       // next search is between mid+1 and high
2001 :       nLow := nMid + 1
2002 :     else
2003 :       // must be in left hand side of binary tree
2004 :       // next search is between low and mid-1
2005 :       nHigh := nMid - 1
2006 :     endif
2007 :
2008 :     nMid := int((nLow+nHigh)/2)  // new middle between the extremes
2009 :
2010 :   enddo
2011 :
2012 :   // if no find, return 0, else return the string
2013 :   if !(aBucket[nMid,DI_KEY] == cKey)
2014 :     nRetval := 0
2015 :   else
2016 :     nRetval := nMid
2017 :   endif
2018 :
2019 :   return( nRetval )
2020 :
2021 : *******************
2022 :
2023 : function DBPReader( oGet )
2024 :
2025 :   // read the GET if the WHEN condition is satisfied
2026 :   if ( GetPreValidate(oGet) )
2027 :
2028 :     // activate the GET for reading
2029 :     oGet:SetFocus()
2030 :
2031 :     while ( oGet:exitState == GE_NOEXIT )
2032 :
2033 :       // check for initial typeout (no editable positions)
2034 :       if ( oGet:typeOut )
2035 :          oGet:exitState := GE_ENTER
2036 :       end
2037 :
2038 :       // apply keystrokes until exit
2039 :       while ( oGet:exitState == GE_NOEXIT )
2040 :          GetApplyKey( oGet, Inkey(0) )
2041 :       end
2042 :
2043 :       // disallow exit if the VALID condition is not satisfied
2044 :       if ( !DBPPostValidate(oGet) )
2045 :          oGet:exitState := GE_NOEXIT
2046 :       end
2047 :
2048 :     enddo
2049 :
2050 :     // deactivate the GET
2051 :     oGet:KillFocus()
2052 :
2053 :   endif
2054 :
2055 :   return( NIL )
2056 :
2057 : /***
2058 : *   DBPPostValidate()
2059 : *   Test exit condition (VALID clause) for a GET.
2060 : *
2061 : *   NOTE: bad dates are rejected in such a way as to preserve edit buffer.
2062 : */
2063 : func DBPPostValidate(oGet)
2064 :
2065 :   local lSaveUpdated     as logical
2066 :   local lChanged         as logical
2067 :   local lValid := pTRUE  as logical
2068 :
2069 :   if ( oGet:exitState == GE_ESCAPE )
2070 :     return (pTRUE)               // NOTE
2071 :   endif
2072 :
2073 :   if ( oGet:BadDate() )
2074 :     oGet:Home()
2075 :     return (pFALSE)               // NOTE
2076 :   endif
2077 :
2078 :   // if editing occurred, assign the new value to the variable
2079 :   if ( oGet:changed )
2080 :     oGet:Assign()
2081 :     readupdated( pTRUE )
2082 :   endif
2083 :
2084 :   // reform edit buffer, set cursor to home position, redisplay
2085 :   // Changed for this function to use UpdateBuffer instead
2086 :   oGet:UpdateBuffer()
2087 :
2088 :   // check VALID condition if specified
2089 :   if ( oGet:postBlock <> NIL )
2090 :
2091 :     lSaveUpdated := readupdated()
2092 :
2093 :     // S87 compat.
2094 :     setpos( oGet:row, oGet:col + Len(oGet:buffer) )
2095 :
2096 :     lValid := eval(oGet:postBlock, oGet)
2097 :
2098 :     // reset compat. pos
2099 :     setpos( oGet:row, oGet:col )
2100 :
2101 :     oGet:UpdateBuffer()
2102 :
2103 :     readupdated( lSaveUpdated )
2104 :
2105 :     if ReadKill()
2106 :       oGet:exitState := GE_ESCAPE   // provokes ReadModal() exit
2107 :       lValid := pTRUE
2108 :     end
2109 :
2110 :   endif
2111 :
2112 :   return (lValid)
2113 :
2114 : // End of File: Genfunc.prg

