fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
Viktor Szakats
1999-08-05 03:01:15 +00:00
parent 70a082a7a7
commit 05aaa87103
4 changed files with 420 additions and 478 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
harbour/ChangeLog
View File

@@ -1,3 +1,9 @@
19990805-04:47 GMT+1 Victor Szel <info@szelvesz.hu>
* source/rtl/console.c - Small var naming change.
* source/rtl/achoice.prg
! Fixed: SET DEVICE is no longer redirecting it's output.
% Optimialized color handling. (Thanks to Paul Tucker)
19990804-14:30 EDT Paul Tucker <ptucker@sympatico.ca>
* source/rtl/filesys.c
* added a cast (reported by Matteo)

847
harbour/source/rtl/achoice.prg
View File

@@ -95,534 +95,449 @@
* $END$
*/
*+--------------------------------------------------------------------
*+
*+ Function achoice()
*+
*+--------------------------------------------------------------------
*+
function achoice( nTop, nLft, nBtm, nRyt, acItems, xSelect, xUserFunc, nPos, nHiLytRow )
local nNumCols := 0 // Number of columns in the window
local nNumRows := 0 // Number of rows in the window
local acCopy := {} // A padded copy of the items
local alSelect := {} // Select permission
local nNewPos := 0 // The next item to be selected
local lFinished := .F. // Is processing finished?
local nKey := 0 // The keystroke to be processed
local nMode := AC_IDLE // The current operating mode
local nAtTop := 1 // The number of the item at the top
local nAtBtm := 1 // The number of the item at the bottom
local nItems := 0 // The number of items
local nGap := 0 // The number of lines between top and current lines
// Block used to search for items
local bScan := { | cX | if( left( cX, 1 ) == upper( chr( nKey ) ), .T., .F. ) }
local lUserFunc // Is a user function to be used?
local nUserFunc := 0 // Return value from user function
local cLoClr := __COLORINDEX( setcolor(), CLR_STANDARD )
local cHiClr := __COLORINDEX( setcolor(), CLR_ENHANCED )
local cUnClr := __COLORINDEX( setcolor(), CLR_UNSELECTED )
local nSaveCsr := setcursor( SC_NONE )
local nFrstItem := 0
local nLastItem := 0
local nCntr
local nNumCols := 0 // Number of columns in the window
local nNumRows := 0 // Number of rows in the window
local acCopy := {} // A padded copy of the items
local alSelect := {} // Select permission
local nNewPos := 0 // The next item to be selected
local lFinished := .F. // Is processing finished?
local nKey := 0 // The keystroke to be processed
local nMode := AC_IDLE // The current operating mode
local nAtTop := 1 // The number of the item at the top
local nAtBtm := 1 // The number of the item at the bottom
local nItems := 0 // The number of items
local nGap := 0 // The number of lines between top and current lines
// Block used to search for items
local bScan := { | cX | if( left( cX, 1 ) == upper( chr( nKey ) ), .T., .F. ) }
local lUserFunc // Is a user function to be used?
local nUserFunc := 0 // Return value from user function
local nSaveCsr := setcursor( SC_NONE )
local nFrstItem := 0
local nLastItem := 0
local nCntr
lUserFunc := !empty( xUserFunc ) .AND. ValType( xUserFunc ) $ "CB"
ColorSelect( CLR_STANDARD )
IF empty( cHiClr )
cHiClr := After( "/", cLoClr ) + "/" + Before( "/", cLoClr )
endif
lUserFunc := !empty( xUserFunc ) .AND. ValType( xUserFunc ) $ "CB"
IF empty( cUnClr )
cUnClr := cLoClr
endif
DEFAULT nTop to 0 // The topmost row of the window
DEFAULT nLft to 0 // The leftmost column of the window
DEFAULT nBtm to maxrow() + 1 // The bottommost row of the windows
DEFAULT nRyt to maxcol() + 1 // The rightmost column of the window
DEFAULT acItems to {} // The items from which to choose
DEFAULT xSelect to .T. // Array or logical, what is selectable
DEFAULT nPos to 1 // The number of the selected item
DEFAULT nHiLytRow to 0 // The row to be highlighted
DEFAULT nTop to 0 // The topmost row of the window
DEFAULT nLft to 0 // The leftmost column of the window
DEFAULT nBtm to maxrow() + 1 // The bottommost row of the windows
DEFAULT nRyt to maxcol() + 1 // The rightmost column of the window
DEFAULT acItems to {} // The items from which to choose
DEFAULT xSelect to .T. // Array or logical, what is selectable
DEFAULT nPos to 1 // The number of the selected item
DEFAULT nHiLytRow to 0 // The row to be highlighted
nNumCols := nRyt - nLft + 1
nNumRows := nBtm - nTop + 1
aeval( acItems, { | x, n | if( valtype( x ) == "C", aadd( acCopy, padr( x, nNumCols ) ), .F. ) } )
nItems := len( acCopy )
nNumCols := nRyt - nLft + 1
nNumRows := nBtm - nTop + 1
aeval( acItems, { | x, n | if( valtype( x ) == "C", aadd( acCopy, padr( x, nNumCols ) ), .F. ) } )
nItems := len( acCopy )
alSelect := array( nItems )
IF valtype( xSelect ) == "A"
afill( alSelect, .T. )
for nCntr := 1 to len( xSelect )
IF nCntr <= nItems
IF valtype( xSelect[ nCntr ] ) == "C"
IF empty( xSelect[ nCntr ] )
lFinished := .T.
nPos := 0
else
alSelect := array( nItems )
IF valtype( xSelect ) == "A"
afill( alSelect, .T. )
for nCntr := 1 to len( xSelect )
IF nCntr <= nItems
IF valtype( xSelect[ nCntr ] ) == "C"
IF empty( xSelect[ nCntr ] )
lFinished := .T.
nPos := 0
else
/* TODO: When macro evaluation will work, this should be commented out:
alSelect[ nCntr ] := &( xSelect[ nCntr ] )
*/
endif
else
alSelect[ nCntr ] := xSelect[ nCntr ]
endif
else
alSelect[ nCntr ] := xSelect[ nCntr ]
nCntr := len( xSelect ) + 1
endif
else
nCntr := len( xSelect ) + 1
endif
next
else
afill( alSelect, xSelect )
endif
IF !lFinished
nFrstItem := ascan( alSelect, .T. ) // First valid item
IF nFrstItem == 0
nLastItem := 0
nPos := 0
nMode := AC_NOITEM
next
else
nMode := AC_IDLE
nLastItem := nItems // Last valid item
do while ( !alSelect[ nLastItem ] )
nLastItem --
enddo
afill( alSelect, xSelect )
endif
// Ensure hilighted item can be selected
nPos := Between( nFrstItem, nPos, nLastItem )
IF !lFinished
// Force hilighted row to be valid
nHiLytRow := Between( 0, nHiLytRow, nNumRows - 1 )
nFrstItem := ascan( alSelect, .T. ) // First valid item
// Force the topmost item to be a valid index of the array
nAtTop := Between( 1, max( 1, nPos - nHiLytRow ), nItems )
// Ensure as much of the selection area as possible is covered
if ( nAtTop + nNumRows - 1 ) > nItems
nAtTop := max( 1, nItems - nNumrows + 1 )
endif
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
do while ( !lFinished )
IF nMode != AC_GOTO .and. nMode != AC_NOITEM
nKey := Inkey( 0 )
nMode := AC_IDLE
endif
do case
case ( ( nKey == K_ESC ) .or. ( nMode == AC_NOITEM ) ) .and. ( !lUserFunc )
nMode := AC_ABORT
nPos := 0
lFinished := .T.
case nKey == K_UP
IF nPos == nFrstItem
nMode := AC_HITTOP
IF nAtTop > max( 1, nPos - nNumRows + 1 )
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
IF nFrstItem == 0
nLastItem := 0
nPos := 0
nMode := AC_NOITEM
else
nNewPos := nPos - 1
do while !alSelect[ nNewPos ]
nNewPos --
nMode := AC_IDLE
nLastItem := nItems // Last valid item
do while ( !alSelect[ nLastItem ] )
nLastItem --
enddo
IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 )
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
else
dispbegin()
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
scroll( nTop, nLft, nBtm, nRyt, ( nNewPos - ( nAtTop + nNumRows - 1 ) ) )
nAtTop := nNewPos
nPos := max( nPos, nAtTop + nNumRows - 1 )
do while nPos > nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos --
enddo
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
dispend()
endif
endif
case nKey == K_DOWN
* Find the next selectable item to display
IF nPos == nLastItem
nMode := AC_HITBOTTOM
IF nAtTop < min( nPos, nItems - nNumRows + 1 )
nAtTop := min( nPos, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
// Ensure hilighted item can be selected
nPos := Between( nFrstItem, nPos, nLastItem )
nNewPos := nPos + 1
// Force hilighted row to be valid
nHiLytRow := Between( 0, nHiLytRow, nNumRows - 1 )
do while !alSelect[ nNewPos ]
nNewPos ++
enddo
IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 )
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
else
dispbegin()
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
scroll( nTop, nLft, nBtm, nRyt, ( nNewPos - ( nAtTop + nNumRows - 1 ) ) )
nAtTop := nNewPos - nNumRows + 1
nPos := max( nPos, nAtTop )
do while nPos < nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos ++
enddo
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
dispend()
endif
// Force the topmost item to be a valid index of the array
nAtTop := Between( 1, max( 1, nPos - nHiLytRow ), nItems )
// Ensure as much of the selection area as possible is covered
if ( nAtTop + nNumRows - 1 ) > nItems
nAtTop := max( 1, nItems - nNumrows + 1 )
endif
case ( ( nKey == K_HOME ) .or. ( nKey == K_CTRL_PGUP ) ) .and. ( !lUserFunc )
IF nPos == nFrstItem
IF nAtTop == max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
do while ( !lFinished )
IF nMode != AC_GOTO .and. nMode != AC_NOITEM
nKey := Inkey( 0 )
nMode := AC_IDLE
endif
do case
case ( ( nKey == K_ESC ) .or. ( nMode == AC_NOITEM ) ) .and. ( !lUserFunc )
nMode := AC_ABORT
nPos := 0
lFinished := .T.
case nKey == K_UP
IF nPos == nFrstItem
nMode := AC_HITTOP
IF nAtTop > max( 1, nPos - nNumRows + 1 )
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
nPos := nFrstItem
nAtTop := nPos
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
case ( ( nKey == K_END ) .or. ( nKey == K_CTRL_PGDN ) ) .and. ( !lUserFunc )
IF nPos == nLastItem
IF nAtTop == min( nLastItem, nItems - nNumRows + 1 )
nMode := AC_HITBOTTOM
else
nAtTop := min( nLastItem, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
IF InRange( nAtTop, nLastItem, nAtTop + nNumRows - 1 )
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nLastItem
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
else
nPos := nLastItem
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
endif
case nKey == K_CTRL_HOME
IF nPos == nFrstItem
IF nAtTop == max( 1, nPos - nNumRows + 1 )
nMode := AC_HITTOP
else
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
nNewPos := nAtTop
do while !alSelect[ nNewPos ]
nNewPos ++
enddo
IF nNewPos != nPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
endif
endif
case nKey == K_CTRL_END
IF nPos == nLastItem
IF nAtTop == min( nPos, nItems - nNumRows + 1 )
nMode := AC_HITBOTTOM
else
nAtTop := min( nPos, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
nNewPos := nAtTop + nNumRows - 1
do while !alSelect[ nNewPos ]
nNewPos --
enddo
IF nNewPos != nPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
endif
endif
case nKey == K_PGUP
IF nPos == nFrstItem
nMode := AC_HITTOP
IF nAtTop > max( 1, nPos - nNumRows + 1 )
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
IF InRange( nAtTop, nFrstItem, nAtTop + nNumRows - 1 )
* On same page as nFrstItem
nPos := nFrstItem
nAtTop := max( nPos - nNumRows + 1, 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
else
if ( nPos - nNumRows + 1 ) < nFrstItem
nPos := nFrstItem
nAtTop := nFrstItem
nNewPos := nPos - 1
do while !alSelect[ nNewPos ]
nNewPos --
enddo
IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 )
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
else
nPos := max( nFrstItem, nPos - nNumRows + 1 )
nAtTop := max( 1, nAtTop - nNumRows + 1 )
do while ( nPos > nFrstItem ) .and. ( !alSelect[ nPos ] )
dispbegin()
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
scroll( nTop, nLft, nBtm, nRyt, ( nNewPos - ( nAtTop + nNumRows - 1 ) ) )
nAtTop := nNewPos
nPos := max( nPos, nAtTop + nNumRows - 1 )
do while nPos > nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos --
enddo
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
dispend()
endif
endif
case nKey == K_DOWN
* Find the next selectable item to display
IF nPos == nLastItem
nMode := AC_HITBOTTOM
IF nAtTop < min( nPos, nItems - nNumRows + 1 )
nAtTop := min( nPos, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
nNewPos := nPos + 1
do while !alSelect[ nNewPos ]
nNewPos ++
enddo
IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 )
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
else
dispbegin()
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
scroll( nTop, nLft, nBtm, nRyt, ( nNewPos - ( nAtTop + nNumRows - 1 ) ) )
nAtTop := nNewPos - nNumRows + 1
nPos := max( nPos, nAtTop )
do while nPos < nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos ++
enddo
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
dispend()
endif
endif
case ( ( nKey == K_HOME ) .or. ( nKey == K_CTRL_PGUP ) ) .and. ( !lUserFunc )
IF nPos == nFrstItem
IF nAtTop == max( 1, nPos - nNumRows + 1 )
nMode := AC_HITTOP
else
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
nPos := nFrstItem
nAtTop := nPos
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
case ( ( nKey == K_END ) .or. ( nKey == K_CTRL_PGDN ) ) .and. ( !lUserFunc )
IF nPos == nLastItem
IF nAtTop == min( nLastItem, nItems - nNumRows + 1 )
nMode := AC_HITBOTTOM
else
nAtTop := min( nLastItem, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
IF InRange( nAtTop, nLastItem, nAtTop + nNumRows - 1 )
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nLastItem
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
else
nPos := nLastItem
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
endif
case nKey == K_CTRL_HOME
IF nPos == nFrstItem
IF nAtTop == max( 1, nPos - nNumRows + 1 )
nMode := AC_HITTOP
else
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
nNewPos := nAtTop
do while !alSelect[ nNewPos ]
nNewPos ++
enddo
IF nNewPos != nPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
endif
endif
case nKey == K_CTRL_END
IF nPos == nLastItem
IF nAtTop == min( nPos, nItems - nNumRows + 1 )
nMode := AC_HITBOTTOM
else
nAtTop := min( nPos, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
nNewPos := nAtTop + nNumRows - 1
do while !alSelect[ nNewPos ]
nNewPos --
enddo
IF nNewPos != nPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
endif
endif
case nKey == K_PGUP
IF nPos == nFrstItem
nMode := AC_HITTOP
IF nAtTop > max( 1, nPos - nNumRows + 1 )
nAtTop := max( 1, nPos - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
IF InRange( nAtTop, nFrstItem, nAtTop + nNumRows - 1 )
* On same page as nFrstItem
nPos := nFrstItem
nAtTop := max( nPos - nNumRows + 1, 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
else
if ( nPos - nNumRows + 1 ) < nFrstItem
nPos := nFrstItem
nAtTop := nFrstItem
else
nPos := max( nFrstItem, nPos - nNumRows + 1 )
nAtTop := max( 1, nAtTop - nNumRows + 1 )
do while ( nPos > nFrstItem ) .and. ( !alSelect[ nPos ] )
nPos --
nAtTop --
enddo
nAtTop := max( 1, nAtTop )
endif
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
endif
case nKey == K_PGDN
IF nPos == nLastItem
nMode := AC_HITBOTTOM
IF nAtTop < min( nPos, nItems - nNumRows + 1 )
nAtTop := min( nPos, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
else
IF InRange( nAtTop, nLastItem, nAtTop + nNumRows - 1 )
* On the same page as nLastItem
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nLastItem
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
else
nGap := nPos - nAtTop
nPos := min( nLastItem, nPos + nNumRows - 1 )
if ( nPos + nNumRows - 1 ) > nLastItem
* On the last page
nAtTop := nLastItem - nNumRows + 1
nPos := min( nLastItem, nAtTop + nGap )
else
* Not on the last page
nAtTop := nPos - nGap
endif
* Make sure that the item is selectable
do while ( nPos < nLastItem ) .and. ( !alSelect[ nPos ] )
nPos ++
nAtTop ++
enddo
* Don't leave blank space on the page
do while ( nAtTop + nNumRows - 1 ) > nItems
nAtTop --
enddo
nAtTop := max( 1, nAtTop )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
endif
case nKey == K_PGDN
IF nPos == nLastItem
nMode := AC_HITBOTTOM
IF nAtTop < min( nPos, nItems - nNumRows + 1 )
nAtTop := min( nPos, nItems - nNumRows + 1 )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
else
IF InRange( nAtTop, nLastItem, nAtTop + nNumRows - 1 )
* On the same page as nLastItem
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nLastItem
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
else
nGap := nPos - nAtTop
nPos := min( nLastItem, nPos + nNumRows - 1 )
if ( nPos + nNumRows - 1 ) > nLastItem
* On the last page
nAtTop := nLastItem - nNumRows + 1
nPos := min( nLastItem, nAtTop + nGap )
else
* Not on the last page
nAtTop := nPos - nGap
endif
* Make sure that the item is selectable
do while ( nPos < nLastItem ) .and. ( !alSelect[ nPos ] )
nPos ++
nAtTop ++
enddo
* Don't leave blank space on the page
do while ( nAtTop + nNumRows - 1 ) > nItems
nAtTop --
enddo
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
endif
endif
case ( nKey == K_ENTER ) .and. ( !lUserFunc )
nMode := AC_SELECT
lFinished := .T.
case ( nKey == K_ENTER ) .and. ( !lUserFunc )
nMode := AC_SELECT
lFinished := .T.
case ( nKey == K_RIGHT ) .and. ( !lUserFunc )
nPos := 0
lFinished := .T.
case ( nKey == K_RIGHT ) .and. ( !lUserFunc )
nPos := 0
lFinished := .T.
case ( nKey == K_LEFT ) .and. ( !lUserFunc )
nPos := 0
lFinished := .T.
case ( nKey == K_LEFT ) .and. ( !lUserFunc )
nPos := 0
lFinished := .T.
case InRange( 32, nKey, 255 ) .and. ( ( !lUserFunc ) .or. ( nMode == AC_GOTO ) )
* Find next selectable item
nNewPos := ascan( acCopy, bScan, nPos + 1 )
do while InRange( nPos, nNewPos, nLastItem ) .and. ( !alSelect[ nNewPos ] )
nNewPos := ascan( acCopy, bScan, nNewPos + 1 )
enddo
IF nNewPos == 0
* Loop back to beginning item, if there is one
nNewPos := ascan( acCopy, bScan )
do while InRange( 1, nNewPos, nLastItem ) .and. ( !alSelect[ nNewPos ] )
case InRange( 32, nKey, 255 ) .and. ( ( !lUserFunc ) .or. ( nMode == AC_GOTO ) )
* Find next selectable item
nNewPos := ascan( acCopy, bScan, nPos + 1 )
do while InRange( nPos, nNewPos, nLastItem ) .and. ( !alSelect[ nNewPos ] )
nNewPos := ascan( acCopy, bScan, nNewPos + 1 )
enddo
endif
IF InRange( nFrstItem, nNewPos, nLastItem ) .and. alSelect[ nNewPos ]
IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 )
* On same page
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F., cLoClr, cHiClr, cUnClr )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T., cLoClr, cHiClr, cUnClr )
else
* On different page
nPos := nNewPos
nAtTop := Between( 1, nPos - nNumRows + 1, nItems )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
IF nNewPos == 0
* Loop back to beginning item, if there is one
nNewPos := ascan( acCopy, bScan )
do while InRange( 1, nNewPos, nLastItem ) .and. ( !alSelect[ nNewPos ] )
nNewPos := ascan( acCopy, bScan, nNewPos + 1 )
enddo
endif
endif
nMode := AC_IDLE
IF InRange( nFrstItem, nNewPos, nLastItem ) .and. alSelect[ nNewPos ]
IF InRange( nAtTop, nNewPos, nAtTop + nNumRows - 1 )
* On same page
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .F. )
nPos := nNewPos
DispLine( acCopy[ nPos ], nTop + ( nPos - nAtTop ), nLft, alSelect[ nPos ], .T. )
else
* On different page
nPos := nNewPos
nAtTop := Between( 1, nPos - nNumRows + 1, nItems )
DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
endif
endif
case ( nMode == AC_GOTO )
* Garbage collect gotos which aren't valid ASCII characters
nMode := AC_IDLE
otherwise
IF nKey == 0 // No keystroke
nMode := AC_IDLE
else
nMode := AC_EXCEPT
case ( nMode == AC_GOTO )
* Garbage collect gotos which aren't valid ASCII characters
nMode := AC_IDLE
otherwise
IF nKey == 0 // No keystroke
nMode := AC_IDLE
else
nMode := AC_EXCEPT
endif
endcase
IF lUserFunc
nUserFunc := do( xUserFunc, nMode, nPos, nPos - nAtTop )
// DISPVAR nUserFunc
do case
case nUserFunc == AC_ABORT
lFinished := .T.
nPos := 0
case nUserFunc == AC_SELECT
lFinished := .T.
case nUserFunc == AC_CONT
* Do nothing
case nUserFunc == AC_GOTO
* Do nothing. The next keystroke won't be read and
* this keystroke will be processed as a goto.
nMode := AC_GOTO
endcase
endif
endcase
enddo
IF lUserFunc
nUserFunc := do( xUserFunc, nMode, nPos, nPos - nAtTop )
// DISPVAR nUserFunc
do case
case nUserFunc == AC_ABORT
lFinished := .T.
nPos := 0
case nUserFunc == AC_SELECT
lFinished := .T.
case nUserFunc == AC_CONT
* Do nothing
case nUserFunc == AC_GOTO
* Do nothing. The next keystroke won't be read and
* this keystroke will be processed as a goto.
nMode := AC_GOTO
endcase
endif
setcursor( nSaveCsr )
enddo
return nPos
setcursor( nSaveCsr )
static function DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop )
return ( nPos )
local nCntr
local nRow // Screen row
local nIndex // Array index
local nSaveRow := row() // Position at start of routine
local nSaveCol := col() // Position at start of routine
local nArrLen := len( acCopy )
*+--------------------------------------------------------------------
*+
*+ Static Function DispPage()
*+
*+ Called from ( achoice.prg ) 15 - function achoice()
*+
*+--------------------------------------------------------------------
*+
static function DispPage( acCopy, alSelect, nTop, nLft, nNumRows, nPos, nAtTop, cLoClr, cHiClr, cUnClr )
dispbegin()
for nCntr := 1 to nNumRows
nRow := nTop + nCntr - 1
nIndex := nCntr + nAtTop - 1
IF InRange( 1, nIndex, nArrLen )
DispLine( acCopy[ nIndex ], nRow, nLft, alSelect[ nIndex ], nIndex == nPos )
else
SetPos( nRow, nCol )
DispOut( space( len( acCopy[ 1 ] ) ) )
endif
next
dispend()
local nCntr
local nRow // Screen row
local nIndex // Array index
local nSaveRow := row() // Position at start of routine
local nSaveCol := col() // Position at start of routine
local nArrLen := len( acCopy )
setpos( nSaveRow, nSaveCol )
dispbegin()
for nCntr := 1 to nNumRows
nRow := nTop + nCntr - 1
nIndex := nCntr + nAtTop - 1
IF InRange( 1, nIndex, nArrLen )
DispLine( acCopy[ nIndex ], nRow, nLft, alSelect[ nIndex ], nIndex == nPos, cLoClr, cHiClr, cUnClr )
else
@ nRow, nLft say space( len( acCopy[ 1 ] ) ) color cLoClr
endif
next
dispend()
return NIL
setpos( nSaveRow, nSaveCol )
static function DispLine( cLine, nRow, nCol, lSelect, lHiLyt )
return ( NIL )
ColorSelect( if( lSelect, ;
if( lHiLyt, CLR_ENHANCED, CLR_STANDARD ), CLR_UNSELECTED ) )
*+--------------------------------------------------------------------
*+
*+ Static Function DispLine()
*+
*+ Called from ( achoice.prg ) 20 - function achoice()
*+ 1 - static function disppage()
*+
*+--------------------------------------------------------------------
*+
static function DispLine( cLine, nRow, nCol, lSelect, lHiLyt, cLoClr, cHiClr, cUnClr )
SetPos( nRow, nCol )
DispOut( cLine )
@ nRow, nCol say cLine color if( lSelect, if( lHiLyt, cHiClr, cLoClr ), cUnClr )
ColorSelect( CLR_STANDARD )
return ( NIL )
return NIL
*+--------------------------------------------------------------------
*+
*+ Static Function InRange()
*+
*+ Called from ( achoice.prg ) 10 - function achoice()
*+ 1 - static function disppage()
*+
*+--------------------------------------------------------------------
*+
static function InRange( xLo, xVal, xHi )
return ( xVal >= xLo ) .and. ;
( xVal <= xHi )
return ( ( xVal >= xLo ) .and. ( xVal <= xHi ) )
*+--------------------------------------------------------------------
*+
*+ Static Function Between()
*+
*+ Called from ( achoice.prg ) 4 - function achoice()
*+
*+--------------------------------------------------------------------
*+
static function Between( xLo, xVal, xHi )
return min( max( xLo, xVal ), xHi )
return ( min( max( xLo, xVal ), xHi ) )
*+--------------------------------------------------------------------
*+
*+ Static Function Before()
*+
*+ Called from ( achoice.prg ) 3 - function achoice()
*+
*+--------------------------------------------------------------------
*+
static function Before( cDelim, cValue )
local cRetVal
local nPos
IF (nPos := at( cDelim, cValue )) > 0
cRetVal := left( cValue, nPos - 1 )
else
cRetVal := cValue
endif
return ( cRetVal )
*+--------------------------------------------------------------------
*+
*+ Static Function After()
*+
*+ Called from ( achoice.prg ) 6 - function achoice()
*+
*+--------------------------------------------------------------------
*+
static function After( cDelim, cValue )
local cRetVal
local nPos
IF (nPos := at( cDelim, cValue )) > 0
cRetVal := substr( cValue, nPos + 1 )
else
cRetVal := ""
endif
return ( cRetVal )

24
harbour/source/rtl/console.c
View File

@@ -1120,16 +1120,16 @@ HARBOUR HB___COLORINDEX( void )
{
if ( ISCHAR( 1 ) && ISNUM( 2 ) )
{
char * szColorSpec = hb_parc( 1 );
ULONG ulColorSpecPos;
ULONG ulColorSpecLen;
char * szColor = hb_parc( 1 );
ULONG ulColorPos;
ULONG ulColorLen;
USHORT uiColorIndex = hb_parni( 2 );
/* Skip the given number of commas */
for ( ulColorSpecPos = 0; szColorSpec[ ulColorSpecPos ] && uiColorIndex > 0 ; ulColorSpecPos++ )
for ( ulColorPos = 0 ; szColor[ ulColorPos ] && uiColorIndex > 0 ; ulColorPos++ )
{
if ( szColorSpec[ ulColorSpecPos ] == ',' )
if ( szColor[ ulColorPos ] == ',' )
uiColorIndex--;
}
@@ -1139,23 +1139,23 @@ HARBOUR HB___COLORINDEX( void )
{
/* Skip the spaces after the comma */
while ( szColorSpec[ ulColorSpecPos ] == ' ' ) ulColorSpecPos++;
while ( szColor[ ulColorPos ] == ' ' ) ulColorPos++;
/* Search for next comma or end of string */
ulColorSpecLen = 0;
ulColorLen = 0;
while ( szColorSpec[ ulColorSpecPos + ulColorSpecLen ] &&
szColorSpec[ ulColorSpecPos + ulColorSpecLen ] != ',' ) ulColorSpecLen++;
while ( szColor[ ulColorPos + ulColorLen ] &&
szColor[ ulColorPos + ulColorLen ] != ',' ) ulColorLen++;
/* Skip the trailing spaces */
while ( ulColorSpecLen &&
szColorSpec[ ulColorSpecPos + ulColorSpecLen - 1 ] == ' ' ) ulColorSpecLen--;
while ( ulColorLen &&
szColor[ ulColorPos + ulColorLen - 1 ] == ' ' ) ulColorLen--;
/* Return the string */
hb_retclen( szColorSpec + ulColorSpecPos, ulColorSpecLen );
hb_retclen( szColor + ulColorPos, ulColorLen );
}
else
hb_retc( "" );

21
harbour/tests/working/Makefile
View File

@@ -17,6 +17,27 @@ endif
ifeq ($(PM),) # PM not defined = build all files
PRG_SOURCES=\
ac_test.prg \
adirtest.prg \
ainstest.prg \
and_or.prg \
array16.prg \
arrayidx.prg \
arrays.prg \
arreval.prg \
arrindex.prg \
atest.prg \
box.prg \
byref.prg \
calling.prg \
cdow.prg \
clasinit.prg \
clasname.prg \
classch.prg \
classes.prg \
clsdata.prg \
cmphello.prg \
codebl.prg \
codebloc.prg \
colorind.prg \
comments.prg \
copyfile.prg \