diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 5c42060dbb..9812f0befb 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,18 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +2007-09-17 13:26 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) + * tests/rto_get.prg + * tests/rto_tb.prg + * source/rtl/gui.prg + + source/rtl/tbrowsys.prg + * source/rtl/tmenusys.prg + * source/rtl/menusys.prg + * source/rtl/tscalar.prg + * source/rtl/tbrowse.prg + + Added missing file from previous commit. + + Set Id keyword and eol-style to native on newly added files. + 2007-09-17 12:34 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) * source/rtl/tscalar.prg ! Some fixes for previous commit regarding scalar classes. diff --git a/harbour/source/rtl/gui.prg b/harbour/source/rtl/gui.prg index f047248c6f..1aff65e777 100644 --- a/harbour/source/rtl/gui.prg +++ b/harbour/source/rtl/gui.prg @@ -1,106 +1,106 @@ -/* - * $Id: checkbox.prg 7155 2007-04-14 10:41:54Z vszakats $ - */ - -/* - * Harbour Project source code: - * GUI helper functions - * - * Copyright 2000 Luiz Rafael Culik - * www - http://www.harbour-project.org - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ - -#include "common.ch" - -#ifdef HB_COMPAT_C53 - -#define LLG_VIDEO_TXT 3 - -FUNCTION _IsGraphic() - RETURN Set( _SET_VIDEOMODE ) != NIL .AND. ; - Set( _SET_VIDEOMODE ) != 0 .AND. ; - Set( _SET_VIDEOMODE ) != LLG_VIDEO_TXT - -FUNCTION _SetVideoMode( nMode ) - - HB_SYMBOL_UNUSED( nMode ) - - RETURN 0 - -FUNCTION _GetNumCol( cColor ) - LOCAL nPos - - IF ( nPos := At( "/", cColor ) ) > 0 - cColor := Left( cColor, nPos - 1 ) - ENDIF - IF ( nPos := At( ",", cColor ) ) > 0 - cColor := Left( cColor, nPos - 1 ) - ENDIF - #ifndef HB_C52_STRICT - cColor := Upper( cColor ) - #endif - - RETURN AScan( { "B", "G", "BG", "R", "RB", "GR", "W", "N+", "B+", "G+", "BG+", "R+", "RB+", "GR+", "W+" }, {| tmp | tmp == cColor } ) - -FUNCTION __GUIColor( cColor, nPos ) - RETURN hb_ColorIndex( cColor, nPos - 1 ) - -FUNCTION IsDefColor() - RETURN SetColor() == "W/N,N/W,N/N,N/N,N/W" /* NOTE: Color must match with the one in set.c */ - -/* Removes the accelerator marker from a caption string */ -FUNCTION __Caption( cCaption ) - LOCAL nPos - - RETURN iif( ( nPos := At( "&", cCaption ) ) > 0, Stuff( cCaption, nPos, 1, "" ), cCaption ) - -FUNCTION __CapLength( cCaption ) - LOCAL nCaptionLen := Len( cCaption ) - LOCAL nPos - - RETURN iif( ( nPos := At( "&", cCaption ) ) > 0 .AND. nPos < nCaptionLen, nCaptionLen - 1, nCaptionLen ) - -FUNCTION __CapMetrics( o ) - RETURN __CapLength( o:caption ) + iif( o:isPopup(), 3, 2 ) - -#endif +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * GUI helper functions + * + * Copyright 2000 Luiz Rafael Culik + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "common.ch" + +#ifdef HB_COMPAT_C53 + +#define LLG_VIDEO_TXT 3 + +FUNCTION _IsGraphic() + RETURN Set( _SET_VIDEOMODE ) != NIL .AND. ; + Set( _SET_VIDEOMODE ) != 0 .AND. ; + Set( _SET_VIDEOMODE ) != LLG_VIDEO_TXT + +FUNCTION _SetVideoMode( nMode ) + + HB_SYMBOL_UNUSED( nMode ) + + RETURN 0 + +FUNCTION _GetNumCol( cColor ) + LOCAL nPos + + IF ( nPos := At( "/", cColor ) ) > 0 + cColor := Left( cColor, nPos - 1 ) + ENDIF + IF ( nPos := At( ",", cColor ) ) > 0 + cColor := Left( cColor, nPos - 1 ) + ENDIF + #ifndef HB_C52_STRICT + cColor := Upper( cColor ) + #endif + + RETURN AScan( { "B", "G", "BG", "R", "RB", "GR", "W", "N+", "B+", "G+", "BG+", "R+", "RB+", "GR+", "W+" }, {| tmp | tmp == cColor } ) + +FUNCTION __GUIColor( cColor, nPos ) + RETURN hb_ColorIndex( cColor, nPos - 1 ) + +FUNCTION IsDefColor() + RETURN SetColor() == "W/N,N/W,N/N,N/N,N/W" /* NOTE: Color must match with the one in set.c */ + +/* Removes the accelerator marker from a caption string */ +FUNCTION __Caption( cCaption ) + LOCAL nPos + + RETURN iif( ( nPos := At( "&", cCaption ) ) > 0, Stuff( cCaption, nPos, 1, "" ), cCaption ) + +FUNCTION __CapLength( cCaption ) + LOCAL nCaptionLen := Len( cCaption ) + LOCAL nPos + + RETURN iif( ( nPos := At( "&", cCaption ) ) > 0 .AND. nPos < nCaptionLen, nCaptionLen - 1, nCaptionLen ) + +FUNCTION __CapMetrics( o ) + RETURN __CapLength( o:caption ) + iif( o:isPopup(), 3, 2 ) + +#endif diff --git a/harbour/source/rtl/menusys.prg b/harbour/source/rtl/menusys.prg index 312c30d115..cb749c607f 100644 --- a/harbour/source/rtl/menusys.prg +++ b/harbour/source/rtl/menusys.prg @@ -1,173 +1,173 @@ -/* - * $Id: mssgline.prg 7155 2007-04-14 10:41:54Z vszakats $ - */ - -/* - * Harbour Project source code: - * MENUSYS parts - * - * Copyright 2002 Larry Sevilla - * www - http://www.harbour-project.org - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ - -#include "hbclass.ch" - -#include "common.ch" -#include "getexit.ch" -#include "inkey.ch" -#include "setcurs.ch" - -/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but - it has all related variables and methods. */ - -#ifdef HB_COMPAT_C53 - -/* Standard Menu System Modal handling for Menu Items */ -FUNCTION MenuModal( oTopMenu, nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) - RETURN HBMenuSys():New( oTopMenu ):modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) - -/* Dummy function */ -FUNCTION ShowMsg( aMsg, lMode ) - - HB_SYMBOL_UNUSED( aMsg ) - HB_SYMBOL_UNUSED( lMode ) - - RETURN .F. - -/*** -* -* ShortCut processing for initial Get or Menu Item. -* -***/ -FUNCTION IsShortCut( oMenu, nKey, nID ) - LOCAL nItem - LOCAL nTotal - LOCAL nShortCut - LOCAL oItem - LOCAL i - - // Test for top menu item not a TopBar Menu: - IF !( oMenu:ClassName() == "TOPBARMENU" ) - - RETURN IsQuick( oMenu, nKey, @nID ) - - // Test and assign top menu item shortCut, enabled, and !PopUp: - // Changed by enclosing assignment before ':Enabled': - ELSEIF ( nShortCut := oMenu:getShortCt( nKey ) ) > 0 .AND. ; - ( oItem := oMenu:getItem( nShortcut ) ):enabled .AND. ; - !oItem:isPopUp() - - oMenu:select( nShortCut ) - Eval( oItem:data, oItem ) - nID := oItem:ID - - RETURN .T. - - // Test and assignment for TopBar MenuItem: - ELSEIF nShortCut == 0 - - nTotal := oMenu:itemCount - nItem := oMenu:current - - IF nItem == 0 - nItem := 1 - ENDIF - - // Loop to wrap around through TopMenu from Current Item: - FOR i := 1 TO nTotal - - IF ( oItem := oMenu:getItem( nItem ) ):enabled .AND. ; - oItem:isPopUp() .AND. ; - IsQuick( oItem:data, nKey, @nID ) - - RETURN .T. - ENDIF - - IF ++nItem > nTotal - nItem := 1 - ENDIF - NEXT - - ENDIF - - RETURN .F. - -/*** -* -* Navigates to the next Get or Menu Item from the -* Current if more than one uses the same ShortCut. -* -***/ -FUNCTION IsQuick( oMenu, nKey, nID ) - LOCAL nItem - LOCAL nTotal - LOCAL nShortCut - LOCAL oItem - - IF ( nShortCut := oMenu:getShortCt( nKey ) ) == 0 - - nTotal := oMenu:itemCount - - FOR nItem := 1 TO nTotal - - IF ( oItem := oMenu:getItem( nItem ) ):enabled .AND. ; - oItem:isPopUp() .AND. ; - IsQuick( oItem:data, nKey, @nID ) - - RETURN .T. - ENDIF - NEXT - - ELSEIF !( oItem := oMenu:getItem( nShortCut ) ):isPopUp() .AND. oItem:enabled - - oMenu:select( nShortCut ) - Eval( oItem:data, oItem ) - nID := oItem:ID - - RETURN .T. - - ENDIF - - RETURN .F. - -#endif +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * MENUSYS parts + * + * Copyright 2002 Larry Sevilla + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "hbclass.ch" + +#include "common.ch" +#include "getexit.ch" +#include "inkey.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +#ifdef HB_COMPAT_C53 + +/* Standard Menu System Modal handling for Menu Items */ +FUNCTION MenuModal( oTopMenu, nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) + RETURN HBMenuSys():New( oTopMenu ):modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) + +/* Dummy function */ +FUNCTION ShowMsg( aMsg, lMode ) + + HB_SYMBOL_UNUSED( aMsg ) + HB_SYMBOL_UNUSED( lMode ) + + RETURN .F. + +/*** +* +* ShortCut processing for initial Get or Menu Item. +* +***/ +FUNCTION IsShortCut( oMenu, nKey, nID ) + LOCAL nItem + LOCAL nTotal + LOCAL nShortCut + LOCAL oItem + LOCAL i + + // Test for top menu item not a TopBar Menu: + IF !( oMenu:ClassName() == "TOPBARMENU" ) + + RETURN IsQuick( oMenu, nKey, @nID ) + + // Test and assign top menu item shortCut, enabled, and !PopUp: + // Changed by enclosing assignment before ':Enabled': + ELSEIF ( nShortCut := oMenu:getShortCt( nKey ) ) > 0 .AND. ; + ( oItem := oMenu:getItem( nShortcut ) ):enabled .AND. ; + !oItem:isPopUp() + + oMenu:select( nShortCut ) + Eval( oItem:data, oItem ) + nID := oItem:ID + + RETURN .T. + + // Test and assignment for TopBar MenuItem: + ELSEIF nShortCut == 0 + + nTotal := oMenu:itemCount + nItem := oMenu:current + + IF nItem == 0 + nItem := 1 + ENDIF + + // Loop to wrap around through TopMenu from Current Item: + FOR i := 1 TO nTotal + + IF ( oItem := oMenu:getItem( nItem ) ):enabled .AND. ; + oItem:isPopUp() .AND. ; + IsQuick( oItem:data, nKey, @nID ) + + RETURN .T. + ENDIF + + IF ++nItem > nTotal + nItem := 1 + ENDIF + NEXT + + ENDIF + + RETURN .F. + +/*** +* +* Navigates to the next Get or Menu Item from the +* Current if more than one uses the same ShortCut. +* +***/ +FUNCTION IsQuick( oMenu, nKey, nID ) + LOCAL nItem + LOCAL nTotal + LOCAL nShortCut + LOCAL oItem + + IF ( nShortCut := oMenu:getShortCt( nKey ) ) == 0 + + nTotal := oMenu:itemCount + + FOR nItem := 1 TO nTotal + + IF ( oItem := oMenu:getItem( nItem ) ):enabled .AND. ; + oItem:isPopUp() .AND. ; + IsQuick( oItem:data, nKey, @nID ) + + RETURN .T. + ENDIF + NEXT + + ELSEIF !( oItem := oMenu:getItem( nShortCut ) ):isPopUp() .AND. oItem:enabled + + oMenu:select( nShortCut ) + Eval( oItem:data, oItem ) + nID := oItem:ID + + RETURN .T. + + ENDIF + + RETURN .F. + +#endif diff --git a/harbour/source/rtl/tbrowse.prg b/harbour/source/rtl/tbrowse.prg index 607eb44e26..a35e07784f 100644 --- a/harbour/source/rtl/tbrowse.prg +++ b/harbour/source/rtl/tbrowse.prg @@ -467,6 +467,8 @@ METHOD addColumn( oCol ) CLASS TBrowse // Insert a column object in a browse METHOD insColumn( nPos, oCol ) CLASS TBrowse + /* NOTE: CA-Cl*pper does no checks at all on the parameters. */ + if nPos >= 1 ::Moved() /* TOFIX: This logic should go inside ::configure() */ @@ -513,21 +515,27 @@ METHOD setColumn( nPos, oCol ) CLASS TBrowse LOCAL oOldCol - /* NOTE: CA-Cl*pper doesn't check this, but crashes instead. */ + if nPos != NIL .AND. oCol != NIL - if nPos >= 1 .and. nPos <= ::nColumns + nPos := _eInstVar( Self, "COLUMN", nPos, "N", 1001 ) + oCol := _eInstVar( Self, "COLUMN", oCol, "O", 1001 ) - ::Moved() /* TOFIX: This logic should go inside ::configure() */ + /* NOTE: CA-Cl*pper doesn't check nPos range (and type in C5.3), but crashes instead. */ - oOldCol := ::aColumns[ nPos ] + if nPos >= 1 .AND. nPos <= ::nColumns - ::aColumns[ nPos ] := oCol - ::aColsWidth[ nPos ] := ::SetColumnWidth( oCol ) - ::aColsPos[ nPos ] := 0 - ::aColsInfo[ nPos ] := ::InitColumn( oCol, .F. ) - - ::Configure( 2 ) + ::Moved() /* TOFIX: This logic should go inside ::configure() */ + + oOldCol := ::aColumns[ nPos ] + + ::aColumns[ nPos ] := oCol + ::aColsWidth[ nPos ] := ::SetColumnWidth( oCol ) + ::aColsPos[ nPos ] := 0 + ::aColsInfo[ nPos ] := ::InitColumn( oCol, .F. ) + + ::Configure( 2 ) + endif endif /* NOTE: CA-Cl*pper 5.2 NG says this will return the previously set diff --git a/harbour/source/rtl/tbrowsys.prg b/harbour/source/rtl/tbrowsys.prg new file mode 100644 index 0000000000..2ffc5ab05c --- /dev/null +++ b/harbour/source/rtl/tbrowsys.prg @@ -0,0 +1,167 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * TBrowse() CA-Cl*pper 5.3 functions + * + * Copyright 2007 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#ifdef HB_COMPAT_C53 + +#include "button.ch" +#include "common.ch" +#include "tbrowse.ch" + +PROCEDURE TBReader( oGet, oGetList, oMenu, aMsg ) + + IF !ISOBJECT( oGetList ) + oGetList := __GetListActive() + ENDIF + + IF oGetList != NIL + oGetlist:TBReader( oGet, oMenu, aMsg ) + ENDIF + + RETURN + +FUNCTION TBMouse( oBrowse, nMRow, nMCol ) + + LOCAL n + + IF oBrowse:hitTest( nMRow, nMCol ) == HTCELL + + n := oBrowse:mRowPos - oBrowse:rowPos + DO WHILE n < 0 + n++ + oBrowse:up() + ENDDO + DO WHILE n > 0 + n-- + oBrowse:down() + ENDDO + + n := oBrowse:mColPos - oBrowse:colPos + DO WHILE n < 0 + n++ + oBrowse:left() + ENDDO + DO WHILE n > 0 + n-- + oBrowse:right() + ENDDO + + RETURN TBR_CONTINUE + ENDIF + + RETURN TBR_EXCEPTION + +FUNCTION TApplyKey( nKey, oBrowse ) + + RETURN oBrowse:applyKey( nKey ) + +FUNCTION TBAddCol() + /* TODO */ + RETURN NIL + +FUNCTION TBApplyKey() + /* TODO */ + RETURN NIL + +FUNCTION TBBBlock() + /* TODO */ + RETURN NIL + +FUNCTION TBClose() + /* TODO */ + RETURN NIL + +FUNCTION TBCreate() + /* TODO */ + RETURN NIL + +FUNCTION TBDelCol() + /* TODO */ + RETURN NIL + +FUNCTION TBDisplay() + /* TODO */ + RETURN NIL + +FUNCTION TBEditCell() + /* TODO */ + RETURN NIL + +FUNCTION TBFBlock() + /* TODO */ + RETURN NIL + +FUNCTION TBGoBot() + /* TODO */ + RETURN NIL + +FUNCTION TBGoTop() + /* TODO */ + RETURN NIL + +FUNCTION TBInsCol() + /* TODO */ + RETURN NIL + +FUNCTION TBModal() + /* TODO */ + RETURN NIL + +FUNCTION TBSBlock() + /* TODO */ + RETURN NIL + +FUNCTION TBSkip() + /* TODO */ + RETURN NIL + +#endif + diff --git a/harbour/source/rtl/tmenusys.prg b/harbour/source/rtl/tmenusys.prg index ba67716ba3..b9b5bfa4db 100644 --- a/harbour/source/rtl/tmenusys.prg +++ b/harbour/source/rtl/tmenusys.prg @@ -1,662 +1,662 @@ -/* - * $Id: mssgline.prg 7155 2007-04-14 10:41:54Z vszakats $ - */ - -/* - * Harbour Project source code: - * TMENUSYS class - * - * Copyright 2002 Larry Sevilla - * www - http://www.harbour-project.org - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ - -#include "hbclass.ch" - -#include "common.ch" -#include "getexit.ch" -#include "inkey.ch" -#include "setcurs.ch" - -/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but - it has all related variables and methods. */ - -#ifdef HB_COMPAT_C53 - -/* Some helper contants for the ReadStats() calls. */ -#define SNLASTEXIT 6 -#define SNNEXTGET 12 - -/* Class to simulate menusys.prg of CA-Cl*pper 5.3 */ - -CREATE CLASS HBMenuSys - - EXPORT: - - METHOD Modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) - METHOD New( oMenu ) - - PROTECTED: - - METHOD PushMenu() - METHOD PopMenu() - METHOD PopChild( nNewLevel ) - METHOD PopAll() - METHOD Execute() - METHOD MHitTest( oNewMenu, nNewLevel, nNewItem ) - METHOD ShowMsg( lMode ) - METHOD GetMsgArray() - - VAR oMenu - VAR lOldMsgFlag - VAR cOldMessage - VAR aMenuList - VAR nMenuLevel - VAR nOldRow - VAR nOldCol - VAR nOldCursor - VAR lMsgFlag - VAR nMsgRow - VAR nMsgLeft - VAR nMsgRight - VAR cMsgColor - VAR cMsgSaveS - -ENDCLASS - -/*** -* -* Standard Menu System Modal handling for Menu Items -* -***/ -METHOD Modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) CLASS HBMenuSys - - LOCAL oTopMenu := ::oMenu - - LOCAL nReturn := 0 - - LOCAL nKey - LOCAL nNewItem - LOCAL lLeftDown - LOCAL oNewMenu - LOCAL nNewLevel - LOCAL nEvent - LOCAL oMenuItem - LOCAL nMenuItem - LOCAL nTemp - LOCAL bKeyBlock - LOCAL lSubMenu - - ::nOldRow := Row() - ::nOldCol := Col() - ::nOldCursor := SetCursor( SC_NONE ) - - ::nMsgRow := nMsgRow - ::nMsgLeft := nMsgLeft - ::nMsgRight := nMsgRight - ::cMsgColor := cMsgColor - - IF ( ::lMsgFlag := ISNUMBER( ::nMsgRow ) .AND. ; - ISNUMBER( ::nMsgLeft ) .AND. ; - ISNUMBER( ::nMsgRight ) ) - - IF !ISCHARACTER( ::cMsgColor ) - ::cMsgColor := GetClrPair( SetColor(), 1 ) - ENDIF - - Scroll( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight ) - - ::cMsgSaveS := SaveScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight ) - - ENDIF - - oTopMenu:select( nSelection ) - - IF !( oTopMenu:ClassName() == "TOPBARMENU" ) .AND. !oTopMenu:isOpen - oTopMenu:open() - ELSE - oTopMenu:display() - ENDIF - - IF nSelection <= 0 - - DO WHILE nSelection <= 0 - - nEvent := Set( _SET_EVENTMASK, INKEY_KEYBOARD + INKEY_LDOWN ) - nKey := Inkey( 0 ) - Set( _SET_EVENTMASK, nEvent ) - - IF nKey == K_LBUTTONDOWN .OR. nKey == K_LDBLCLK - nSelection := oTopMenu:hitTest( MRow(), MCol() ) - - ELSEIF ( nSelection := oTopMenu:getAccel( nKey ) ) != 0 - - ELSEIF IsShortCut( oTopMenu, nKey, @nReturn ) - RETURN nReturn - - ELSE - nSelection := 1 - - ENDIF - - ENDDO - - oTopMenu:select( nSelection ) - oTopMenu:display() - - ENDIF - - IF !oTopMenu:getItem( nSelection ):enabled - RETURN 0 - ENDIF - - ::aMenuList := Array( 16 ) - ::nMenuLevel := 1 - ::aMenuList[ 1 ] := ::oMenu - - lLeftDown := MLeftDown() - - ::ShowMsg( .T. ) - - DO WHILE .T. - - nKey := Inkey( 0 ) - - IF ( bKeyBlock := SetKey( nKey ) ) != NIL - Eval( bKeyBlock, ProcName( 1 ), ProcLine( 1 ), "" ) - LOOP - ENDIF - - DO CASE - CASE nKey == K_MOUSEMOVE - - IF lLeftDown - - IF !::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) // ; hit nowhere. - - ELSEIF nNewLevel != ::nMenuLevel // ; menu level change. - - IF nNewItem != oNewMenu:current .AND. oNewMenu:GetItem( nNewItem ):enabled - ::oMenu := oNewMenu - ::PopChild( nNewLevel ) - ::oMenu:select( nNewItem ) - ::oMenu:display() - ::PushMenu() - ::ShowMsg( .T. ) - ENDIF - - ELSEIF nNewItem != oNewMenu:Current() // ; menu item change. - - ::PopChild( ::nMenuLevel ) - - IF ::oMenu:getItem( nNewItem ):enabled - ::oMenu:select( nNewItem ) - ::oMenu:display() - ::PushMenu() - ::ShowMsg( .T. ) - ENDIF - - ENDIF - - ENDIF - - CASE nKey == K_DOWN - - IF ::oMenu:ClassName() == "TOPBARMENU" - IF ::PushMenu() - ::ShowMsg( .T. ) - ENDIF - ELSE - nTemp := ::oMenu:getNext() - IF nTemp == 0 - nTemp := ::oMenu:getFirst() - ENDIF - ::oMenu:select( nTemp ) - ::oMenu:display() - ::ShowMsg( .T. ) - ENDIF - - CASE nKey == K_UP - - IF !( ::oMenu:ClassName() == "TOPBARMENU" ) - nTemp := ::oMenu:getPrev() - IF nTemp == 0 - nTemp := ::oMenu:getLast() - ENDIF - ::oMenu:select( nTemp ) - ::oMenu:display() - ::ShowMsg( .T. ) - - ENDIF - - CASE nKey == K_LEFT - - IF ( lSubMenu := ( ::nMenuLevel > 1 ) ) - ::PopMenu() - ENDIF - IF ::oMenu:ClassName() == "TOPBARMENU" - nTemp := ::oMenu:getPrev() - IF nTemp == 0 - nTemp := ::oMenu:getLast() - ENDIF - ::oMenu:select( nTemp ) - ::oMenu:display() - IF lSubMenu - ::PushMenu() - ENDIF - ENDIF - ::ShowMsg( .T. ) - - CASE nKey == K_RIGHT - - IF ( lSubMenu := ( ::nMenuLevel > 1 ) ) - ::PopMenu() - ENDIF - - IF ::oMenu:ClassName() == "TOPBARMENU" - nTemp := ::oMenu:getNext() - IF nTemp == 0 - nTemp := ::oMenu:getFirst() - ENDIF - ::oMenu:select( nTemp ) - ::oMenu:display() - IF lSubMenu - ::PushMenu() - ENDIF - ENDIF - ::ShowMsg( .T. ) - - CASE nKey == K_ENTER - - IF ::PushMenu() - ::ShowMsg( .T. ) - ELSE - ::ShowMsg( .F. ) - nReturn := ::execute() - IF nReturn != 0 - EXIT - ENDIF - ENDIF - - CASE nKey == K_ESC // go to previous menu - - IF ::PopMenu() - ::oMenu:display() - ::ShowMsg( .T. ) - ELSE - - IF ::oMenu:ClassName() == "POPUPMENU" - ::oMenu:close() - ENDIF - - nReturn := -1 // Bail out if at the top menu item - EXIT - - ENDIF - - CASE nKey == K_LBUTTONDOWN - - IF !::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) - - IF GetList != NIL .AND. HitTest( GetList, MRow(), MCol(), ::GetMsgArray() ) != 0 - GetActive():ExitState := GE_MOUSEHIT - ReadStats( SNLASTEXIT, GE_MOUSEHIT ) // Reset Get System values - IF ::oMenu:ClassName() == "POPUPMENU" - ::PopMenu() - ENDIF - nReturn := -1 - EXIT - ENDIF - - IF ::oMenu:ClassName() == "POPUPMENU" - ::PopMenu() - ENDIF - - ELSEIF nNewLevel == ::nMenuLevel - ::oMenu:select( nNewItem ) - ::oMenu:display() - ::PushMenu() - ::ShowMsg( .T. ) - - ELSE - ::nMenuLevel := nNewLevel - ::oMenu := ::aMenuList[ ::nMenuLevel ] - - nMenuItem := ::oMenu:current - oMenuItem := ::oMenu:getItem( nMenuItem ) - IF ( oMenuItem := ::oMenu:getItem( ::oMenu:Current ) ):isPopUp() - oMenuItem:data:close() - ENDIF - - IF nMenuItem != nNewItem - nMenuItem := nNewItem - ::oMenu:select( nNewItem ) - ::oMenu:display() - ::PushMenu() - ENDIF - - ::ShowMsg( .T. ) - ENDIF - - lLeftDown := .T. - - CASE nKey == K_LBUTTONUP - - lLeftDown := .F. - - IF ::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) .AND. ; - nNewLevel == ::nMenuLevel - - IF nNewItem == ::oMenu:current - ::ShowMsg( .F. ) - nReturn := ::execute() - IF nReturn != 0 - EXIT - ENDIF - ENDIF - ENDIF - - CASE ( nNewItem := ::oMenu:getAccel( nKey ) ) != 0 - - IF ::oMenu:getItem( nNewItem ):enabled - ::oMenu:select( nNewItem ) - ::oMenu:display() - - IF !::PushMenu() - ::ShowMsg( .F. ) - nReturn := ::execute() - IF nReturn != 0 - EXIT - ENDIF - ENDIF - ::ShowMsg( .T. ) - - ENDIF - - CASE IsShortCut( oTopMenu, nKey, @nReturn ) - - IF nReturn != 0 - EXIT - ENDIF - - CASE GetList != NIL .AND. ( nNewItem := Accelerator( GetList, nKey, ::GetMsgArray() ) ) != 0 - - GetActive():ExitState := GE_SHORTCUT - ReadStats( SNNEXTGET, nNewItem ) // Reset Get System values - IF ::oMenu:ClassName() == "POPUPMENU" - ::PopMenu() - ENDIF - - nReturn := -1 - EXIT - - CASE ( nNewItem := oTopMenu:getAccel( nKey ) ) != 0 // ; check for the top menu item accelerator key - - IF oTopMenu:getItem( nNewItem ):enabled - ::PopAll() - ::oMenu:select( nNewItem ) - ::oMenu:display() - IF oTopMenu:getItem( nNewItem ):isPopUp() - ::PushMenu() - ELSE - ::ShowMsg( .F. ) - nReturn := ::execute() - IF nReturn != 0 - EXIT - ENDIF - ENDIF - ::ShowMsg( .T. ) - ENDIF - - ENDCASE - - ENDDO - - IF ::lMsgFlag - RestScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight, ::cMsgSaveS ) - ENDIF - - ::PopAll() - - SetPos( ::nOldRow, ::nOldCol ) - SetCursor( ::nOldCursor ) - - RETURN nReturn - -/*** -* -* Increment ::nMenuLevel and optionally select first item. -* If selected MenuItem IsPopUp, assign ::oMenu. -* -***/ -METHOD PushMenu() CLASS HBMenuSys - LOCAL oNewMenu := ::oMenu:getItem( ::oMenu:current ) - - IF ISOBJECT( oNewMenu ) .AND. oNewMenu:IsPopUp - - ::oMenu := oNewMenu:data - ::aMenuList[ ++::nMenuLevel ] := ::oMenu - ::oMenu:select( ::oMenu:getFirst() ) - - IF !::oMenu:isOpen - ::oMenu:open() - ENDIF - - RETURN .T. - - ENDIF - - RETURN .F. - -/*** -* -* Close SubMenuItem and Return to the upper MenuItem level. -* -***/ -METHOD PopMenu() CLASS HBMenuSys - - IF ::nMenuLevel > 1 - ::oMenu:select( 0 ) - ::oMenu:close( .T. ) - ::oMenu := ::aMenuList[ --::nMenuLevel ] // Decrement MenuItem level and assign - RETURN .T. - ENDIF - - RETURN .F. - -/*** -* -* Close PopUp Child MenuItem and Return to the upper MenuItem level. -* -***/ -METHOD PopChild( nNewLevel ) CLASS HBMenuSys - LOCAL oOldMenuItem - LOCAL nCurrent - - IF ( nCurrent := ::oMenu:current ) != 0 - oOldMenuItem := ::oMenu:getItem( nCurrent ) - IF oOldMenuItem:isPopUp - oOldMenuItem:data:close() - ::nMenuLevel := nNewLevel - RETURN .T. - ENDIF - - ENDIF - - RETURN .F. - -/*** -* -* Close all Menus below Top Menu and Return to upper MenuItem level. -* -***/ -METHOD PopAll() CLASS HBMenuSys - - IF ::aMenuList[ 2 ] != NIL - ::aMenuList[ 2 ]:close() - ENDIF - // Set the menu level and position relative to the top menu item: - ::nMenuLevel := 1 - ::oMenu := ::aMenuList[ 1 ] - - RETURN .T. - -/*** -* -* Eval() the Data block if selected MenuItem is !IsPopUp. -* -***/ -METHOD Execute() CLASS HBMenuSys - LOCAL oNewMenu := ::oMenu:getItem( ::oMenu:current ) - LOCAL lPas := .T. - - // Execute the Data block if selected MenuItem is !IsPopUp: - IF ISOBJECT( oNewMenu ) .AND. !oNewMenu:IsPopUp - - IF ::oMenu:ClassName() $ "TOPBARMENU|POPUPMENU" - SetPos( ::nOldRow, ::nOldCol ) - SetCursor( ::nOldCursor ) - Eval( oNewMenu:data, oNewMenu ) - SetCursor( SC_NONE ) - lPas := .F. - ENDIF - - // Pop the Menu: - ::oMenu:select( iif( ::PopMenu(), ::oMenu:current, 0 ) ) - - // Display newly selected current menu item: - IF ::oMenu:ClassName() == "POPUPMENU" .AND. ; - ::nMenuLevel == 1 .AND. ; - !::oMenu:isOpen - - ::oMenu:open() - ENDIF - - IF lPas - ::oMenu:close() - SetPos( ::nOldRow, ::nOldCol ) - SetCursor( ::nOldCursor ) - Eval( oNewMenu:data, oNewMenu ) - SetCursor( SC_NONE ) - ENDIF - - RETURN oNewMenu:Id - - ENDIF - - RETURN 0 - -/*** -* -* Test to find the Mouse location. -* Note: Formal parameters received here were passed by reference. -* -***/ -METHOD MHitTest( oNewMenu, nNewLevel, nNewItem ) CLASS HBMenuSys - - FOR nNewLevel := ::nMenuLevel TO 1 STEP -1 - - oNewMenu := ::aMenuList[ nNewLevel ] - nNewItem := oNewMenu:hitTest( MRow(), MCol() ) - - IF nNewItem < 0 - RETURN .F. // Test for the mouse on Menu separator or border - ELSEIF nNewItem > 0 .AND. oNewMenu:getItem( nNewItem ):enabled - RETURN .T. // Test for the mouse on an enabled item in the menu - ENDIF - - NEXT - - RETURN .F. - -/*** -* -* Erase and Show Messages. -* Erase Message then ::ShowMsg() if lMode is .T. -* Only erases Menu Message if lMode is .F. -* SaveScreen()/RestScreen() is used for the -* Message area in both text or graphics mode. -* -***/ -METHOD ShowMsg( lMode ) CLASS HBMenuSys - LOCAL nCurrent - LOCAL cMsg - LOCAL lMOldState := MSetCursor( .F. ) - - IF ISLOGICAL( ::lOldMsgFlag ) .AND. ::lOldMsgFlag - RestScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight, ::cMsgSaveS ) - ENDIF - - IF lMode - IF !ISCHARACTER( ::cMsgColor ) - ::cMsgColor := GetClrPair( SetColor(), 1 ) - ENDIF - - IF ::lMsgFlag .AND. ; - ( nCurrent := ::oMenu:current ) != 0 .AND. ; - !Empty( cMsg := ::oMenu:getItem( nCurrent ):message ) - - DispOutAt( ::nMsgRow, ::nMsgLeft, PadC( cMsg, ::nMsgRight - ::nMsgLeft + 1 ), ::cMsgColor ) - ENDIF - - ::cOldMessage := cMsg - ::lOldMsgFlag := ::lMsgFlag - - ENDIF - - MSetCursor( lMOldState ) - - RETURN .T. - -/* NOTE: Generates the somewhat internal, yet widely used message line format of CA-Cl*pper 5.3 - This format contradicts the one in the official docs. */ - -METHOD GetMsgArray() CLASS HBMenuSys - RETURN { , ::nMsgRow, ::nMsgLeft, ::nMsgRight, ::cMsgColor, , , , , } - -/* -------------------------------------------- */ - -METHOD New( oMenu ) CLASS HBMenuSys - ::oMenu := oMenu - RETURN Self - -#endif +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * TMENUSYS class + * + * Copyright 2002 Larry Sevilla + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include "hbclass.ch" + +#include "common.ch" +#include "getexit.ch" +#include "inkey.ch" +#include "setcurs.ch" + +/* NOTE: Harbour doesn't support CA-Cl*pper 5.3 GUI functionality, but + it has all related variables and methods. */ + +#ifdef HB_COMPAT_C53 + +/* Some helper contants for the ReadStats() calls. */ +#define SNLASTEXIT 6 +#define SNNEXTGET 12 + +/* Class to simulate menusys.prg of CA-Cl*pper 5.3 */ + +CREATE CLASS HBMenuSys + + EXPORT: + + METHOD Modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) + METHOD New( oMenu ) + + PROTECTED: + + METHOD PushMenu() + METHOD PopMenu() + METHOD PopChild( nNewLevel ) + METHOD PopAll() + METHOD Execute() + METHOD MHitTest( oNewMenu, nNewLevel, nNewItem ) + METHOD ShowMsg( lMode ) + METHOD GetMsgArray() + + VAR oMenu + VAR lOldMsgFlag + VAR cOldMessage + VAR aMenuList + VAR nMenuLevel + VAR nOldRow + VAR nOldCol + VAR nOldCursor + VAR lMsgFlag + VAR nMsgRow + VAR nMsgLeft + VAR nMsgRight + VAR cMsgColor + VAR cMsgSaveS + +ENDCLASS + +/*** +* +* Standard Menu System Modal handling for Menu Items +* +***/ +METHOD Modal( nSelection, nMsgRow, nMsgLeft, nMsgRight, cMsgColor, GetList ) CLASS HBMenuSys + + LOCAL oTopMenu := ::oMenu + + LOCAL nReturn := 0 + + LOCAL nKey + LOCAL nNewItem + LOCAL lLeftDown + LOCAL oNewMenu + LOCAL nNewLevel + LOCAL nEvent + LOCAL oMenuItem + LOCAL nMenuItem + LOCAL nTemp + LOCAL bKeyBlock + LOCAL lSubMenu + + ::nOldRow := Row() + ::nOldCol := Col() + ::nOldCursor := SetCursor( SC_NONE ) + + ::nMsgRow := nMsgRow + ::nMsgLeft := nMsgLeft + ::nMsgRight := nMsgRight + ::cMsgColor := cMsgColor + + IF ( ::lMsgFlag := ISNUMBER( ::nMsgRow ) .AND. ; + ISNUMBER( ::nMsgLeft ) .AND. ; + ISNUMBER( ::nMsgRight ) ) + + IF !ISCHARACTER( ::cMsgColor ) + ::cMsgColor := GetClrPair( SetColor(), 1 ) + ENDIF + + Scroll( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight ) + + ::cMsgSaveS := SaveScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight ) + + ENDIF + + oTopMenu:select( nSelection ) + + IF !( oTopMenu:ClassName() == "TOPBARMENU" ) .AND. !oTopMenu:isOpen + oTopMenu:open() + ELSE + oTopMenu:display() + ENDIF + + IF nSelection <= 0 + + DO WHILE nSelection <= 0 + + nEvent := Set( _SET_EVENTMASK, INKEY_KEYBOARD + INKEY_LDOWN ) + nKey := Inkey( 0 ) + Set( _SET_EVENTMASK, nEvent ) + + IF nKey == K_LBUTTONDOWN .OR. nKey == K_LDBLCLK + nSelection := oTopMenu:hitTest( MRow(), MCol() ) + + ELSEIF ( nSelection := oTopMenu:getAccel( nKey ) ) != 0 + + ELSEIF IsShortCut( oTopMenu, nKey, @nReturn ) + RETURN nReturn + + ELSE + nSelection := 1 + + ENDIF + + ENDDO + + oTopMenu:select( nSelection ) + oTopMenu:display() + + ENDIF + + IF !oTopMenu:getItem( nSelection ):enabled + RETURN 0 + ENDIF + + ::aMenuList := Array( 16 ) + ::nMenuLevel := 1 + ::aMenuList[ 1 ] := ::oMenu + + lLeftDown := MLeftDown() + + ::ShowMsg( .T. ) + + DO WHILE .T. + + nKey := Inkey( 0 ) + + IF ( bKeyBlock := SetKey( nKey ) ) != NIL + Eval( bKeyBlock, ProcName( 1 ), ProcLine( 1 ), "" ) + LOOP + ENDIF + + DO CASE + CASE nKey == K_MOUSEMOVE + + IF lLeftDown + + IF !::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) // ; hit nowhere. + + ELSEIF nNewLevel != ::nMenuLevel // ; menu level change. + + IF nNewItem != oNewMenu:current .AND. oNewMenu:GetItem( nNewItem ):enabled + ::oMenu := oNewMenu + ::PopChild( nNewLevel ) + ::oMenu:select( nNewItem ) + ::oMenu:display() + ::PushMenu() + ::ShowMsg( .T. ) + ENDIF + + ELSEIF nNewItem != oNewMenu:Current() // ; menu item change. + + ::PopChild( ::nMenuLevel ) + + IF ::oMenu:getItem( nNewItem ):enabled + ::oMenu:select( nNewItem ) + ::oMenu:display() + ::PushMenu() + ::ShowMsg( .T. ) + ENDIF + + ENDIF + + ENDIF + + CASE nKey == K_DOWN + + IF ::oMenu:ClassName() == "TOPBARMENU" + IF ::PushMenu() + ::ShowMsg( .T. ) + ENDIF + ELSE + nTemp := ::oMenu:getNext() + IF nTemp == 0 + nTemp := ::oMenu:getFirst() + ENDIF + ::oMenu:select( nTemp ) + ::oMenu:display() + ::ShowMsg( .T. ) + ENDIF + + CASE nKey == K_UP + + IF !( ::oMenu:ClassName() == "TOPBARMENU" ) + nTemp := ::oMenu:getPrev() + IF nTemp == 0 + nTemp := ::oMenu:getLast() + ENDIF + ::oMenu:select( nTemp ) + ::oMenu:display() + ::ShowMsg( .T. ) + + ENDIF + + CASE nKey == K_LEFT + + IF ( lSubMenu := ( ::nMenuLevel > 1 ) ) + ::PopMenu() + ENDIF + IF ::oMenu:ClassName() == "TOPBARMENU" + nTemp := ::oMenu:getPrev() + IF nTemp == 0 + nTemp := ::oMenu:getLast() + ENDIF + ::oMenu:select( nTemp ) + ::oMenu:display() + IF lSubMenu + ::PushMenu() + ENDIF + ENDIF + ::ShowMsg( .T. ) + + CASE nKey == K_RIGHT + + IF ( lSubMenu := ( ::nMenuLevel > 1 ) ) + ::PopMenu() + ENDIF + + IF ::oMenu:ClassName() == "TOPBARMENU" + nTemp := ::oMenu:getNext() + IF nTemp == 0 + nTemp := ::oMenu:getFirst() + ENDIF + ::oMenu:select( nTemp ) + ::oMenu:display() + IF lSubMenu + ::PushMenu() + ENDIF + ENDIF + ::ShowMsg( .T. ) + + CASE nKey == K_ENTER + + IF ::PushMenu() + ::ShowMsg( .T. ) + ELSE + ::ShowMsg( .F. ) + nReturn := ::execute() + IF nReturn != 0 + EXIT + ENDIF + ENDIF + + CASE nKey == K_ESC // go to previous menu + + IF ::PopMenu() + ::oMenu:display() + ::ShowMsg( .T. ) + ELSE + + IF ::oMenu:ClassName() == "POPUPMENU" + ::oMenu:close() + ENDIF + + nReturn := -1 // Bail out if at the top menu item + EXIT + + ENDIF + + CASE nKey == K_LBUTTONDOWN + + IF !::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) + + IF GetList != NIL .AND. HitTest( GetList, MRow(), MCol(), ::GetMsgArray() ) != 0 + GetActive():ExitState := GE_MOUSEHIT + ReadStats( SNLASTEXIT, GE_MOUSEHIT ) // Reset Get System values + IF ::oMenu:ClassName() == "POPUPMENU" + ::PopMenu() + ENDIF + nReturn := -1 + EXIT + ENDIF + + IF ::oMenu:ClassName() == "POPUPMENU" + ::PopMenu() + ENDIF + + ELSEIF nNewLevel == ::nMenuLevel + ::oMenu:select( nNewItem ) + ::oMenu:display() + ::PushMenu() + ::ShowMsg( .T. ) + + ELSE + ::nMenuLevel := nNewLevel + ::oMenu := ::aMenuList[ ::nMenuLevel ] + + nMenuItem := ::oMenu:current + oMenuItem := ::oMenu:getItem( nMenuItem ) + IF ( oMenuItem := ::oMenu:getItem( ::oMenu:Current ) ):isPopUp() + oMenuItem:data:close() + ENDIF + + IF nMenuItem != nNewItem + nMenuItem := nNewItem + ::oMenu:select( nNewItem ) + ::oMenu:display() + ::PushMenu() + ENDIF + + ::ShowMsg( .T. ) + ENDIF + + lLeftDown := .T. + + CASE nKey == K_LBUTTONUP + + lLeftDown := .F. + + IF ::MHitTest( @oNewMenu, @nNewLevel, @nNewItem ) .AND. ; + nNewLevel == ::nMenuLevel + + IF nNewItem == ::oMenu:current + ::ShowMsg( .F. ) + nReturn := ::execute() + IF nReturn != 0 + EXIT + ENDIF + ENDIF + ENDIF + + CASE ( nNewItem := ::oMenu:getAccel( nKey ) ) != 0 + + IF ::oMenu:getItem( nNewItem ):enabled + ::oMenu:select( nNewItem ) + ::oMenu:display() + + IF !::PushMenu() + ::ShowMsg( .F. ) + nReturn := ::execute() + IF nReturn != 0 + EXIT + ENDIF + ENDIF + ::ShowMsg( .T. ) + + ENDIF + + CASE IsShortCut( oTopMenu, nKey, @nReturn ) + + IF nReturn != 0 + EXIT + ENDIF + + CASE GetList != NIL .AND. ( nNewItem := Accelerator( GetList, nKey, ::GetMsgArray() ) ) != 0 + + GetActive():ExitState := GE_SHORTCUT + ReadStats( SNNEXTGET, nNewItem ) // Reset Get System values + IF ::oMenu:ClassName() == "POPUPMENU" + ::PopMenu() + ENDIF + + nReturn := -1 + EXIT + + CASE ( nNewItem := oTopMenu:getAccel( nKey ) ) != 0 // ; check for the top menu item accelerator key + + IF oTopMenu:getItem( nNewItem ):enabled + ::PopAll() + ::oMenu:select( nNewItem ) + ::oMenu:display() + IF oTopMenu:getItem( nNewItem ):isPopUp() + ::PushMenu() + ELSE + ::ShowMsg( .F. ) + nReturn := ::execute() + IF nReturn != 0 + EXIT + ENDIF + ENDIF + ::ShowMsg( .T. ) + ENDIF + + ENDCASE + + ENDDO + + IF ::lMsgFlag + RestScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight, ::cMsgSaveS ) + ENDIF + + ::PopAll() + + SetPos( ::nOldRow, ::nOldCol ) + SetCursor( ::nOldCursor ) + + RETURN nReturn + +/*** +* +* Increment ::nMenuLevel and optionally select first item. +* If selected MenuItem IsPopUp, assign ::oMenu. +* +***/ +METHOD PushMenu() CLASS HBMenuSys + LOCAL oNewMenu := ::oMenu:getItem( ::oMenu:current ) + + IF ISOBJECT( oNewMenu ) .AND. oNewMenu:IsPopUp + + ::oMenu := oNewMenu:data + ::aMenuList[ ++::nMenuLevel ] := ::oMenu + ::oMenu:select( ::oMenu:getFirst() ) + + IF !::oMenu:isOpen + ::oMenu:open() + ENDIF + + RETURN .T. + + ENDIF + + RETURN .F. + +/*** +* +* Close SubMenuItem and Return to the upper MenuItem level. +* +***/ +METHOD PopMenu() CLASS HBMenuSys + + IF ::nMenuLevel > 1 + ::oMenu:select( 0 ) + ::oMenu:close( .T. ) + ::oMenu := ::aMenuList[ --::nMenuLevel ] // Decrement MenuItem level and assign + RETURN .T. + ENDIF + + RETURN .F. + +/*** +* +* Close PopUp Child MenuItem and Return to the upper MenuItem level. +* +***/ +METHOD PopChild( nNewLevel ) CLASS HBMenuSys + LOCAL oOldMenuItem + LOCAL nCurrent + + IF ( nCurrent := ::oMenu:current ) != 0 + oOldMenuItem := ::oMenu:getItem( nCurrent ) + IF oOldMenuItem:isPopUp + oOldMenuItem:data:close() + ::nMenuLevel := nNewLevel + RETURN .T. + ENDIF + + ENDIF + + RETURN .F. + +/*** +* +* Close all Menus below Top Menu and Return to upper MenuItem level. +* +***/ +METHOD PopAll() CLASS HBMenuSys + + IF ::aMenuList[ 2 ] != NIL + ::aMenuList[ 2 ]:close() + ENDIF + // Set the menu level and position relative to the top menu item: + ::nMenuLevel := 1 + ::oMenu := ::aMenuList[ 1 ] + + RETURN .T. + +/*** +* +* Eval() the Data block if selected MenuItem is !IsPopUp. +* +***/ +METHOD Execute() CLASS HBMenuSys + LOCAL oNewMenu := ::oMenu:getItem( ::oMenu:current ) + LOCAL lPas := .T. + + // Execute the Data block if selected MenuItem is !IsPopUp: + IF ISOBJECT( oNewMenu ) .AND. !oNewMenu:IsPopUp + + IF ::oMenu:ClassName() $ "TOPBARMENU|POPUPMENU" + SetPos( ::nOldRow, ::nOldCol ) + SetCursor( ::nOldCursor ) + Eval( oNewMenu:data, oNewMenu ) + SetCursor( SC_NONE ) + lPas := .F. + ENDIF + + // Pop the Menu: + ::oMenu:select( iif( ::PopMenu(), ::oMenu:current, 0 ) ) + + // Display newly selected current menu item: + IF ::oMenu:ClassName() == "POPUPMENU" .AND. ; + ::nMenuLevel == 1 .AND. ; + !::oMenu:isOpen + + ::oMenu:open() + ENDIF + + IF lPas + ::oMenu:close() + SetPos( ::nOldRow, ::nOldCol ) + SetCursor( ::nOldCursor ) + Eval( oNewMenu:data, oNewMenu ) + SetCursor( SC_NONE ) + ENDIF + + RETURN oNewMenu:Id + + ENDIF + + RETURN 0 + +/*** +* +* Test to find the Mouse location. +* Note: Formal parameters received here were passed by reference. +* +***/ +METHOD MHitTest( oNewMenu, nNewLevel, nNewItem ) CLASS HBMenuSys + + FOR nNewLevel := ::nMenuLevel TO 1 STEP -1 + + oNewMenu := ::aMenuList[ nNewLevel ] + nNewItem := oNewMenu:hitTest( MRow(), MCol() ) + + IF nNewItem < 0 + RETURN .F. // Test for the mouse on Menu separator or border + ELSEIF nNewItem > 0 .AND. oNewMenu:getItem( nNewItem ):enabled + RETURN .T. // Test for the mouse on an enabled item in the menu + ENDIF + + NEXT + + RETURN .F. + +/*** +* +* Erase and Show Messages. +* Erase Message then ::ShowMsg() if lMode is .T. +* Only erases Menu Message if lMode is .F. +* SaveScreen()/RestScreen() is used for the +* Message area in both text or graphics mode. +* +***/ +METHOD ShowMsg( lMode ) CLASS HBMenuSys + LOCAL nCurrent + LOCAL cMsg + LOCAL lMOldState := MSetCursor( .F. ) + + IF ISLOGICAL( ::lOldMsgFlag ) .AND. ::lOldMsgFlag + RestScreen( ::nMsgRow, ::nMsgLeft, ::nMsgRow, ::nMsgRight, ::cMsgSaveS ) + ENDIF + + IF lMode + IF !ISCHARACTER( ::cMsgColor ) + ::cMsgColor := GetClrPair( SetColor(), 1 ) + ENDIF + + IF ::lMsgFlag .AND. ; + ( nCurrent := ::oMenu:current ) != 0 .AND. ; + !Empty( cMsg := ::oMenu:getItem( nCurrent ):message ) + + DispOutAt( ::nMsgRow, ::nMsgLeft, PadC( cMsg, ::nMsgRight - ::nMsgLeft + 1 ), ::cMsgColor ) + ENDIF + + ::cOldMessage := cMsg + ::lOldMsgFlag := ::lMsgFlag + + ENDIF + + MSetCursor( lMOldState ) + + RETURN .T. + +/* NOTE: Generates the somewhat internal, yet widely used message line format of CA-Cl*pper 5.3 + This format contradicts the one in the official docs. */ + +METHOD GetMsgArray() CLASS HBMenuSys + RETURN { , ::nMsgRow, ::nMsgLeft, ::nMsgRight, ::cMsgColor, , , , , } + +/* -------------------------------------------- */ + +METHOD New( oMenu ) CLASS HBMenuSys + ::oMenu := oMenu + RETURN Self + +#endif diff --git a/harbour/source/rtl/tscalar.prg b/harbour/source/rtl/tscalar.prg index 9426244b2d..8a967abb0c 100644 --- a/harbour/source/rtl/tscalar.prg +++ b/harbour/source/rtl/tscalar.prg @@ -1,314 +1,314 @@ -/* - * $Id: scalar.prg 7751 2007-09-15 11:54:39Z vszakats $ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Scalar classes - * - * Copyright 2004 Antonio Linares - * www - http://www.harbour-project.org - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ - -/* Class(y) documentation is located at: - http://www.clipx.net/ng/classy/ngdebc.php */ - -#include "hbclass.ch" - -/* -------------------------------------------- */ - -CREATE CLASS ScalarObject FUNCTION HBScalar - - METHOD Copy() - METHOD IsScalar() - METHOD AsString() - METHOD AsExpStr() - - MESSAGE Become METHOD BecomeErr() // a scalar cannot "become" another object - MESSAGE DeepCopy METHOD Copy() - -ENDCLASS - -METHOD Copy() CLASS ScalarObject - RETURN Self - -METHOD IsScalar() CLASS ScalarObject - RETURN .T. - -METHOD AsString() CLASS ScalarObject - - SWITCH ValType( Self ) - CASE "B" ; RETURN "{ || ... }" - CASE "C" ; RETURN Self - CASE "D" ; RETURN DToC( Self ) - CASE "L" ; RETURN iif( Self, ".T.", ".F." ) - CASE "N" ; RETURN LTrim( Str( Self ) ) - CASE "U" ; RETURN "NIL" - ENDSWITCH - - RETURN "Error!" - -METHOD AsExpStr() CLASS ScalarObject - - SWITCH ValType( Self ) - CASE "C" ; RETURN '"' + Self + '"' - CASE "D" ; RETURN 'CToD("' + DToC( Self ) + '")' - ENDSWITCH - - RETURN ::AsString() - -METHOD BecomeErr() CLASS ScalarObject - // Not implemented yet - // ::error( CSYERR_BECOME, "Message 'become' illegally sent to scalar", ::ClassName() ) - RETURN NIL - -/* -------------------------------------------- */ - -CREATE CLASS Array INHERIT HBScalar FUNCTION HBArray - - METHOD Init() - - METHOD AsString() - METHOD At - METHOD AtPut() - METHOD Add - METHOD AddAll() - METHOD Collect() - METHOD Copy() - METHOD Do() - METHOD DeleteAt() - METHOD InsertAt() - METHOD IndexOf() - METHOD IsScalar() - METHOD Remove() - METHOD Scan() - METHOD _Size() // assignment method - -ENDCLASS - -METHOD Init( nElements ) CLASS Array - - ::size := iif( nElements == NIL, 0, nElements ) - - RETURN Self - -METHOD AddAll( aOtherCollection ) CLASS Array - - aOtherCollection:Do( {| e | ::Add( e ) } ) - - RETURN Self - -METHOD AsString() CLASS Array - RETURN "{ ... }" - -METHOD At( n ) CLASS Array - RETURN Self[ n ] - -METHOD AtPut( n, x ) CLASS Array - RETURN Self[ n ] := x - -METHOD Add( x ) CLASS Array - - AAdd( Self, x ) - - RETURN .T. - -METHOD Collect( b ) CLASS Array - - LOCAL i - LOCAL currElem - LOCAL result := {} - LOCAL nElems := Len( Self ) - - FOR i := 1 to nElems - currElem := Self[ i ] - IF Eval( b, currElem ) - AAdd( result, currElem ) - ENDIF - NEXT - - RETURN result - -METHOD Copy() CLASS Array - RETURN ACopy( Self, Array( Len( Self ) ) ) - -METHOD DeleteAt( n ) CLASS Array - - IF n > 0 .AND. n <= Len( Self ) - ADel( Self, n ) - ASize( Self, Len( Self ) - 1 ) - ENDIF - - RETURN Self - -METHOD InsertAt( n, x ) CLASS Array - - IF n > Len( Self ) - ASize( Self, n ) - Self[ n ] := x - ELSEIF n > 0 - ASize( Self, Len( Self ) + 1 ) - AIns( Self, n ) - Self[ n ] := x - ENDIF - - RETURN Self - -METHOD IsScalar() CLASS Array - RETURN .T. - -METHOD Do( b ) CLASS Array - - LOCAL i - - FOR i := 1 TO Len( Self ) - b:Eval( Self[ i ], i ) - NEXT - - RETURN Self - -METHOD IndexOf( x ) CLASS Array - - LOCAL nElems := Len( Self ) - LOCAL i - - FOR i := 1 TO nElems - IF Self[ i ] == x - RETURN i - ENDIF - NEXT - - RETURN 0 - -METHOD Remove( e ) CLASS Array - - ::DeleteAt( ::IndexOf( e ) ) - - RETURN NIL - -METHOD Scan( b ) CLASS Array - RETURN AScan( Self, b ) - -METHOD _Size( newSize ) CLASS Array - - ASize( Self, newSize ) - - RETURN newSize // so that assignment works according to standard rules - -/* -------------------------------------------- */ - -CREATE CLASS Block INHERIT HBScalar FUNCTION HBBlock - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS Block - RETURN "{ || ... }" - -/* -------------------------------------------- */ - -CREATE CLASS Character INHERIT HBScalar FUNCTION HBCharacter - - METHOD AsString() - METHOD AsExpStr() - -ENDCLASS - -METHOD AsString() CLASS Character - RETURN Self - -METHOD AsExpStr() CLASS Character - RETURN '"' + Self + '"' - -/* -------------------------------------------- */ - -CREATE CLASS Date INHERIT HBScalar FUNCTION HBDate - - METHOD AsString() - METHOD AsExpStr() - -ENDCLASS - -METHOD AsString() CLASS Date - RETURN DToC( Self ) - -METHOD AsExpStr() CLASS Date - RETURN 'CToD("' + ::AsString() + '")' - -/* -------------------------------------------- */ - -CREATE CLASS Logical INHERIT HBScalar FUNCTION HBLogical - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS Logical - RETURN iif( Self, ".T.", ".F." ) - -/* -------------------------------------------- */ - -CREATE CLASS HBNil INHERIT HBScalar - - VAR ClassName INIT "NIL" - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS HBNil - RETURN "NIL" - -/* -------------------------------------------- */ - -CREATE CLASS Numeric INHERIT HBScalar FUNCTION HBNumeric - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS Numeric - RETURN LTrim( Str( Self ) ) - -/* -------------------------------------------- */ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Harbour implementation of Class(y) Scalar classes + * + * Copyright 2004 Antonio Linares + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +/* Class(y) documentation is located at: + http://www.clipx.net/ng/classy/ngdebc.php */ + +#include "hbclass.ch" + +/* -------------------------------------------- */ + +CREATE CLASS ScalarObject FUNCTION HBScalar + + METHOD Copy() + METHOD IsScalar() + METHOD AsString() + METHOD AsExpStr() + + MESSAGE Become METHOD BecomeErr() // a scalar cannot "become" another object + MESSAGE DeepCopy METHOD Copy() + +ENDCLASS + +METHOD Copy() CLASS ScalarObject + RETURN Self + +METHOD IsScalar() CLASS ScalarObject + RETURN .T. + +METHOD AsString() CLASS ScalarObject + + SWITCH ValType( Self ) + CASE "B" ; RETURN "{ || ... }" + CASE "C" ; RETURN Self + CASE "D" ; RETURN DToC( Self ) + CASE "L" ; RETURN iif( Self, ".T.", ".F." ) + CASE "N" ; RETURN LTrim( Str( Self ) ) + CASE "U" ; RETURN "NIL" + ENDSWITCH + + RETURN "Error!" + +METHOD AsExpStr() CLASS ScalarObject + + SWITCH ValType( Self ) + CASE "C" ; RETURN '"' + Self + '"' + CASE "D" ; RETURN 'CToD("' + DToC( Self ) + '")' + ENDSWITCH + + RETURN ::AsString() + +METHOD BecomeErr() CLASS ScalarObject + // Not implemented yet + // ::error( CSYERR_BECOME, "Message 'become' illegally sent to scalar", ::ClassName() ) + RETURN NIL + +/* -------------------------------------------- */ + +CREATE CLASS Array INHERIT HBScalar FUNCTION HBArray + + METHOD Init() + + METHOD AsString() + METHOD At + METHOD AtPut() + METHOD Add + METHOD AddAll() + METHOD Collect() + METHOD Copy() + METHOD Do() + METHOD DeleteAt() + METHOD InsertAt() + METHOD IndexOf() + METHOD IsScalar() + METHOD Remove() + METHOD Scan() + METHOD _Size() // assignment method + +ENDCLASS + +METHOD Init( nElements ) CLASS Array + + ::size := iif( nElements == NIL, 0, nElements ) + + RETURN Self + +METHOD AddAll( aOtherCollection ) CLASS Array + + aOtherCollection:Do( {| e | ::Add( e ) } ) + + RETURN Self + +METHOD AsString() CLASS Array + RETURN "{ ... }" + +METHOD At( n ) CLASS Array + RETURN Self[ n ] + +METHOD AtPut( n, x ) CLASS Array + RETURN Self[ n ] := x + +METHOD Add( x ) CLASS Array + + AAdd( Self, x ) + + RETURN .T. + +METHOD Collect( b ) CLASS Array + + LOCAL i + LOCAL currElem + LOCAL result := {} + LOCAL nElems := Len( Self ) + + FOR i := 1 to nElems + currElem := Self[ i ] + IF Eval( b, currElem ) + AAdd( result, currElem ) + ENDIF + NEXT + + RETURN result + +METHOD Copy() CLASS Array + RETURN ACopy( Self, Array( Len( Self ) ) ) + +METHOD DeleteAt( n ) CLASS Array + + IF n > 0 .AND. n <= Len( Self ) + ADel( Self, n ) + ASize( Self, Len( Self ) - 1 ) + ENDIF + + RETURN Self + +METHOD InsertAt( n, x ) CLASS Array + + IF n > Len( Self ) + ASize( Self, n ) + Self[ n ] := x + ELSEIF n > 0 + ASize( Self, Len( Self ) + 1 ) + AIns( Self, n ) + Self[ n ] := x + ENDIF + + RETURN Self + +METHOD IsScalar() CLASS Array + RETURN .T. + +METHOD Do( b ) CLASS Array + + LOCAL i + + FOR i := 1 TO Len( Self ) + b:Eval( Self[ i ], i ) + NEXT + + RETURN Self + +METHOD IndexOf( x ) CLASS Array + + LOCAL nElems := Len( Self ) + LOCAL i + + FOR i := 1 TO nElems + IF Self[ i ] == x + RETURN i + ENDIF + NEXT + + RETURN 0 + +METHOD Remove( e ) CLASS Array + + ::DeleteAt( ::IndexOf( e ) ) + + RETURN NIL + +METHOD Scan( b ) CLASS Array + RETURN AScan( Self, b ) + +METHOD _Size( newSize ) CLASS Array + + ASize( Self, newSize ) + + RETURN newSize // so that assignment works according to standard rules + +/* -------------------------------------------- */ + +CREATE CLASS Block INHERIT HBScalar FUNCTION HBBlock + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS Block + RETURN "{ || ... }" + +/* -------------------------------------------- */ + +CREATE CLASS Character INHERIT HBScalar FUNCTION HBCharacter + + METHOD AsString() + METHOD AsExpStr() + +ENDCLASS + +METHOD AsString() CLASS Character + RETURN Self + +METHOD AsExpStr() CLASS Character + RETURN '"' + Self + '"' + +/* -------------------------------------------- */ + +CREATE CLASS Date INHERIT HBScalar FUNCTION HBDate + + METHOD AsString() + METHOD AsExpStr() + +ENDCLASS + +METHOD AsString() CLASS Date + RETURN DToC( Self ) + +METHOD AsExpStr() CLASS Date + RETURN 'CToD("' + ::AsString() + '")' + +/* -------------------------------------------- */ + +CREATE CLASS Logical INHERIT HBScalar FUNCTION HBLogical + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS Logical + RETURN iif( Self, ".T.", ".F." ) + +/* -------------------------------------------- */ + +CREATE CLASS HBNil INHERIT HBScalar + + VAR ClassName INIT "NIL" + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS HBNil + RETURN "NIL" + +/* -------------------------------------------- */ + +CREATE CLASS Numeric INHERIT HBScalar FUNCTION HBNumeric + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS Numeric + RETURN LTrim( Str( Self ) ) + +/* -------------------------------------------- */ diff --git a/harbour/tests/rto_tb.prg b/harbour/tests/rto_tb.prg index 22b0b628b9..e2d7511336 100644 --- a/harbour/tests/rto_tb.prg +++ b/harbour/tests/rto_tb.prg @@ -1,710 +1,710 @@ -/* - * $Id: rto_get.prg 7264 2007-04-24 08:38:50Z vszakats $ - */ - -/* - * Harbour Project source code: - * Regression tests for classes TBrowse/TBColumn - * - * Copyright 1999-2007 Viktor Szakats - * www - http://www.harbour-project.org - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). - * - * As a special exception, the Harbour Project gives permission for - * additional uses of the text contained in its release of Harbour. - * - * The exception is that, if you link the Harbour libraries with other - * files to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the Harbour library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the Harbour - * Project under the name Harbour. If you copy code from other - * Harbour Project or Free Software Foundation releases into a copy of - * Harbour, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for Harbour, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - */ - -/* NOTE: This source can be compiled with both Harbour and CA-Cl*pper. */ - -#include "common.ch" -#include "error.ch" -#include "fileio.ch" - -#ifndef __HARBOUR__ - #define hb_OSNewLine() ( Chr( 13 ) + Chr( 10 ) ) -#endif - -#translate TEST_L_TBR( ) => TEST_C_TBR( o, #, {|| } ) -#translate TEST_L_TBC( ) => TEST_C_TBC( o, #, {|| } ) - -STATIC s_cTest := "" -STATIC s_xVar := NIL -STATIC s_fhnd -STATIC s_lCallBackStack -STATIC s_lRTEDetails -STATIC s_lIgnoreErrOp -STATIC s_lC5xDump -STATIC s_lCatchErr -STATIC s_lCheckResult - -FUNCTION Main( cArg01, cArg02, cArg03, cArg04 ) - - LOCAL o - - LOCAL cCommandLine - - DEFAULT cArg01 TO "" - DEFAULT cArg02 TO "" - DEFAULT cArg03 TO "" - DEFAULT cArg04 TO "" - - SET DATE ANSI - - // ; - - cCommandLine := cArg01 + " " + cArg02 + " " + cArg03 + " " + cArg04 - - s_lCallBackStack := "CALLBACKSTACK" $ Upper( cCommandLine ) - s_lRTEDetails := "RTEDETAILS" $ Upper( cCommandLine ) - s_lIgnoreErrOp := "IGNERROP" $ Upper( cCommandLine ) - s_lC5xDump := "C5XDUMP" $ Upper( cCommandLine ) - s_lCatchErr := .T. - s_lCheckResult := .F. - - s_lRTEDetails := .T. -// s_lIgnoreErrOp := .T. - - // ; - - #ifdef __HARBOUR__ - s_fhnd := FCreate( "tb_hb.txt", FC_NORMAL ) - #else - s_fhnd := FCreate( "tb_cl5.txt", FC_NORMAL ) - #endif - - IF s_fhnd == F_ERROR - RETURN 1 - ENDIF - - // ; - - o := TBColumnNew( "test00", {|| "test00" } ) - TEST_L_TBC( OBJ_CREATE() ) - TEST_L_TBC( o:defColor := {} ) - TEST_L_TBC( o:defColor := { 1 } ) - TEST_L_TBC( o:defColor := NIL ) - TEST_L_TBC( o:defColor := { 1, 2 } ) - TEST_L_TBC( o:defColor := { 1, 2, 3 } ) - TEST_L_TBC( o:defColor := { 1, 2, 3, 4 } ) - TEST_L_TBC( o:defColor := { 1, 2, 3, 4, 5 } ) - TEST_L_TBC( o:defColor := { "1" } ) - TEST_L_TBC( o:defColor := { "1", "2" } ) - TEST_L_TBC( o:defColor := { "1", "2", "3" } ) - TEST_L_TBC( o:defColor := { "1", "2", "3", "4" } ) - TEST_L_TBC( o:defColor := { "1", "2", "3", "4", "5" } ) - TEST_L_TBC( o:defColor := { "1", 2, "3" } ) - - // ; - - s_lCheckResult := .T. - - TEST_L_TBC( TBColumnNew( NIL , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( -1 , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( 0 , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( 1 , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( 3 , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( 25 , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( "" , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( "az" , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( hb_SToD( "20070425" ), {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( .F. , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( .T. , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( {|| NIL } , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( {} , {|| "test00" } ) ) - TEST_L_TBC( TBColumnNew( { "" } , {|| "test00" } ) ) - - TEST_L_TBC( TBColumnNew( "test00", NIL ) ) - TEST_L_TBC( TBColumnNew( "test00", -1 ) ) - TEST_L_TBC( TBColumnNew( "test00", 0 ) ) - TEST_L_TBC( TBColumnNew( "test00", 1 ) ) - TEST_L_TBC( TBColumnNew( "test00", 3 ) ) - TEST_L_TBC( TBColumnNew( "test00", 25 ) ) - TEST_L_TBC( TBColumnNew( "test00", "" ) ) - TEST_L_TBC( TBColumnNew( "test00", "az" ) ) - TEST_L_TBC( TBColumnNew( "test00", hb_SToD( "20070425" ) ) ) - TEST_L_TBC( TBColumnNew( "test00", .F. ) ) - TEST_L_TBC( TBColumnNew( "test00", .T. ) ) - TEST_L_TBC( TBColumnNew( "test00", {|| NIL } ) ) - TEST_L_TBC( TBColumnNew( "test00", {} ) ) - TEST_L_TBC( TBColumnNew( "test00", { "" } ) ) - - s_lCheckResult := .F. - - // ; - - TBRAssign( NIL ) - TBRAssign( -1 ) - TBRAssign( 0 ) - TBRAssign( 1 ) - TBRAssign( 3 ) - TBRAssign( 25 ) - TBRAssign( "" ) - TBRAssign( "az" ) - TBRAssign( hb_SToD( "20070425" ) ) - TBRAssign( .F. ) - TBRAssign( .T. ) - TBRAssign( {|| NIL } ) - TBRAssign( {} ) - TBRAssign( { "" } ) - - // ; - - TBCAssign( NIL ) - TBCAssign( -1 ) - TBCAssign( 0 ) - TBCAssign( 1 ) - TBCAssign( 3 ) - TBCAssign( 25 ) - TBCAssign( "" ) - TBCAssign( "az" ) - TBCAssign( hb_SToD( "20070425" ) ) - TBCAssign( .F. ) - TBCAssign( .T. ) - TBCAssign( {|| NIL } ) - TBCAssign( {} ) - TBCAssign( { "" } ) - - // ; - - s_cTest := "" - - // ; - - s_lCatchErr := .F. - - o := TBrowseNew( 10, 10, 20, 50 ) - TEST_L_TBR( OBJ_CREATE() ) - TEST_L_TBR( o:AddColumn( TBColumnNew( "test01h", {|| "test01d" } ) ) ) - TEST_L_TBR( o:DelColumn( 1 ) ) - TEST_L_TBR( o:Left() ) - TEST_L_TBR( o:Right() ) - - // ; - -#ifdef HB_COMPAT_C53 - - o := TBColumnNew( "test01h", {|| "test01d" } ) - TEST_L_TBC( OBJ_CREATE() ) - TEST_L_TBC( o:SetStyle( 1 ) ) - TEST_L_TBC( o:SetStyle( 2 ) ) - TEST_L_TBC( o:SetStyle( 3 ) ) - TEST_L_TBC( o:SetStyle( 4, .T. ) ) - TEST_L_TBC( o:SetStyle( 4 ) ) - TEST_L_TBC( o:SetStyle( 4, NIL ) ) - TEST_L_TBC( o:SetStyle( 4 ) ) - TEST_L_TBC( o:SetStyle( 5 ) ) - TEST_L_TBC( o:SetStyle( 5, .T. ) ) - TEST_L_TBC( o:SetStyle( 5, .F. ) ) - - o := TBrowseNew( 10, 10, 20, 50 ) - TEST_L_TBR( OBJ_CREATE() ) - TEST_L_TBR( o:SetStyle( 1 ) ) - TEST_L_TBR( o:SetStyle( 2 ) ) - TEST_L_TBR( o:SetStyle( 3 ) ) - TEST_L_TBR( o:SetStyle( 4 ) ) - TEST_L_TBR( o:SetStyle( 5 ) ) - TEST_L_TBR( o:SetStyle( 4, .T. ) ) - TEST_L_TBR( o:SetStyle( 4 ) ) - TEST_L_TBR( o:SetStyle( 4, NIL ) ) - TEST_L_TBR( o:SetStyle( 4 ) ) - TEST_L_TBR( o:SetStyle( 6 ) ) - TEST_L_TBR( o:SetStyle( 6, .T. ) ) - TEST_L_TBR( o:SetStyle( 6, .F. ) ) - -#endif - - // ; - - FClose( s_fhnd ) - - RETURN 0 - -PROCEDURE TBRAssign( xVar ) - LOCAL o - - s_xVar := xVar - - s_cTest := "TBrowse (empty) assigning: " + XToStr( xVar ) - - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:AutoLite := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Cargo := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColCount := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColorSpec := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColPos := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColSep := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:FootSep := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Freeze := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:GoBottomBlock := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:GoTopBlock := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HeadSep := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HitBottom := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HitTop := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:LeftVisible := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nBottom := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nLeft := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nRight := xVar ) - // ; This is needed for CA-Cl*pper 5.x otherwise an unmaskable (bug?) RTE would be thrown. [vszakats] - IF ISNUMBER( xVar ) .AND. xVar < o:nBottom - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nTop := xVar ) - ENDIF - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RightVisible := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RowCount := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RowPos := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:SkipBlock := xVar ) - o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Stable := xVar ) - - RETURN - -PROCEDURE TBCAssign( xVar ) - LOCAL o - - s_xVar := xVar - - s_cTest := "TBColumn assigning: " + XToStr( xVar ) - - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Block := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Cargo := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:ColorBlock := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:ColSep := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:DefColor := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Footing := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:FootSep := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Heading := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:HeadSep := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Picture := xVar ) - o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Width := xVar ) - - RETURN - -PROCEDURE TEST_C_TBR( o, cBlock, bBlock ) - LOCAL xResult - LOCAL bOldError - LOCAL oError - - SetPos( 0, 0 ) // ; To check where the cursor was moved after evaluating the block. - - IF s_lCatchErr - bOldError := ErrorBlock( {|oError| Break( oError ) } ) - ENDIF - - BEGIN SEQUENCE - xResult := Eval( bBlock ) - RECOVER USING oError - xResult := ErrorMessage( oError ) - END SEQUENCE - - IF s_lCatchErr - ErrorBlock( bOldError ) - ENDIF - - LogTBRVars( o, cBlock, xResult ) - - RETURN - -PROCEDURE TEST_C_TBC( o, cBlock, bBlock ) - LOCAL xResult - LOCAL bOldError - LOCAL oError - - SetPos( 0, 0 ) // ; To check where the cursor was moved after evaluating the block. - - IF s_lCatchErr - bOldError := ErrorBlock( {|oError| Break( oError ) } ) - ENDIF - - BEGIN SEQUENCE - xResult := Eval( bBlock ) - RECOVER USING oError - xResult := ErrorMessage( oError ) - END SEQUENCE - - IF s_lCatchErr - ErrorBlock( bOldError ) - ENDIF - - IF s_lCheckResult - LogTBCVars( xResult, cBlock, xResult ) - ELSE - LogTBCVars( o, cBlock, xResult ) - ENDIF - - RETURN - -PROCEDURE LogMe( data, desc ) - LOCAL nLevel - LOCAL cStack - - cStack := "" - FOR nLevel := 2 TO 5 - IF Empty( ProcName( nLevel ) ) - EXIT - ENDIF - cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") " - NEXT - - IF desc == NIL - desc := "" - ENDIF - desc := s_cTest + " " + desc - - IF !s_lCallBackStack - cStack := "" - ENDIF - - IF PCount() > 2 - FWrite( s_fhnd, cStack + "BLOCK_SET " + iif( data == NIL, "NIL", data ) + " " + desc + hb_OSNewLine() ) - ELSE - FWrite( s_fhnd, cStack + "BLOCK_GET " + desc + hb_OSNewLine() ) - ENDIF - - RETURN - -PROCEDURE LogTBRVars( o, desc, xResult ) - LOCAL nLevel - LOCAL cStack - - LOCAL tmp - LOCAL col - - cStack := "" - FOR nLevel := 2 TO 2 - IF Empty( ProcName( nLevel ) ) - EXIT - ENDIF - cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") " - NEXT - - IF desc == NIL - desc := "" - ENDIF - desc := s_cTest + " " + XToStr( desc ) - - FWrite( s_fhnd, cStack + " " + desc + hb_OSNewLine() ) - FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) - FWrite( s_fhnd, " s_xVar " + XToStr( s_xVar ) + hb_OSNewLine() ) - FWrite( s_fhnd, " xResult " + XToStr( xResult ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Row() " + XToStr( Row() ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Col() " + XToStr( Col() ) + hb_OSNewLine() ) - FWrite( s_fhnd, " AutoLite " + XToStr( o:AutoLite ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Cargo " + XToStr( o:Cargo ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColCount " + XToStr( o:ColCount ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColorSpec " + XToStr( o:ColorSpec ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColPos " + XToStr( o:ColPos ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColSep " + XToStr( o:ColSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " FootSep " + XToStr( o:FootSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Freeze " + XToStr( o:Freeze ) + hb_OSNewLine() ) - FWrite( s_fhnd, " GoBottomBlock " + XToStr( o:GoBottomBlock ) + hb_OSNewLine() ) - FWrite( s_fhnd, " GoTopBlock " + XToStr( o:GoTopBlock ) + hb_OSNewLine() ) - FWrite( s_fhnd, " HeadSep " + XToStr( o:HeadSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " HitBottom " + XToStr( o:HitBottom ) + hb_OSNewLine() ) - FWrite( s_fhnd, " HitTop " + XToStr( o:HitTop ) + hb_OSNewLine() ) - FWrite( s_fhnd, " LeftVisible " + XToStr( o:LeftVisible ) + hb_OSNewLine() ) - FWrite( s_fhnd, " nBottom " + XToStr( o:nBottom ) + hb_OSNewLine() ) - FWrite( s_fhnd, " nLeft " + XToStr( o:nLeft ) + hb_OSNewLine() ) - FWrite( s_fhnd, " nRight " + XToStr( o:nRight ) + hb_OSNewLine() ) - FWrite( s_fhnd, " nTop " + XToStr( o:nTop ) + hb_OSNewLine() ) - FWrite( s_fhnd, " RightVisible " + XToStr( o:RightVisible ) + hb_OSNewLine() ) - FWrite( s_fhnd, " RowCount " + XToStr( o:RowCount ) + hb_OSNewLine() ) - FWrite( s_fhnd, " RowPos " + XToStr( o:RowPos ) + hb_OSNewLine() ) - FWrite( s_fhnd, " SkipBlock " + XToStr( o:SkipBlock ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Stable " + XToStr( o:Stable ) + hb_OSNewLine() ) -#ifndef __HARBOUR__ - IF s_lC5xDump - FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() ) - ENDIF -#endif - FOR tmp := 1 TO o:colCount - FWrite( s_fhnd, " Column: " + StrZero( tmp, 3 ) + hb_OSNewLine() ) - col := o:GetColumn( tmp ) - IF ISOBJECT( col ) - FWrite( s_fhnd, " Block " + XToStr( col:Block ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Cargo " + XToStr( col:Cargo ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColorBlock " + XToStr( col:ColorBlock ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColSep " + XToStr( col:ColSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " DefColor " + XToStr( col:DefColor ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Footing " + XToStr( col:Footing ) + hb_OSNewLine() ) - FWrite( s_fhnd, " FootSep " + XToStr( col:FootSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Heading " + XToStr( col:Heading ) + hb_OSNewLine() ) - FWrite( s_fhnd, " HeadSep " + XToStr( col:HeadSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Picture " + XToStr( col:Picture ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Width " + XToStr( col:Width ) + hb_OSNewLine() ) - ELSE - FWrite( s_fhnd, " Col: " + XToStr( col ) + hb_OSNewLine() ) - ENDIF - NEXT - FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) - - RETURN - -PROCEDURE LogTBCVars( o, desc, xResult ) - LOCAL nLevel - LOCAL cStack - - cStack := "" - FOR nLevel := 2 TO 2 - IF Empty( ProcName( nLevel ) ) - EXIT - ENDIF - cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") " - NEXT - - IF desc == NIL - desc := "" - ENDIF - desc := s_cTest + " " + XToStr( desc ) - - FWrite( s_fhnd, cStack + " " + desc + hb_OSNewLine() ) - FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) - FWrite( s_fhnd, " s_xVar " + XToStr( s_xVar ) + hb_OSNewLine() ) - FWrite( s_fhnd, " xResult " + XToStr( xResult ) + hb_OSNewLine() ) - IF ISOBJECT( o ) - FWrite( s_fhnd, " Block " + XToStr( o:Block ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Cargo " + XToStr( o:Cargo ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColorBlock " + XToStr( o:ColorBlock ) + hb_OSNewLine() ) - FWrite( s_fhnd, " ColSep " + XToStr( o:ColSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " DefColor " + XToStr( o:DefColor ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Footing " + XToStr( o:Footing ) + hb_OSNewLine() ) - FWrite( s_fhnd, " FootSep " + XToStr( o:FootSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Heading " + XToStr( o:Heading ) + hb_OSNewLine() ) - FWrite( s_fhnd, " HeadSep " + XToStr( o:HeadSep ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Picture " + XToStr( o:Picture ) + hb_OSNewLine() ) - FWrite( s_fhnd, " Width " + XToStr( o:Width ) + hb_OSNewLine() ) -#ifndef __HARBOUR__ - IF s_lC5xDump - FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() ) - ENDIF -#endif - ELSE - FWrite( s_fhnd, " o " + XToStr( o ) + hb_OSNewLine() ) - ENDIF - FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) - - RETURN - -STATIC FUNCTION ObjToList( o ) - LOCAL cString := "" - LOCAL tmp - - FOR tmp := 1 TO Len( o ) - cString += XToStr( o[ tmp ] ) - IF tmp < Len( o ) - cString += ", " - ENDIF - NEXT - - RETURN cString - -FUNCTION XToStr( xValue ) - LOCAL cType := ValType( xValue ) - - DO CASE - CASE cType == "C" - - xValue := StrTran( xValue, Chr(0), '"+Chr(0)+"' ) - xValue := StrTran( xValue, Chr(9), '"+Chr(9)+"' ) - xValue := StrTran( xValue, Chr(10), '"+Chr(10)+"' ) - xValue := StrTran( xValue, Chr(13), '"+Chr(13)+"' ) - xValue := StrTran( xValue, Chr(26), '"+Chr(26)+"' ) - - RETURN '"' + xValue + '"' - - CASE cType == "N" ; RETURN LTrim( Str( xValue ) ) - CASE cType == "D" ; RETURN 'HB_SToD("' + DToS( xValue ) + '")' - CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." ) - CASE cType == "O" ; RETURN xValue:className() + " Object" - CASE cType == "U" ; RETURN "NIL" - CASE cType == "B" ; RETURN '{||...} -> ' + XToStr( Eval( xValue ) ) - CASE cType == "A" ; RETURN '{ ' + ArrayToList( xValue ) + ' }' - CASE cType == "M" ; RETURN 'M:"' + xValue + '"' - ENDCASE - - RETURN "" - -FUNCTION ArrayToList( a ) - LOCAL tmp - LOCAL cString := "" - - FOR tmp := 1 TO Len( a ) - cString += XToStr( a[ tmp ] ) - IF tmp < Len( a ) - cString += ", " - ENDIF - NEXT - - RETURN cString - -FUNCTION XToStrE( xValue ) - LOCAL cType := ValType( xValue ) - - DO CASE - CASE cType == "C" - - xValue := StrTran( xValue, Chr(0), '"+Chr(0)+"' ) - xValue := StrTran( xValue, Chr(9), '"+Chr(9)+"' ) - xValue := StrTran( xValue, Chr(10), '"+Chr(10)+"' ) - xValue := StrTran( xValue, Chr(13), '"+Chr(13)+"' ) - xValue := StrTran( xValue, Chr(26), '"+Chr(26)+"' ) - - RETURN xValue - - CASE cType == "N" ; RETURN LTrim( Str( xValue ) ) - CASE cType == "D" ; RETURN DToS( xValue ) - CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." ) - CASE cType == "O" ; RETURN xValue:className() + " Object" - CASE cType == "U" ; RETURN "NIL" - CASE cType == "B" ; RETURN '{||...} -> ' + XToStrE( Eval( xValue ) ) - CASE cType == "A" ; RETURN '{ ' + ArrayToEList( xValue ) + ' }' - CASE cType == "M" ; RETURN 'M:' + xValue - ENDCASE - - RETURN "" - -FUNCTION ArrayToEList( a ) - LOCAL tmp - LOCAL cString := "" - - FOR tmp := 1 TO Len( a ) - cString += XToStrE( a[ tmp ] ) - IF tmp < Len( a ) - cString += ", " - ENDIF - NEXT - - RETURN cString - -STATIC FUNCTION ErrorMessage( oError ) - LOCAL cMessage - LOCAL tmp - - IF s_lRTEDetails - - cMessage := "" - - IF ValType( oError:severity ) == "N" - DO CASE - CASE oError:severity == ES_WHOCARES ; cMessage += "M " - CASE oError:severity == ES_WARNING ; cMessage += "W " - CASE oError:severity == ES_ERROR ; cMessage += "E " - CASE oError:severity == ES_CATASTROPHIC ; cMessage += "C " - ENDCASE - ENDIF - IF ValType( oError:subsystem ) == "C" - cMessage += oError:subsystem + " " - ENDIF - IF ValType( oError:subCode ) == "N" - cMessage += LTrim( Str( oError:subCode ) ) + " " - ENDIF - IF ValType( oError:description ) == "C" - cMessage += oError:description + " " - ENDIF - IF !Empty( oError:operation ) .AND. !s_lIgnoreErrOp - cMessage += oError:operation + " " - ENDIF - IF !Empty( oError:filename ) - cMessage += oError:filename + " " - ENDIF - - IF ValType( oError:Args ) == "A" - cMessage += "A:" + LTrim( Str( Len( oError:Args ) ) ) + ":" - FOR tmp := 1 TO Len( oError:Args ) - cMessage += ValType( oError:Args[ tmp ] ) + ":" + XToStrE( oError:Args[ tmp ] ) - IF tmp < Len( oError:Args ) - cMessage += ";" - ENDIF - NEXT - cMessage += " " - ENDIF - - IF oError:canDefault .OR. ; - oError:canRetry .OR. ; - oError:canSubstitute - - cMessage += "F:" - IF oError:canDefault - cMessage += "D" - ENDIF - IF oError:canRetry - cMessage += "R" - ENDIF - IF oError:canSubstitute - cMessage += "S" - ENDIF - ENDIF - ELSE - cMessage := "(ERROR)" - ENDIF - - RETURN cMessage - -#ifdef __XPP__ -FUNCTION hb_SToD( cDate ) - RETURN SToD( cDate ) -#endif - -#ifndef HAVE_HBCLIP -#ifndef __HARBOUR__ -#ifndef __XPP__ - -FUNCTION hb_SToD( cDate ) - LOCAL cOldDateFormat - LOCAL dDate - - IF ValType( cDate ) == "C" .AND. !Empty( cDate ) - cOldDateFormat := Set( _SET_DATEFORMAT, "yyyy/mm/dd" ) - - dDate := CToD( SubStr( cDate, 1, 4 ) + "/" +; - SubStr( cDate, 5, 2 ) + "/" +; - SubStr( cDate, 7, 2 ) ) - - Set( _SET_DATEFORMAT, cOldDateFormat ) - ELSE - dDate := CToD( "" ) - ENDIF - - RETURN dDate - -#endif -#endif -#endif - -PROCEDURE OBJ_CREATE() - - // ; Dummy - - RETURN +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Regression tests for classes TBrowse/TBColumn + * + * Copyright 1999-2007 Viktor Szakats + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +/* NOTE: This source can be compiled with both Harbour and CA-Cl*pper. */ + +#include "common.ch" +#include "error.ch" +#include "fileio.ch" + +#ifndef __HARBOUR__ + #define hb_OSNewLine() ( Chr( 13 ) + Chr( 10 ) ) +#endif + +#translate TEST_L_TBR( ) => TEST_C_TBR( o, #, {|| } ) +#translate TEST_L_TBC( ) => TEST_C_TBC( o, #, {|| } ) + +STATIC s_cTest := "" +STATIC s_xVar := NIL +STATIC s_fhnd +STATIC s_lCallBackStack +STATIC s_lRTEDetails +STATIC s_lIgnoreErrOp +STATIC s_lC5xDump +STATIC s_lCatchErr +STATIC s_lCheckResult + +FUNCTION Main( cArg01, cArg02, cArg03, cArg04 ) + + LOCAL o + + LOCAL cCommandLine + + DEFAULT cArg01 TO "" + DEFAULT cArg02 TO "" + DEFAULT cArg03 TO "" + DEFAULT cArg04 TO "" + + SET DATE ANSI + + // ; + + cCommandLine := cArg01 + " " + cArg02 + " " + cArg03 + " " + cArg04 + + s_lCallBackStack := "CALLBACKSTACK" $ Upper( cCommandLine ) + s_lRTEDetails := "RTEDETAILS" $ Upper( cCommandLine ) + s_lIgnoreErrOp := "IGNERROP" $ Upper( cCommandLine ) + s_lC5xDump := "C5XDUMP" $ Upper( cCommandLine ) + s_lCatchErr := .T. + s_lCheckResult := .F. + + s_lRTEDetails := .T. +// s_lIgnoreErrOp := .T. + + // ; + + #ifdef __HARBOUR__ + s_fhnd := FCreate( "tb_hb.txt", FC_NORMAL ) + #else + s_fhnd := FCreate( "tb_cl5.txt", FC_NORMAL ) + #endif + + IF s_fhnd == F_ERROR + RETURN 1 + ENDIF + + // ; + + o := TBColumnNew( "test00", {|| "test00" } ) + TEST_L_TBC( OBJ_CREATE() ) + TEST_L_TBC( o:defColor := {} ) + TEST_L_TBC( o:defColor := { 1 } ) + TEST_L_TBC( o:defColor := NIL ) + TEST_L_TBC( o:defColor := { 1, 2 } ) + TEST_L_TBC( o:defColor := { 1, 2, 3 } ) + TEST_L_TBC( o:defColor := { 1, 2, 3, 4 } ) + TEST_L_TBC( o:defColor := { 1, 2, 3, 4, 5 } ) + TEST_L_TBC( o:defColor := { "1" } ) + TEST_L_TBC( o:defColor := { "1", "2" } ) + TEST_L_TBC( o:defColor := { "1", "2", "3" } ) + TEST_L_TBC( o:defColor := { "1", "2", "3", "4" } ) + TEST_L_TBC( o:defColor := { "1", "2", "3", "4", "5" } ) + TEST_L_TBC( o:defColor := { "1", 2, "3" } ) + + // ; + + s_lCheckResult := .T. + + TEST_L_TBC( TBColumnNew( NIL , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( -1 , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( 0 , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( 1 , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( 3 , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( 25 , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( "" , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( "az" , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( hb_SToD( "20070425" ), {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( .F. , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( .T. , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( {|| NIL } , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( {} , {|| "test00" } ) ) + TEST_L_TBC( TBColumnNew( { "" } , {|| "test00" } ) ) + + TEST_L_TBC( TBColumnNew( "test00", NIL ) ) + TEST_L_TBC( TBColumnNew( "test00", -1 ) ) + TEST_L_TBC( TBColumnNew( "test00", 0 ) ) + TEST_L_TBC( TBColumnNew( "test00", 1 ) ) + TEST_L_TBC( TBColumnNew( "test00", 3 ) ) + TEST_L_TBC( TBColumnNew( "test00", 25 ) ) + TEST_L_TBC( TBColumnNew( "test00", "" ) ) + TEST_L_TBC( TBColumnNew( "test00", "az" ) ) + TEST_L_TBC( TBColumnNew( "test00", hb_SToD( "20070425" ) ) ) + TEST_L_TBC( TBColumnNew( "test00", .F. ) ) + TEST_L_TBC( TBColumnNew( "test00", .T. ) ) + TEST_L_TBC( TBColumnNew( "test00", {|| NIL } ) ) + TEST_L_TBC( TBColumnNew( "test00", {} ) ) + TEST_L_TBC( TBColumnNew( "test00", { "" } ) ) + + s_lCheckResult := .F. + + // ; + + TBRAssign( NIL ) + TBRAssign( -1 ) + TBRAssign( 0 ) + TBRAssign( 1 ) + TBRAssign( 3 ) + TBRAssign( 25 ) + TBRAssign( "" ) + TBRAssign( "az" ) + TBRAssign( hb_SToD( "20070425" ) ) + TBRAssign( .F. ) + TBRAssign( .T. ) + TBRAssign( {|| NIL } ) + TBRAssign( {} ) + TBRAssign( { "" } ) + + // ; + + TBCAssign( NIL ) + TBCAssign( -1 ) + TBCAssign( 0 ) + TBCAssign( 1 ) + TBCAssign( 3 ) + TBCAssign( 25 ) + TBCAssign( "" ) + TBCAssign( "az" ) + TBCAssign( hb_SToD( "20070425" ) ) + TBCAssign( .F. ) + TBCAssign( .T. ) + TBCAssign( {|| NIL } ) + TBCAssign( {} ) + TBCAssign( { "" } ) + + // ; + + s_cTest := "" + + // ; + + s_lCatchErr := .F. + + o := TBrowseNew( 10, 10, 20, 50 ) + TEST_L_TBR( OBJ_CREATE() ) + TEST_L_TBR( o:AddColumn( TBColumnNew( "test01h", {|| "test01d" } ) ) ) + TEST_L_TBR( o:DelColumn( 1 ) ) + TEST_L_TBR( o:Left() ) + TEST_L_TBR( o:Right() ) + + // ; + +#ifdef HB_COMPAT_C53 + + o := TBColumnNew( "test01h", {|| "test01d" } ) + TEST_L_TBC( OBJ_CREATE() ) + TEST_L_TBC( o:SetStyle( 1 ) ) + TEST_L_TBC( o:SetStyle( 2 ) ) + TEST_L_TBC( o:SetStyle( 3 ) ) + TEST_L_TBC( o:SetStyle( 4, .T. ) ) + TEST_L_TBC( o:SetStyle( 4 ) ) + TEST_L_TBC( o:SetStyle( 4, NIL ) ) + TEST_L_TBC( o:SetStyle( 4 ) ) + TEST_L_TBC( o:SetStyle( 5 ) ) + TEST_L_TBC( o:SetStyle( 5, .T. ) ) + TEST_L_TBC( o:SetStyle( 5, .F. ) ) + + o := TBrowseNew( 10, 10, 20, 50 ) + TEST_L_TBR( OBJ_CREATE() ) + TEST_L_TBR( o:SetStyle( 1 ) ) + TEST_L_TBR( o:SetStyle( 2 ) ) + TEST_L_TBR( o:SetStyle( 3 ) ) + TEST_L_TBR( o:SetStyle( 4 ) ) + TEST_L_TBR( o:SetStyle( 5 ) ) + TEST_L_TBR( o:SetStyle( 4, .T. ) ) + TEST_L_TBR( o:SetStyle( 4 ) ) + TEST_L_TBR( o:SetStyle( 4, NIL ) ) + TEST_L_TBR( o:SetStyle( 4 ) ) + TEST_L_TBR( o:SetStyle( 6 ) ) + TEST_L_TBR( o:SetStyle( 6, .T. ) ) + TEST_L_TBR( o:SetStyle( 6, .F. ) ) + +#endif + + // ; + + FClose( s_fhnd ) + + RETURN 0 + +PROCEDURE TBRAssign( xVar ) + LOCAL o + + s_xVar := xVar + + s_cTest := "TBrowse (empty) assigning: " + XToStr( xVar ) + + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:AutoLite := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Cargo := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColCount := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColorSpec := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColPos := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:ColSep := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:FootSep := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Freeze := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:GoBottomBlock := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:GoTopBlock := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HeadSep := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HitBottom := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:HitTop := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:LeftVisible := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nBottom := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nLeft := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nRight := xVar ) + // ; This is needed for CA-Cl*pper 5.x otherwise an unmaskable (bug?) RTE would be thrown. [vszakats] + IF ISNUMBER( xVar ) .AND. xVar < o:nBottom + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:nTop := xVar ) + ENDIF + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RightVisible := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RowCount := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:RowPos := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:SkipBlock := xVar ) + o := TBrowseNew( 10, 10, 20, 50 ) ; TEST_L_TBR( o:Stable := xVar ) + + RETURN + +PROCEDURE TBCAssign( xVar ) + LOCAL o + + s_xVar := xVar + + s_cTest := "TBColumn assigning: " + XToStr( xVar ) + + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Block := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Cargo := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:ColorBlock := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:ColSep := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:DefColor := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Footing := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:FootSep := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Heading := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:HeadSep := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Picture := xVar ) + o := TBColumnNew( "test01h", {|| "test01d" } ) ; TEST_L_TBC( o:Width := xVar ) + + RETURN + +PROCEDURE TEST_C_TBR( o, cBlock, bBlock ) + LOCAL xResult + LOCAL bOldError + LOCAL oError + + SetPos( 0, 0 ) // ; To check where the cursor was moved after evaluating the block. + + IF s_lCatchErr + bOldError := ErrorBlock( {|oError| Break( oError ) } ) + ENDIF + + BEGIN SEQUENCE + xResult := Eval( bBlock ) + RECOVER USING oError + xResult := ErrorMessage( oError ) + END SEQUENCE + + IF s_lCatchErr + ErrorBlock( bOldError ) + ENDIF + + LogTBRVars( o, cBlock, xResult ) + + RETURN + +PROCEDURE TEST_C_TBC( o, cBlock, bBlock ) + LOCAL xResult + LOCAL bOldError + LOCAL oError + + SetPos( 0, 0 ) // ; To check where the cursor was moved after evaluating the block. + + IF s_lCatchErr + bOldError := ErrorBlock( {|oError| Break( oError ) } ) + ENDIF + + BEGIN SEQUENCE + xResult := Eval( bBlock ) + RECOVER USING oError + xResult := ErrorMessage( oError ) + END SEQUENCE + + IF s_lCatchErr + ErrorBlock( bOldError ) + ENDIF + + IF s_lCheckResult + LogTBCVars( xResult, cBlock, xResult ) + ELSE + LogTBCVars( o, cBlock, xResult ) + ENDIF + + RETURN + +PROCEDURE LogMe( data, desc ) + LOCAL nLevel + LOCAL cStack + + cStack := "" + FOR nLevel := 2 TO 5 + IF Empty( ProcName( nLevel ) ) + EXIT + ENDIF + cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") " + NEXT + + IF desc == NIL + desc := "" + ENDIF + desc := s_cTest + " " + desc + + IF !s_lCallBackStack + cStack := "" + ENDIF + + IF PCount() > 2 + FWrite( s_fhnd, cStack + "BLOCK_SET " + iif( data == NIL, "NIL", data ) + " " + desc + hb_OSNewLine() ) + ELSE + FWrite( s_fhnd, cStack + "BLOCK_GET " + desc + hb_OSNewLine() ) + ENDIF + + RETURN + +PROCEDURE LogTBRVars( o, desc, xResult ) + LOCAL nLevel + LOCAL cStack + + LOCAL tmp + LOCAL col + + cStack := "" + FOR nLevel := 2 TO 2 + IF Empty( ProcName( nLevel ) ) + EXIT + ENDIF + cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") " + NEXT + + IF desc == NIL + desc := "" + ENDIF + desc := s_cTest + " " + XToStr( desc ) + + FWrite( s_fhnd, cStack + " " + desc + hb_OSNewLine() ) + FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) + FWrite( s_fhnd, " s_xVar " + XToStr( s_xVar ) + hb_OSNewLine() ) + FWrite( s_fhnd, " xResult " + XToStr( xResult ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Row() " + XToStr( Row() ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Col() " + XToStr( Col() ) + hb_OSNewLine() ) + FWrite( s_fhnd, " AutoLite " + XToStr( o:AutoLite ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Cargo " + XToStr( o:Cargo ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColCount " + XToStr( o:ColCount ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColorSpec " + XToStr( o:ColorSpec ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColPos " + XToStr( o:ColPos ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColSep " + XToStr( o:ColSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " FootSep " + XToStr( o:FootSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Freeze " + XToStr( o:Freeze ) + hb_OSNewLine() ) + FWrite( s_fhnd, " GoBottomBlock " + XToStr( o:GoBottomBlock ) + hb_OSNewLine() ) + FWrite( s_fhnd, " GoTopBlock " + XToStr( o:GoTopBlock ) + hb_OSNewLine() ) + FWrite( s_fhnd, " HeadSep " + XToStr( o:HeadSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " HitBottom " + XToStr( o:HitBottom ) + hb_OSNewLine() ) + FWrite( s_fhnd, " HitTop " + XToStr( o:HitTop ) + hb_OSNewLine() ) + FWrite( s_fhnd, " LeftVisible " + XToStr( o:LeftVisible ) + hb_OSNewLine() ) + FWrite( s_fhnd, " nBottom " + XToStr( o:nBottom ) + hb_OSNewLine() ) + FWrite( s_fhnd, " nLeft " + XToStr( o:nLeft ) + hb_OSNewLine() ) + FWrite( s_fhnd, " nRight " + XToStr( o:nRight ) + hb_OSNewLine() ) + FWrite( s_fhnd, " nTop " + XToStr( o:nTop ) + hb_OSNewLine() ) + FWrite( s_fhnd, " RightVisible " + XToStr( o:RightVisible ) + hb_OSNewLine() ) + FWrite( s_fhnd, " RowCount " + XToStr( o:RowCount ) + hb_OSNewLine() ) + FWrite( s_fhnd, " RowPos " + XToStr( o:RowPos ) + hb_OSNewLine() ) + FWrite( s_fhnd, " SkipBlock " + XToStr( o:SkipBlock ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Stable " + XToStr( o:Stable ) + hb_OSNewLine() ) +#ifndef __HARBOUR__ + IF s_lC5xDump + FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() ) + ENDIF +#endif + FOR tmp := 1 TO o:colCount + FWrite( s_fhnd, " Column: " + StrZero( tmp, 3 ) + hb_OSNewLine() ) + col := o:GetColumn( tmp ) + IF ISOBJECT( col ) + FWrite( s_fhnd, " Block " + XToStr( col:Block ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Cargo " + XToStr( col:Cargo ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColorBlock " + XToStr( col:ColorBlock ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColSep " + XToStr( col:ColSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " DefColor " + XToStr( col:DefColor ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Footing " + XToStr( col:Footing ) + hb_OSNewLine() ) + FWrite( s_fhnd, " FootSep " + XToStr( col:FootSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Heading " + XToStr( col:Heading ) + hb_OSNewLine() ) + FWrite( s_fhnd, " HeadSep " + XToStr( col:HeadSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Picture " + XToStr( col:Picture ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Width " + XToStr( col:Width ) + hb_OSNewLine() ) + ELSE + FWrite( s_fhnd, " Col: " + XToStr( col ) + hb_OSNewLine() ) + ENDIF + NEXT + FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) + + RETURN + +PROCEDURE LogTBCVars( o, desc, xResult ) + LOCAL nLevel + LOCAL cStack + + cStack := "" + FOR nLevel := 2 TO 2 + IF Empty( ProcName( nLevel ) ) + EXIT + ENDIF + cStack += ProcName( nLevel ) + " (" + LTrim( Str( ProcLine( nLevel ) ) ) + ") " + NEXT + + IF desc == NIL + desc := "" + ENDIF + desc := s_cTest + " " + XToStr( desc ) + + FWrite( s_fhnd, cStack + " " + desc + hb_OSNewLine() ) + FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) + FWrite( s_fhnd, " s_xVar " + XToStr( s_xVar ) + hb_OSNewLine() ) + FWrite( s_fhnd, " xResult " + XToStr( xResult ) + hb_OSNewLine() ) + IF ISOBJECT( o ) + FWrite( s_fhnd, " Block " + XToStr( o:Block ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Cargo " + XToStr( o:Cargo ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColorBlock " + XToStr( o:ColorBlock ) + hb_OSNewLine() ) + FWrite( s_fhnd, " ColSep " + XToStr( o:ColSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " DefColor " + XToStr( o:DefColor ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Footing " + XToStr( o:Footing ) + hb_OSNewLine() ) + FWrite( s_fhnd, " FootSep " + XToStr( o:FootSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Heading " + XToStr( o:Heading ) + hb_OSNewLine() ) + FWrite( s_fhnd, " HeadSep " + XToStr( o:HeadSep ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Picture " + XToStr( o:Picture ) + hb_OSNewLine() ) + FWrite( s_fhnd, " Width " + XToStr( o:Width ) + hb_OSNewLine() ) +#ifndef __HARBOUR__ + IF s_lC5xDump + FWrite( s_fhnd, " _dump_ " + ObjToList( o ) + hb_OSNewLine() ) + ENDIF +#endif + ELSE + FWrite( s_fhnd, " o " + XToStr( o ) + hb_OSNewLine() ) + ENDIF + FWrite( s_fhnd, "---------------------" + hb_OSNewLine() ) + + RETURN + +STATIC FUNCTION ObjToList( o ) + LOCAL cString := "" + LOCAL tmp + + FOR tmp := 1 TO Len( o ) + cString += XToStr( o[ tmp ] ) + IF tmp < Len( o ) + cString += ", " + ENDIF + NEXT + + RETURN cString + +FUNCTION XToStr( xValue ) + LOCAL cType := ValType( xValue ) + + DO CASE + CASE cType == "C" + + xValue := StrTran( xValue, Chr(0), '"+Chr(0)+"' ) + xValue := StrTran( xValue, Chr(9), '"+Chr(9)+"' ) + xValue := StrTran( xValue, Chr(10), '"+Chr(10)+"' ) + xValue := StrTran( xValue, Chr(13), '"+Chr(13)+"' ) + xValue := StrTran( xValue, Chr(26), '"+Chr(26)+"' ) + + RETURN '"' + xValue + '"' + + CASE cType == "N" ; RETURN LTrim( Str( xValue ) ) + CASE cType == "D" ; RETURN 'HB_SToD("' + DToS( xValue ) + '")' + CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." ) + CASE cType == "O" ; RETURN xValue:className() + " Object" + CASE cType == "U" ; RETURN "NIL" + CASE cType == "B" ; RETURN '{||...} -> ' + XToStr( Eval( xValue ) ) + CASE cType == "A" ; RETURN '{ ' + ArrayToList( xValue ) + ' }' + CASE cType == "M" ; RETURN 'M:"' + xValue + '"' + ENDCASE + + RETURN "" + +FUNCTION ArrayToList( a ) + LOCAL tmp + LOCAL cString := "" + + FOR tmp := 1 TO Len( a ) + cString += XToStr( a[ tmp ] ) + IF tmp < Len( a ) + cString += ", " + ENDIF + NEXT + + RETURN cString + +FUNCTION XToStrE( xValue ) + LOCAL cType := ValType( xValue ) + + DO CASE + CASE cType == "C" + + xValue := StrTran( xValue, Chr(0), '"+Chr(0)+"' ) + xValue := StrTran( xValue, Chr(9), '"+Chr(9)+"' ) + xValue := StrTran( xValue, Chr(10), '"+Chr(10)+"' ) + xValue := StrTran( xValue, Chr(13), '"+Chr(13)+"' ) + xValue := StrTran( xValue, Chr(26), '"+Chr(26)+"' ) + + RETURN xValue + + CASE cType == "N" ; RETURN LTrim( Str( xValue ) ) + CASE cType == "D" ; RETURN DToS( xValue ) + CASE cType == "L" ; RETURN iif( xValue, ".T.", ".F." ) + CASE cType == "O" ; RETURN xValue:className() + " Object" + CASE cType == "U" ; RETURN "NIL" + CASE cType == "B" ; RETURN '{||...} -> ' + XToStrE( Eval( xValue ) ) + CASE cType == "A" ; RETURN '{ ' + ArrayToEList( xValue ) + ' }' + CASE cType == "M" ; RETURN 'M:' + xValue + ENDCASE + + RETURN "" + +FUNCTION ArrayToEList( a ) + LOCAL tmp + LOCAL cString := "" + + FOR tmp := 1 TO Len( a ) + cString += XToStrE( a[ tmp ] ) + IF tmp < Len( a ) + cString += ", " + ENDIF + NEXT + + RETURN cString + +STATIC FUNCTION ErrorMessage( oError ) + LOCAL cMessage + LOCAL tmp + + IF s_lRTEDetails + + cMessage := "" + + IF ValType( oError:severity ) == "N" + DO CASE + CASE oError:severity == ES_WHOCARES ; cMessage += "M " + CASE oError:severity == ES_WARNING ; cMessage += "W " + CASE oError:severity == ES_ERROR ; cMessage += "E " + CASE oError:severity == ES_CATASTROPHIC ; cMessage += "C " + ENDCASE + ENDIF + IF ValType( oError:subsystem ) == "C" + cMessage += oError:subsystem + " " + ENDIF + IF ValType( oError:subCode ) == "N" + cMessage += LTrim( Str( oError:subCode ) ) + " " + ENDIF + IF ValType( oError:description ) == "C" + cMessage += oError:description + " " + ENDIF + IF !Empty( oError:operation ) .AND. !s_lIgnoreErrOp + cMessage += oError:operation + " " + ENDIF + IF !Empty( oError:filename ) + cMessage += oError:filename + " " + ENDIF + + IF ValType( oError:Args ) == "A" + cMessage += "A:" + LTrim( Str( Len( oError:Args ) ) ) + ":" + FOR tmp := 1 TO Len( oError:Args ) + cMessage += ValType( oError:Args[ tmp ] ) + ":" + XToStrE( oError:Args[ tmp ] ) + IF tmp < Len( oError:Args ) + cMessage += ";" + ENDIF + NEXT + cMessage += " " + ENDIF + + IF oError:canDefault .OR. ; + oError:canRetry .OR. ; + oError:canSubstitute + + cMessage += "F:" + IF oError:canDefault + cMessage += "D" + ENDIF + IF oError:canRetry + cMessage += "R" + ENDIF + IF oError:canSubstitute + cMessage += "S" + ENDIF + ENDIF + ELSE + cMessage := "(ERROR)" + ENDIF + + RETURN cMessage + +#ifdef __XPP__ +FUNCTION hb_SToD( cDate ) + RETURN SToD( cDate ) +#endif + +#ifndef HAVE_HBCLIP +#ifndef __HARBOUR__ +#ifndef __XPP__ + +FUNCTION hb_SToD( cDate ) + LOCAL cOldDateFormat + LOCAL dDate + + IF ValType( cDate ) == "C" .AND. !Empty( cDate ) + cOldDateFormat := Set( _SET_DATEFORMAT, "yyyy/mm/dd" ) + + dDate := CToD( SubStr( cDate, 1, 4 ) + "/" +; + SubStr( cDate, 5, 2 ) + "/" +; + SubStr( cDate, 7, 2 ) ) + + Set( _SET_DATEFORMAT, cOldDateFormat ) + ELSE + dDate := CToD( "" ) + ENDIF + + RETURN dDate + +#endif +#endif +#endif + +PROCEDURE OBJ_CREATE() + + // ; Dummy + + RETURN