Files
harbour-core/harbour/source/rtl/alert.prg
Viktor Szakats 11aa4eb482 2008-06-14 09:13 UTC+0200 Viktor Szakats (harbour.01 syenar hu)
* contrib/hbbmcdx/bmdbfcdx1.c
   * contrib/hbct/ctnet.c
   * contrib/hbct/pos2.c
   * contrib/hbgf/gtk/creabutt.c
   * contrib/hbgf/gtk/creawin.c
   * contrib/hbgt/bitflags.c
   * contrib/hbmisc/stringsx.c
   * contrib/hbtip/encmthd.c
   * contrib/hbtip/utils.c
   * contrib/hbw32/w32_ole.c
   * contrib/hbwhat32/_wincdlg.c
   * contrib/hbwhat32/_winclpb.c
   * contrib/hbwhat32/_wintree.c
   * contrib/rddads/ads1.c
   * contrib/xhb/xstrdel.c
   * source/rdd/dbcmd.c
   * source/rdd/dbf1.c
   * source/rdd/dbfcdx/dbfcdx1.c
   * source/rdd/dbffpt/dbffpt1.c
   * source/rdd/dbfntx/dbfntx1.c
   * source/rdd/delim1.c
   * source/rdd/hbsix/sxsem.c
   * source/rdd/sdf1.c
   * source/rdd/workarea.c
   * source/rtl/alert.prg
   * source/rtl/errorsys.prg
   * source/rtl/gtcrs/gtcrs.c
   * source/rtl/gtgui/gtgui.c
   * source/rtl/gtsln/gtsln.c
   * source/rtl/gtwin/gtwin.c
   * source/rtl/gtxwc/gtxwc.c
   * source/rtl/hbgtcore.c
   * source/rtl/hbregex.c
   * source/vm/cmdarg.c
   * source/vm/dynsym.c
     ! LUPDATE() buffer overread fixed. (hb_retds(""))
     % hb_itemPutC*()/hb_retc*()/hb_errInternal() "" parameter -> NULL
       NOTE: gtwvg not changed.
     * Few minor cleanups.
     * Some formatting in ads1.c.
       (verified to result in no actual codeflow change)
     ; TODO: hb_retc( NULL ) -> hb_retc_null()
2008-06-14 07:19:56 +00:00

154 lines
3.8 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 "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 undefining constant HB_EXTENSION. [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 cMessage
LOCAL cColorHigh
LOCAL aOptionsOK
LOCAL nEval
#ifdef HB_EXTENSION
LOCAL lFirst
LOCAL cLine
#endif
#ifdef HB_C52_UNDOC
DEFAULT s_lNoAlert TO hb_argCheck( "NOALERT" )
IF s_lNoAlert
RETURN NIL
ENDIF
#endif
#ifdef HB_EXTENSION
IF PCount() == 0
RETURN NIL
ENDIF
cMessage := ""
IF ISARRAY( xMessage )
lFirst := .T.
FOR nEval := 1 TO Len( xMessage )
IF ISCHARACTER( cLine := xMessage[ nEval ] )
cMessage += iif( lFirst, "", Chr( 10 ) ) + cLine
lFirst := .F.
ENDIF
NEXT
ELSE
DO CASE
CASE ValType( xMessage ) $ "CM" ; cMessage := StrTran( xMessage, ";", Chr( 10 ) )
CASE ValType( xMessage ) == "N" ; cMessage := LTrim( Str( xMessage ) )
CASE ValType( xMessage ) == "D" ; cMessage := DToC( xMessage )
CASE ValType( xMessage ) == "L" ; cMessage := iif( xMessage, ".T.", ".F." )
CASE ValType( xMessage ) == "O" ; cMessage := xMessage:className + " Object"
CASE ValType( xMessage ) == "S" ; cMessage := "@" + xMessage:Name + "()"
CASE ValType( xMessage ) == "B" ; cMessage := "{||...}"
OTHERWISE ; cMessage := "NIL"
ENDCASE
ENDIF
#else
IF !ISCHARACTER( xMessage )
RETURN NIL
ENDIF
cMessage := StrTran( xMessage, ";", Chr( 10 ) )
#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
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
RETURN hb_gtAlert( cMessage, aOptionsOK, cColorNorm, cColorHigh, nDelay );
#ifdef HB_C52_UNDOC
PROCEDURE __NONOALERT()
s_lNoAlert := .F.
RETURN
#endif