48f8dba263
* harbour/include/hbgtinfo.ch
* harbour/contrib/libct/ctwin.c
* harbour/source/rtl/gtalleg/gtalleg.c
* harbour/source/rtl/gtcrs/gtcrs.c
* harbour/source/rtl/gtdos/gtdos.c
* harbour/source/rtl/gtos2/gtos2.c
* harbour/source/rtl/gtpca/gtpca.c
* harbour/source/rtl/gtsln/gtsln.c
* harbour/source/rtl/gtstd/gtstd.c
* harbour/source/rtl/gtwin/gtwin.c
* harbour/source/rtl/gtwvt/gtwvt.c
* harbour/source/rtl/gtxwc/gtxwc.c
+ added support for GTI_FULLSCREEN, GTI_KBDSUPPORT, GTI_ISCTWIN
* harbour/source/rtl/hbgtcore.c
! fixed line and box drawing when the coordinates are out of screen size
* harbour/include/hbapi.h
* harbour/include/hbcomp.h
* harbour/include/hbpcode.h
* harbour/include/hbstack.h
* harbour/include/hbvm.h
* harbour/include/hbxvm.h
* harbour/source/compiler/complex.c
* harbour/source/compiler/genc.c
* harbour/source/compiler/gencc.c
* harbour/source/compiler/harbour.c
* harbour/source/compiler/harbour.y
* harbour/source/compiler/harbour.yyc
* harbour/source/compiler/harbour.yyh
* harbour/source/compiler/hbdead.c
* harbour/source/compiler/hbfix.c
* harbour/source/compiler/hblbl.c
* harbour/source/compiler/hbpcode.c
* harbour/source/compiler/hbstripl.c
* harbour/source/vm/classes.c
* harbour/source/vm/estack.c
* harbour/source/vm/hvm.c
* harbour/source/vm/itemapi.c
! added protection against cyclic references in arrays
* eliminated action parameter from hb_vmRequestReenter() /
hb_vmRequestRestore()
* moved s_lRecoverBase and s_uiActionRequest to HB_STACK structure
for future MT HVM version
+ added internal item structure hb_struRecover - it's not real item
but this structure is used to keep information about BEGIN SEQUENCE
data - it reduce HB_STACK usage
+ added support for ALWAYS clause in BEGIN SEQUENCE
The syntax is:
BEGIN SEQUENCE
<code>
[ RECOVER [ USING oErr ] ]
<recoverCode>
[ ALWAYS ]
<alwaysCode>
END [ SEQUENCE ]
It's guaranteed that <alwaysCode> is _ALWAYS_ executed even if
inside <code> or <recoverCode> some new exceptions like RETURN,
BREAK or QUIT will appear.
Please note that when the following code is executed:
BEGIN SEQUENCE
<code>
ALWAYS
<alwaysCode>
END
(without RECOVER clause) then BREAK exception inside <code> is not
recovered, <alwaysCode> is executed and then BREAK exception is
passed to outer BEGIN SEQUENCE. This is the same semantic as
used in TRY / [ CATCH ] / FINALLY / END
Those of you who prefer to use TRY / CATCH / FINALLY / END instead
of BEGIN SEQUENCE / RECOVER / ALWAYS / END can simply add to your
source code:
#command TRY => BEGIN SEQUENCE
#command CATCH [ oErr ] => RECOVER [ USING <oErr> ]
and:
errorBlock( {|oErr| break( oErr ) } )
Though instead of 'break( oErr )' I suggest to use some small function
which will support some basic recovery/substitute operations like in
default errorsys() and LockErrHandler() to not break existing code
which may depends on the default behavior.
If you want I can add direct support for TRY / CATCH / FINALLY / END
but I'm not sure it's really necessary.
Please note also that in Harbour ALWAYS code is execute even for QUIT
excpetion.
When <alwaysCode> is executed current exception is stored and restored
when is finished. If new exception appears inside <alwaysCode> then
restored exception depends on the priority in the following order:
QUIT // highest priority
BREAK
RETURN
If both exceptions have the same priority and contain additional value
(error object in BREAK or return value in RETURN) then the recently set
one is restored. It's similar behavior to destructor code.
* harbour/source/common/hbstr.c
* moved one character length string table (hb_szAscii) from hvm.c
to use it also in compiler and preprocessor
* harbour/source/compiler/ppcomp.c
* harbour/source/pp/ppcore.c
* harbour/source/pp/pplib.c
* tuned error messages to be more Clipper compatible
% use static strings from hb_szAscii
* harbour/source/rtl/alert.prg
* use hb_gtInfo( GTI_FULLSCREEN ) to detect type of GT driver
! some minor fixes
TOFIX: we have to also use GTI_ISCTWIN or add window allocation
to standard GT drivers to be Clipper compatible when CTWIN
is used - In Clipper Tools ALERT() works in differ way then
the standard one. It creates separate window box to display
data, supports SETKEY(), etc. I'll think about adding some
extended support for ALERT() and similar operations (f.e.
separate debugger windows) to GT API so it will be also
possible to overload standard alert() command by GUI message
box in GTGUI and similar GT drivers.
* harbour/source/rtl/binnumx.c
! fixed U2BIN() - wrong casting
440 lines
11 KiB
Plaintext
440 lines
11 KiB
Plaintext
/*
|
|
* $Id$
|
|
*/
|
|
|
|
/*
|
|
* Harbour Project source code:
|
|
* ALERT() function
|
|
*
|
|
* Released to Public Domain by Vladimir Kazimirchik <v_kazimirchik@yahoo.com>
|
|
* www - http://www.harbour-project.org
|
|
*
|
|
*/
|
|
|
|
/*
|
|
* The following parts are Copyright of the individual authors.
|
|
* www - http://www.harbour-project.org
|
|
*
|
|
* Copyright 1999-2001 Viktor Szakats <viktor.szakats@syenar.hu>
|
|
* Changes for higher Clipper compatibility, console mode, extensions
|
|
* __NONOALERT()
|
|
*
|
|
* See doc/license.txt for licensing terms.
|
|
*
|
|
*/
|
|
|
|
#include "hbsetup.ch"
|
|
|
|
#include "box.ch"
|
|
#include "common.ch"
|
|
#include "inkey.ch"
|
|
#include "setcurs.ch"
|
|
#include "hbgtinfo.ch"
|
|
|
|
/* TOFIX: Clipper defines a clipped window for Alert() [vszakats] */
|
|
|
|
/* NOTE: Clipper will return NIL if the first parameter is not a string, but
|
|
this is not documented. This implementation converts the first
|
|
parameter to a string if another type was passed. You can switch back
|
|
to Clipper compatible mode by defining constant
|
|
HB_C52_STRICT. [vszakats] */
|
|
|
|
/* NOTE: Clipper handles these buttons { "Ok", "", "Cancel" } in a buggy way.
|
|
This is fixed. [vszakats] */
|
|
|
|
/* NOTE: nDelay parameter is a Harbour extension. */
|
|
|
|
#ifdef HB_C52_UNDOC
|
|
STATIC s_lNoAlert
|
|
#endif
|
|
|
|
FUNCTION Alert( xMessage, aOptions, cColorNorm, nDelay )
|
|
LOCAL nChoice
|
|
LOCAL aSay
|
|
LOCAL nPos, nMaxWidth, nDefWidth, nWidth, nOpWidth, nInitRow, nInitCol, nEval
|
|
LOCAL nKey, cKey, aPos, nCurrent, aHotkey, aOptionsOK
|
|
LOCAL cColorHigh
|
|
|
|
LOCAL nOldRow
|
|
LOCAL nOldCol
|
|
LOCAL nOldCursor
|
|
LOCAL cOldScreen
|
|
|
|
LOCAL nOldDispCount
|
|
LOCAL nCount
|
|
Local cLine
|
|
|
|
#ifdef HB_COMPAT_C53
|
|
LOCAL nMRow, nMCol
|
|
#endif
|
|
|
|
/* TOFIX: Clipper decides at runtime, whether the full screen GT is
|
|
linked. if it is not, the pure tty mode is choosen here.
|
|
[vszakats] */
|
|
LOCAL lTTY := !hb_gtInfo( GTI_FULLSCREEN )
|
|
|
|
#ifdef HB_C52_UNDOC
|
|
|
|
DEFAULT s_lNoAlert TO hb_argCheck( "NOALERT" )
|
|
|
|
IF s_lNoAlert
|
|
RETURN NIL
|
|
ENDIF
|
|
|
|
#endif
|
|
|
|
aSay := {}
|
|
|
|
nMaxWidth := MaxCol() - 3
|
|
nDefWidth := Int( nMaxWidth / 4 * 3 )
|
|
|
|
#ifdef HB_C52_STRICT
|
|
|
|
IF !ISCHARACTER( xMessage )
|
|
RETURN NIL
|
|
ENDIF
|
|
|
|
DO WHILE Len( xMessage ) != 0
|
|
nPos := At( ';', xMessage )
|
|
IF nPos == 0
|
|
cLine := xMessage
|
|
xMessage := ""
|
|
ELSE
|
|
cLine := Left( xMessage, nPos - 1 )
|
|
xMessage := SubStr( xMessage, nPos + 1 )
|
|
ENDIF
|
|
IF !lTTY
|
|
DO WHILE Len( cLine ) > nDefWidth
|
|
nPos := Rat( ' ', Left( cLine, nDefWidth + 1 ) )
|
|
IF nPos == 0
|
|
nPos := Rat( ' ', Left( cLine, nMaxWidth + 1 ) )
|
|
ENDIF
|
|
IF nPos == 0
|
|
cLine := NIL
|
|
EXIT
|
|
ELSE
|
|
AAdd( aSay, Left( cLine, nPos - 1 ) )
|
|
cLine := SubStr( cLine, nPos + 1 )
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
IF cLine != NIL
|
|
AAdd( aSay, cLine )
|
|
ENDIF
|
|
ENDDO
|
|
|
|
#else
|
|
|
|
IF PCount() == 0
|
|
RETURN NIL
|
|
ENDIF
|
|
|
|
IF ISARRAY( xMessage )
|
|
|
|
FOR nEval := 1 TO Len( xMessage )
|
|
IF ISCHARACTER( cLine := xMessage[ nEval ] )
|
|
IF !lTTY
|
|
DO WHILE Len( cLine ) > nDefWidth
|
|
nPos := Rat( ' ', Left( cLine, nDefWidth + 1 ) )
|
|
IF nPos == 0
|
|
nPos := Rat( ' ', Left( cLine, nMaxWidth + 1 ) )
|
|
ENDIF
|
|
IF nPos == 0
|
|
AAdd( aSay, Left( cLine, nMaxWidth ) )
|
|
cLine := SubStr( cLine, nMaxWidth + 1 )
|
|
ELSE
|
|
AAdd( aSay, Left( cLine, nPos - 1 ) )
|
|
cLine := SubStr( cLine, nPos + 1 )
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
AAdd( aSay, cLine )
|
|
ENDIF
|
|
NEXT
|
|
|
|
ELSE
|
|
|
|
DO CASE
|
|
CASE ValType( xMessage ) $ "CM" /* Do nothing, just speed up things */
|
|
CASE ValType( xMessage ) == "N" ; xMessage := LTrim( Str( xMessage ) )
|
|
CASE ValType( xMessage ) == "D" ; xMessage := DToC( xMessage )
|
|
CASE ValType( xMessage ) == "L" ; xMessage := iif( xMessage, ".T.", ".F." )
|
|
CASE ValType( xMessage ) == "O" ; xMessage := xMessage:className + " Object"
|
|
CASE ValType( xMessage ) == "B" ; xMessage := "{||...}"
|
|
OTHERWISE ; xMessage := "NIL"
|
|
ENDCASE
|
|
|
|
DO WHILE Len( xMessage ) != 0
|
|
nPos := At( ';', xMessage )
|
|
IF nPos == 0
|
|
cLine := xMessage
|
|
xMessage := ""
|
|
ELSE
|
|
cLine := Left( xMessage, nPos - 1 )
|
|
xMessage := SubStr( xMessage, nPos + 1 )
|
|
ENDIF
|
|
IF !lTTY
|
|
DO WHILE Len( cLine ) > nDefWidth
|
|
nPos := Rat( ' ', Left( cLine, nDefWidth + 1 ) )
|
|
IF nPos == 0
|
|
nPos := Rat( ' ', Left( cLine, nMaxWidth + 1 ) )
|
|
ENDIF
|
|
IF nPos == 0
|
|
AAdd( aSay, Left( cLine, nMaxWidth ) )
|
|
cLine := SubStr( cLine, nMaxWidth + 1 )
|
|
ELSE
|
|
AAdd( aSay, Left( cLine, nPos - 1 ) )
|
|
cLine := SubStr( cLine, nPos + 1 )
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
AAdd( aSay, cLine )
|
|
ENDDO
|
|
|
|
ENDIF
|
|
|
|
#endif
|
|
|
|
IF !ISARRAY( aOptions )
|
|
aOptions := {}
|
|
ENDIF
|
|
|
|
IF !ISCHARACTER( cColorNorm ) .or. EMPTY( cColorNorm )
|
|
cColorNorm := "W+/R" // first pair color (Box line and Text)
|
|
cColorHigh := "W+/B" // second pair color (Options buttons)
|
|
ELSE
|
|
cColorHigh := StrTran( StrTran( iif( At( "/", cColorNorm ) == 0, "N", SubStr( cColorNorm, At( "/", cColorNorm ) + 1 ) ) + "/" +;
|
|
iif( At( "/", cColorNorm ) == 0, cColorNorm, Left( cColorNorm, At( "/", cColorNorm ) - 1 ) ), "+", "" ), "*", "" )
|
|
ENDIF
|
|
|
|
IF nDelay == NIL
|
|
nDelay := 0
|
|
ENDIF
|
|
|
|
/* The longest line */
|
|
nWidth := 0
|
|
AEval( aSay, {| x | nWidth := Max( Len( x ), nWidth ) } )
|
|
|
|
/* Cleanup the button array */
|
|
aOptionsOK := {}
|
|
FOR nEval := 1 TO Len( aOptions )
|
|
IF ISCHARACTER( aOptions[ nEval ] ) .AND. !Empty( aOptions[ nEval ] )
|
|
AAdd( aOptionsOK, aOptions[ nEval ] )
|
|
ENDIF
|
|
NEXT
|
|
|
|
IF Len( aOptionsOK ) == 0
|
|
aOptionsOK := { 'Ok' }
|
|
#ifdef HB_C52_STRICT
|
|
/* NOTE: Clipper allows only four options [vszakats] */
|
|
ELSEIF Len( aOptionsOK ) > 4
|
|
aSize( aOptionsOK, 4 )
|
|
#endif
|
|
ENDIF
|
|
|
|
/* Total width of the botton line (the one with choices) */
|
|
nOpWidth := 0
|
|
AEval( aOptionsOK, {| x | nOpWidth += Len( x ) + 4 } )
|
|
|
|
/* what's wider ? */
|
|
nWidth := Max( nWidth + 2 + iif( Len( aSay ) == 1, 4, 0 ), nOpWidth + 2 )
|
|
|
|
/* box coordinates */
|
|
nInitRow := Int( ( ( MaxRow() - ( Len( aSay ) + 4 ) ) / 2 ) + .5 )
|
|
nInitCol := Int( ( ( MaxCol() - ( nWidth + 2 ) ) / 2 ) + .5 )
|
|
|
|
/* detect prompts positions */
|
|
aPos := {}
|
|
aHotkey := {}
|
|
nCurrent := nInitCol + Int( ( nWidth - nOpWidth ) / 2 ) + 2
|
|
IF nCurrent < 0
|
|
nCurrent := 0
|
|
ENDIF
|
|
AEval( aOptionsOK, {| x | AAdd( aPos, nCurrent ), AAdd( aHotKey, Upper( Left( x, 1 ) ) ), nCurrent += Len( x ) + 4 } )
|
|
|
|
nChoice := 1
|
|
|
|
IF lTTY
|
|
|
|
FOR nEval := 1 TO Len( aSay )
|
|
OutStd( aSay[ nEval ] )
|
|
IF nEval < Len( aSay )
|
|
OutStd( hb_OSNewLine() )
|
|
ENDIF
|
|
NEXT
|
|
|
|
OutStd( " (" )
|
|
FOR nEval := 1 TO Len( aOptionsOK )
|
|
OutStd( aOptionsOK[ nEval ] )
|
|
IF nEval < Len( aOptionsOK )
|
|
OutStd( ", " )
|
|
ENDIF
|
|
NEXT
|
|
OutStd( ") " )
|
|
|
|
/* choice loop */
|
|
DO WHILE .T.
|
|
|
|
nKey := iif( hb_gtInfo( GTI_KBDSUPPORT ), ;
|
|
Inkey( nDelay, INKEY_ALL ), 0 )
|
|
|
|
DO CASE
|
|
|
|
CASE nKey == 0
|
|
IF Len( aHotkey ) > 0
|
|
nChoice := 1
|
|
ENDIF
|
|
EXIT
|
|
|
|
CASE nKey == K_ESC
|
|
|
|
nChoice := 0
|
|
EXIT
|
|
|
|
CASE nKey >= 32 .AND. nKey <= 255
|
|
|
|
cKey := Upper( Chr( nKey ) )
|
|
nChoice := aScan( aHotkey, {| x | x == cKey } )
|
|
IF nChoice != 0
|
|
EXIT
|
|
ENDIF
|
|
|
|
ENDCASE
|
|
|
|
ENDDO
|
|
|
|
IF nKey >= 32 && nKey <= 255
|
|
OutStd( Chr( nKey ) )
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
/* PreExt */
|
|
nCount := nOldDispCount := DispCount()
|
|
|
|
DO WHILE nCount-- != 0
|
|
DispEnd()
|
|
ENDDO
|
|
|
|
/* save status */
|
|
nOldRow := Row()
|
|
nOldCol := Col()
|
|
nOldCursor := SetCursor( SC_NONE )
|
|
cOldScreen := SaveScreen( nInitRow, nInitCol, nInitRow + Len( aSay ) + 3, nInitCol + nWidth + 1 )
|
|
|
|
DispBegin()
|
|
/* draw box */
|
|
//Fixed box characters cannot be displayed correctly on some terminals
|
|
//(e.g. xterm)
|
|
//DispBox( nInitRow, nInitCol, nInitRow + Len( aSay ) + 3, nInitCol + nWidth + 1, B_SINGLE + ' ', cColorNorm )
|
|
|
|
@ nInitRow, nInitCol TO nInitRow + Len( aSay ) + 3, nInitCol + nWidth + 1 COLOR cColorNorm
|
|
DispBox( nInitRow + 1, nInitCol + 1, nInitRow + Len( aSay ) + 2, nInitCol + nWidth, " ", cColorNorm )
|
|
|
|
FOR nEval := 1 TO Len( aSay )
|
|
DispOutAt( nInitRow + nEval, nInitCol + 1 + Int( ( ( nWidth - Len( aSay[ nEval ] ) ) / 2 ) + .5 ), aSay[ nEval ], cColorNorm )
|
|
NEXT
|
|
|
|
/* choice loop */
|
|
DO WHILE .T.
|
|
|
|
FOR nEval := 1 TO Len( aOptionsOK )
|
|
DispOutAt( nInitRow + Len( aSay ) + 2, aPos[ nEval ], " " + aOptionsOK[ nEval ] + " ",;
|
|
iif( nEval == nChoice, cColorHigh, cColorNorm ) )
|
|
NEXT
|
|
DispEnd()
|
|
|
|
nKey := Inkey( nDelay, INKEY_ALL )
|
|
|
|
DO CASE
|
|
CASE nKey == K_ENTER .OR. ;
|
|
nKey == K_SPACE .OR. ;
|
|
nKey == 0
|
|
|
|
EXIT
|
|
|
|
CASE nKey == K_ESC
|
|
|
|
nChoice := 0
|
|
EXIT
|
|
|
|
#ifdef HB_COMPAT_C53
|
|
|
|
CASE nKey == K_LBUTTONDOWN
|
|
|
|
nMRow := MRow()
|
|
nMCol := MCol()
|
|
|
|
FOR nEval := 1 TO Len( aOptionsOK )
|
|
IF nMRow == nInitRow + Len( aSay ) + 2 .AND. ;
|
|
nMCol >= aPos[ nEval ] .AND. nMCol <= aPos[ nEval ] + ;
|
|
Len( aOptionsOK[ nEval ] ) + 2 - 1
|
|
nChoice := nEval
|
|
EXIT
|
|
ENDIF
|
|
NEXT
|
|
|
|
IF nChoice == nEval
|
|
nChoice := 0
|
|
EXIT
|
|
ENDIF
|
|
|
|
#endif
|
|
|
|
CASE ( nKey == K_LEFT .OR. nKey == K_SH_TAB ) .AND. Len( aOptionsOK ) > 1
|
|
|
|
nChoice--
|
|
IF nChoice == 0
|
|
nChoice := Len( aOptionsOK )
|
|
ENDIF
|
|
|
|
nDelay := 0
|
|
|
|
CASE ( nKey == K_RIGHT .OR. nKey == K_TAB ) .AND. Len( aOptionsOK ) > 1
|
|
|
|
nChoice++
|
|
IF nChoice > Len( aOptionsOK )
|
|
nChoice := 1
|
|
ENDIF
|
|
|
|
nDelay := 0
|
|
|
|
CASE nKey > 32 .AND. nKey <= 255
|
|
|
|
cKey := Upper( Chr( nKey ) )
|
|
nChoice := aScan( aHotkey, {| x | x == cKey } )
|
|
IF nChoice != 0
|
|
EXIT
|
|
ENDIF
|
|
|
|
ENDCASE
|
|
|
|
DispBegin()
|
|
|
|
ENDDO
|
|
|
|
/* Restore status */
|
|
RestScreen( nInitRow, nInitCol, nInitRow + Len( aSay ) + 3, nInitCol + nWidth + 1, cOldScreen )
|
|
SetCursor( nOldCursor )
|
|
SetPos( nOldRow, nOldCol )
|
|
|
|
/* PostExt */
|
|
DO WHILE nOldDispCount-- != 0
|
|
DispBegin()
|
|
ENDDO
|
|
|
|
ENDIF
|
|
|
|
RETURN nChoice
|
|
|
|
#ifdef HB_C52_UNDOC
|
|
|
|
PROCEDURE __NONOALERT()
|
|
|
|
s_lNoAlert := .F.
|
|
|
|
RETURN
|
|
|
|
#endif
|
|
|