From 9303fd7c30e126da76cd6865b9118b201c277e00 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Mon, 17 Sep 2007 10:28:19 +0000 Subject: [PATCH] 2007-09-17 12:25 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) * common.mak + source/rtl/tbrowsys.prg * source/rtl/Makefile * source/rtl/getsys.prg * source/rtl/tbrowse.prg + Added new file for C5.3 TB*() functions. Most of them is dummy, a few of them were moved here from existing files. * include/hbextern.ch + Added rest of C5.3 TB*() functions. * source/rtl/teditor.prg ! Fixed new scope violations reported by Guillermo. * source/rtl/tbrowse.prg + :border implemented (to be tested). ! :setColumn() return value fixed, NOTE added. ! Non-character :picture handled properly. (to be tested for full compatibility) % Some optimizations. - :TApplyKey() removed (it is not a C5.3 method) ; Some source cleanup and other changes. ; Work in progress. * include/hbextern.ch * common.mak * source/rtl/Makefile + source/rtl/tscalar.prg - source/rtl/array.prg - source/rtl/block.prg - source/rtl/characte.prg - source/rtl/date.prg - source/rtl/logical.prg - source/rtl/nil.prg - source/rtl/numeric.prg - source/rtl/scalar.prg + Consolidated scalar classes to one file. + Minor optimizations and cleanup done on files. + Class function names now consistently HB*() (was non-Class(y) compatible and a mixed list of plain unprefixed class names and class names prefixed with an underscore). Notice however that Class(y) has only CsyArray() defined in its own library, the rest was seemingly made only available as additional source code. ! Fixed NIL class to be named NIL (was _NIL). % Some unneeded MESSAGE redirections removed. % LOCAL var[0] -> LOCAL var := {}. This results in better pcode. + Added all these symbols to hbextern.ch * source/rtl/symbol.prg * Some cleanup. ; I believe this should be named HBSymbol() and added to hbextern.ch --- harbour/ChangeLog | 58 ++++ harbour/common.mak | 10 +- harbour/include/hbextern.ch | 25 ++ harbour/source/rtl/Makefile | 10 +- harbour/source/rtl/array.prg | 190 ----------- harbour/source/rtl/block.prg | 64 ---- harbour/source/rtl/characte.prg | 68 ---- harbour/source/rtl/date.prg | 69 ---- harbour/source/rtl/getsys.prg | 12 - harbour/source/rtl/logical.prg | 64 ---- harbour/source/rtl/nil.prg | 64 ---- harbour/source/rtl/numeric.prg | 63 ---- harbour/source/rtl/scalar.prg | 118 ------- harbour/source/rtl/symbol.prg | 15 +- harbour/source/rtl/tbrowse.prg | 574 +++++++++++++++++++------------- harbour/source/rtl/teditor.prg | 130 ++++---- harbour/source/rtl/tscalar.prg | 315 ++++++++++++++++++ 17 files changed, 825 insertions(+), 1024 deletions(-) delete mode 100644 harbour/source/rtl/array.prg delete mode 100644 harbour/source/rtl/block.prg delete mode 100644 harbour/source/rtl/characte.prg delete mode 100644 harbour/source/rtl/date.prg delete mode 100644 harbour/source/rtl/logical.prg delete mode 100644 harbour/source/rtl/nil.prg delete mode 100644 harbour/source/rtl/numeric.prg delete mode 100644 harbour/source/rtl/scalar.prg create mode 100644 harbour/source/rtl/tscalar.prg diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 370295ae0b..345ad2a550 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -8,6 +8,64 @@ 2002-12-01 13:30 UTC+0100 Foo Bar */ +2007-09-17 12:25 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) + * common.mak + + source/rtl/tbrowsys.prg + * source/rtl/Makefile + * source/rtl/getsys.prg + * source/rtl/tbrowse.prg + + Added new file for C5.3 TB*() functions. + Most of them is dummy, a few of them were moved + here from existing files. + + * include/hbextern.ch + + Added rest of C5.3 TB*() functions. + + * source/rtl/teditor.prg + ! Fixed new scope violations reported by Guillermo. + + * source/rtl/tbrowse.prg + + :border implemented (to be tested). + ! :setColumn() return value fixed, NOTE added. + ! Non-character :picture handled properly. + (to be tested for full compatibility) + % Some optimizations. + - :TApplyKey() removed (it is not a C5.3 method) + ; Some source cleanup and other changes. + ; Work in progress. + + * include/hbextern.ch + * common.mak + * source/rtl/Makefile + + source/rtl/tscalar.prg + - source/rtl/array.prg + - source/rtl/block.prg + - source/rtl/characte.prg + - source/rtl/date.prg + - source/rtl/logical.prg + - source/rtl/nil.prg + - source/rtl/numeric.prg + - source/rtl/scalar.prg + + Consolidated scalar classes to one file. + + Minor optimizations and cleanup done on files. + + Class function names now consistently HB*() + (was non-Class(y) compatible and a mixed list + of plain unprefixed class names and class names + prefixed with an underscore). Notice however that + Class(y) has only CsyArray() defined in its own + library, the rest was seemingly made only + available as additional source code. + ! Fixed NIL class to be named NIL (was _NIL). + % Some unneeded MESSAGE redirections removed. + % LOCAL var[0] -> LOCAL var := {}. This results + in better pcode. + + Added all these symbols to hbextern.ch + + * source/rtl/symbol.prg + * Some cleanup. + ; I believe this should be named HBSymbol() and + added to hbextern.ch + 2007-09-16 22:45 UTC+0200 Przemyslaw Czerpak (druzus/at/priv.onet.pl) * harbour/source/compiler/hbopt.c ! fixed bad typo in last modification - thanks to Viktor diff --git a/harbour/common.mak b/harbour/common.mak index 744b0cd225..ee7e17756b 100644 --- a/harbour/common.mak +++ b/harbour/common.mak @@ -527,15 +527,11 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\adir$(OBJEXT) \ $(OBJ_DIR)\alert$(OBJEXT) \ $(OBJ_DIR)\altd$(OBJEXT) \ - $(OBJ_DIR)\array$(OBJEXT) \ - $(OBJ_DIR)\block$(OBJEXT) \ $(OBJ_DIR)\browdb$(OBJEXT) \ $(OBJ_DIR)\browdbx$(OBJEXT) \ $(OBJ_DIR)\browse$(OBJEXT) \ - $(OBJ_DIR)\characte$(OBJEXT) \ $(OBJ_DIR)\checkbox$(OBJEXT) \ $(OBJ_DIR)\color53$(OBJEXT) \ - $(OBJ_DIR)\date$(OBJEXT) \ $(OBJ_DIR)\dbedit$(OBJEXT) \ $(OBJ_DIR)\devoutp$(OBJEXT) \ $(OBJ_DIR)\dircmd$(OBJEXT) \ @@ -548,13 +544,10 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\hbini$(OBJEXT) \ $(OBJ_DIR)\input$(OBJEXT) \ $(OBJ_DIR)\listbox$(OBJEXT) \ - $(OBJ_DIR)\logical$(OBJEXT) \ $(OBJ_DIR)\memoedit$(OBJEXT) \ $(OBJ_DIR)\memvarbl$(OBJEXT) \ $(OBJ_DIR)\menuto$(OBJEXT) \ $(OBJ_DIR)\menusys$(OBJEXT) \ - $(OBJ_DIR)\nil$(OBJEXT) \ - $(OBJ_DIR)\numeric$(OBJEXT) \ $(OBJ_DIR)\objfunc$(OBJEXT) \ $(OBJ_DIR)\perfuncs$(OBJEXT) \ $(OBJ_DIR)\persist$(OBJEXT) \ @@ -564,13 +557,13 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\radiogrp$(OBJEXT) \ $(OBJ_DIR)\readkey$(OBJEXT) \ $(OBJ_DIR)\readvar$(OBJEXT) \ - $(OBJ_DIR)\scalar$(OBJEXT) \ $(OBJ_DIR)\scrollbr$(OBJEXT) \ $(OBJ_DIR)\setfunc$(OBJEXT) \ $(OBJ_DIR)\setta$(OBJEXT) \ $(OBJ_DIR)\symbol$(OBJEXT) \ $(OBJ_DIR)\tbcolumn$(OBJEXT) \ $(OBJ_DIR)\tbrowse$(OBJEXT) \ + $(OBJ_DIR)\tbrowsys$(OBJEXT) \ $(OBJ_DIR)\tclass$(OBJEXT) \ $(OBJ_DIR)\teditor$(OBJEXT) \ $(OBJ_DIR)\text$(OBJEXT) \ @@ -583,6 +576,7 @@ RTL_LIB_OBJS = \ $(OBJ_DIR)\tobject$(OBJEXT) \ $(OBJ_DIR)\tpopup$(OBJEXT) \ $(OBJ_DIR)\treport$(OBJEXT) \ + $(OBJ_DIR)\tscalar$(OBJEXT) \ $(OBJ_DIR)\ttextlin$(OBJEXT) \ $(OBJ_DIR)\ttopbar$(OBJEXT) \ $(OBJ_DIR)\typefile$(OBJEXT) \ diff --git a/harbour/include/hbextern.ch b/harbour/include/hbextern.ch index 11a9092d2f..3569d59ba5 100644 --- a/harbour/include/hbextern.ch +++ b/harbour/include/hbextern.ch @@ -416,6 +416,14 @@ EXTERNAL HB_INIWRITE EXTERNAL HBCLASS EXTERNAL HBOBJECT +EXTERNAL HBSCALAR +EXTERNAL HBARRAY +EXTERNAL HBBLOCK +EXTERNAL HBCHARACTER +EXTERNAL HBDATE +EXTERNAL HBLOGICAL +EXTERNAL HBNIL +EXTERNAL HBNUMERIC EXTERNAL HB_LIBLOAD EXTERNAL HB_LIBFREE @@ -906,7 +914,24 @@ EXTERNAL RADIOBUTTON #endif EXTERNAL RADIOGROUP EXTERNAL TOPBAR + EXTERNAL TBMOUSE +EXTERNAL TAPPLYKEY +EXTERNAL TBADDCOL +EXTERNAL TBAPPLYKEY +EXTERNAL TBBBLOCK +EXTERNAL TBCLOSE +EXTERNAL TBCREATE +EXTERNAL TBDELCOL +EXTERNAL TBDISPLAY +EXTERNAL TBEDITCELL +EXTERNAL TBFBLOCK +EXTERNAL TBGOBOT +EXTERNAL TBGOTOP +EXTERNAL TBINSCOL +EXTERNAL TBMODAL +EXTERNAL TBSBLOCK +EXTERNAL TBSKIP EXTERNAL GETCLRPAIR EXTERNAL SETCLRPAIR diff --git a/harbour/source/rtl/Makefile b/harbour/source/rtl/Makefile index ddc21ff0ed..5fa69cb9e3 100644 --- a/harbour/source/rtl/Makefile +++ b/harbour/source/rtl/Makefile @@ -139,15 +139,11 @@ PRG_SOURCES=\ adir.prg \ alert.prg \ altd.prg \ - array.prg \ - block.prg \ browdb.prg \ browdbx.prg \ browse.prg \ - characte.prg \ checkbox.prg \ color53.prg \ - date.prg \ dbedit.prg \ devoutp.prg \ dircmd.prg \ @@ -160,13 +156,10 @@ PRG_SOURCES=\ hbini.prg \ input.prg \ listbox.prg \ - logical.prg \ memoedit.prg \ memvarbl.prg \ menuto.prg \ menusys.prg \ - nil.prg \ - numeric.prg \ objfunc.prg \ perfuncs.prg \ persist.prg \ @@ -176,7 +169,6 @@ PRG_SOURCES=\ radiogrp.prg \ readkey.prg \ readvar.prg \ - scalar.prg \ scrollbr.prg \ setfunc.prg \ setta.prg \ @@ -184,6 +176,7 @@ PRG_SOURCES=\ tclass.prg \ tbcolumn.prg \ tbrowse.prg \ + tbrowsys.prg \ teditor.prg \ text.prg \ tget.prg \ @@ -195,6 +188,7 @@ PRG_SOURCES=\ tobject.prg \ tpopup.prg \ treport.prg \ + tscalar.prg \ ttextlin.prg \ ttopbar.prg \ typefile.prg \ diff --git a/harbour/source/rtl/array.prg b/harbour/source/rtl/array.prg deleted file mode 100644 index 5f666b6bd1..0000000000 --- a/harbour/source/rtl/array.prg +++ /dev/null @@ -1,190 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Array - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS Array INHERIT ScalarObject FUNCTION HBArray - - METHOD Init() - - METHOD AsString() - MESSAGE At METHOD AtIndex // 'at' is a reserved word - METHOD AtPut() - MESSAGE Add METHOD Append - METHOD AddAll() - METHOD Append() - 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 AtIndex( n ) CLASS Array - -return Self[ n ] - -METHOD AtPut( n, x ) CLASS Array - -return Self[ n ] := x - -METHOD Append( x ) CLASS Array - - AAdd( Self, x ) - -return .t. - -METHOD Collect( b ) CLASS Array - - local i, currElem - local result[ 0 ] - 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 i - local nElems := Len( Self ) - - 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 diff --git a/harbour/source/rtl/block.prg b/harbour/source/rtl/block.prg deleted file mode 100644 index 49db6c8867..0000000000 --- a/harbour/source/rtl/block.prg +++ /dev/null @@ -1,64 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Block - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS Block INHERIT ScalarObject - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS Block - -return "{ || ... }" - diff --git a/harbour/source/rtl/characte.prg b/harbour/source/rtl/characte.prg deleted file mode 100644 index 2e29d9e832..0000000000 --- a/harbour/source/rtl/characte.prg +++ /dev/null @@ -1,68 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Character - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS Character INHERIT ScalarObject - - METHOD AsString() - METHOD AsExpStr() - -ENDCLASS - -METHOD AsString() CLASS Character - -return Self - -METHOD AsExpStr() CLASS Character - -return ["] + Self + ["] diff --git a/harbour/source/rtl/date.prg b/harbour/source/rtl/date.prg deleted file mode 100644 index 1b56398812..0000000000 --- a/harbour/source/rtl/date.prg +++ /dev/null @@ -1,69 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Date - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS Date INHERIT ScalarObject FUNCTION HBDate - - METHOD AsString() - METHOD AsExpStr() - -ENDCLASS - -METHOD AsString() CLASS Date - -return DToC( Self ) - -METHOD AsExpStr() CLASS Date - -return [CToD("] + ::AsString() + [")] - diff --git a/harbour/source/rtl/getsys.prg b/harbour/source/rtl/getsys.prg index ca946239f9..8269da42fe 100644 --- a/harbour/source/rtl/getsys.prg +++ b/harbour/source/rtl/getsys.prg @@ -335,18 +335,6 @@ FUNCTION RangeCheck( oGet, xDummy, xLow, xHigh ) #ifdef HB_COMPAT_C53 -PROCEDURE TBReader( oGet, oGetList, oMenu, aMsg ) - - IF !ISOBJECT( oGetList ) - oGetList := __GetListActive() - ENDIF - - IF oGetList != NIL - oGetlist:TBReader( oGet, oMenu, aMsg ) - ENDIF - - RETURN - PROCEDURE GUIReader( oGet, oGetlist, oMenu, aMsg ) IF !ISOBJECT( oGetList ) diff --git a/harbour/source/rtl/logical.prg b/harbour/source/rtl/logical.prg deleted file mode 100644 index 44e176de8d..0000000000 --- a/harbour/source/rtl/logical.prg +++ /dev/null @@ -1,64 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Logical - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS Logical INHERIT ScalarObject - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS Logical - -return iif( Self, ".T.", ".F." ) - diff --git a/harbour/source/rtl/nil.prg b/harbour/source/rtl/nil.prg deleted file mode 100644 index 4806976c6c..0000000000 --- a/harbour/source/rtl/nil.prg +++ /dev/null @@ -1,64 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Nil - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS _Nil INHERIT ScalarObject - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS _Nil - -return "NIL" - diff --git a/harbour/source/rtl/numeric.prg b/harbour/source/rtl/numeric.prg deleted file mode 100644 index d91f2e5c22..0000000000 --- a/harbour/source/rtl/numeric.prg +++ /dev/null @@ -1,63 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class Numeric - * - * 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. - * - */ - -#include "hbclass.ch" - -CREATE CLASS Numeric INHERIT ScalarObject - - METHOD AsString() - -ENDCLASS - -METHOD AsString() CLASS Numeric - -return LTrim( Str( Self ) ) diff --git a/harbour/source/rtl/scalar.prg b/harbour/source/rtl/scalar.prg deleted file mode 100644 index 56369813ec..0000000000 --- a/harbour/source/rtl/scalar.prg +++ /dev/null @@ -1,118 +0,0 @@ -/* - * $Id$ - */ - -/* - * Harbour Project source code: - * Harbour implementation of Class(y) Class ScalarObject - * - * 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 - - MESSAGE Become METHOD BecomeErr() // a scalar cannot "become" another object - METHOD Copy() - MESSAGE DeepCopy METHOD Copy() - METHOD IsScalar() - METHOD AsString() - METHOD AsExpStr() - -ENDCLASS - -METHOD Copy() CLASS ScalarObject - -return Self - -METHOD IsScalar() CLASS ScalarObject - -return .t. - -METHOD AsString() CLASS ScalarObject - - local cType := ValType( Self ) - - do case - case cType == "B" - return "{ || ... }" - - case cType == "C" - return Self - - case cType == "D" - return DToC( Self ) - - case cType == "L" - return iif( Self, ".T.", ".F." ) - - case cType == "N" - return LTrim( Str( Self ) ) - - case cType == "U" - return "NIL" - endcase - -return "Error!" - -METHOD AsExpStr() CLASS ScalarObject - - local cType := ValType( Self ) - - if cType == "C" - return ["] + Self + ["] - elseif cType == "D" - return [CToD("] + DToC( Self ) + [")] - endif - -return ::AsString() - -METHOD BecomeErr() CLASS ScalarObject - // Not implemented yet - // ::error( CSYERR_BECOME, "Message 'become' illegally sent to scalar", ::ClassName() ) -return NIL diff --git a/harbour/source/rtl/symbol.prg b/harbour/source/rtl/symbol.prg index db221d8e8f..facf7edf55 100644 --- a/harbour/source/rtl/symbol.prg +++ b/harbour/source/rtl/symbol.prg @@ -54,10 +54,6 @@ CREATE CLASS Symbol - PROTECTED: - - VAR nSym // internal pointer to the Symbols table symbol - EXPORT: METHOD New( cSymName ) // Constructor. cSymName may already exists or not @@ -65,18 +61,21 @@ CREATE CLASS Symbol METHOD isEqual( oSymbol ) // Compares two symbol objects METHOD exec() // Executes the function referred to by the // Symbol object, with an optional parameters list + PROTECTED: + + VAR nSym // internal pointer to the Symbols table symbol ENDCLASS METHOD New( cSymName ) CLASS Symbol ::nSym := __DynSN2Sym( cSymName ) -return Self + RETURN Self METHOD name() CLASS Symbol -return ::nSym:Name + RETURN ::nSym:Name METHOD isEqual( oSymbol ) CLASS Symbol -return ::ClassH == oSymbol:ClassH .AND. ::nSym:Name == oSymbol:nSym:Name + RETURN ::ClassH == oSymbol:ClassH .AND. ::nSym:Name == oSymbol:nSym:Name METHOD exec( ... ) CLASS Symbol -return ::nSym:exec( ... ) + RETURN ::nSym:exec( ... ) diff --git a/harbour/source/rtl/tbrowse.prg b/harbour/source/rtl/tbrowse.prg index 3d6e4cc86f..607eb44e26 100644 --- a/harbour/source/rtl/tbrowse.prg +++ b/harbour/source/rtl/tbrowse.prg @@ -83,6 +83,9 @@ Determines the coordinates for the data area of a TBrowse object. Xbase++ compatible method */ +/* NOTE: These TBColumn properties are _not_ cached inside TBrowse: + :picture, :block, :colorBlock */ + #include "hbclass.ch" #include "button.ch" @@ -95,27 +98,34 @@ /* TBColumn info constants */ #define TBCI_OBJ 1 // Object TBColumn -#define TBCI_TYPE 2 // Type of Data in Column -#define TBCI_WIDTH 3 // Column Width +#define TBCI_WIDTH 2 // Column Width +#define TBCI_WIDTHCELL 3 // Width of the Cell #define TBCI_HEADING 4 // Column Headings #define TBCI_FOOTING 5 // Column Footings -#define TBCI_PICT 6 // Column Picture -#define TBCI_WIDTHCELL 7 // Width of the Cell -#define TBCI_COLSEP 8 // Column Seperator -#define TBCI_SEPWIDTH 9 // Width of the Separator -#define TBCI_DEFCOLOR 10 // Array with index of color -#define TBCI_SETWIDTH 11 // If True, only SetFrozen can change TBCI_WIDTH -#define TBCI_LCOLSEP 12 // Should column separator be drawn -#define TBCI_SCRCOLPOS 13 // Temporary column position on screen +#define TBCI_COLSEP 6 // Column Seperator +#define TBCI_SEPWIDTH 7 // Width of the Separator +#define TBCI_DEFCOLOR 8 // Array with index of color +#define TBCI_SETWIDTH 9 // If True, only SetFrozen can change TBCI_WIDTH +#define TBCI_LCOLSEP 10 // Should column separator be drawn +#define TBCI_SCRCOLPOS 11 // Temporary column position on screen + +//#define TBCI_COLOBJECT 1 // column object +//#define TBCI_CELLWIDTH 2 // width of the cell +//#define TBCI_COLWIDTH 3 // width of the column +//#define TBCI_SCRCELLPOS 4 // cell position on screen +//#define TBCI_SCRCOLPOS 5 // column position on screen +//#define TBCI_SEPWIDTH 6 // width of the separator #define TBC_CLR_STANDARD 1 // first index value to set unselected data color. #define TBC_CLR_ENHANCED 2 // second index value to set selected data color. #ifdef HB_COMPAT_C53 #define TBC_CLR_HEADING 3 // third index value to set heading color. #define TBC_CLR_FOOTING 4 // fourth index value to set footing color. +#define TBC_CLR_MAX_ 4 #else #define TBC_CLR_HEADING TBC_CLR_STANDARD #define TBC_CLR_FOOTING TBC_CLR_STANDARD +#define TBC_CLR_MAX_ 2 #endif /* NOTE: In CA-Cl*pper TBROWSE class does not inherit from any other classes @@ -170,7 +180,6 @@ CREATE CLASS TBrowse #ifdef HB_COMPAT_C53 METHOD setKey( nKey, bBlock ) METHOD applyKey( nKey ) - METHOD TApplyKey( nKey, o ) /* NOTE: Undocumented CA-Cl*pper 5.3 method. */ METHOD hitTest( nMRow, nMCol ) METHOD setStyle( nStyle, lNewValue ) #endif @@ -199,6 +208,7 @@ CREATE CLASS TBrowse METHOD freeze( nFrozenCols ) SETGET METHOD skipBlock( bSkipBlock ) SETGET #ifdef HB_COMPAT_C53 + METHOD border( cBorder ) SETGET METHOD nRow( nRow ) SETGET /* NOTE: Undocumented CA-Cl*pper 5.3 method. */ METHOD nCol( nCol ) SETGET /* NOTE: Undocumented CA-Cl*pper 5.3 method. */ METHOD mRowPos( nMRowPos ) SETGET @@ -215,6 +225,7 @@ CREATE CLASS TBrowse VAR n_Left INIT 0 // Leftmost column for the TBrowse display VAR n_Bottom INIT 0 // Bottom row number for the TBrowse display VAR n_Right INIT 0 // Rightmost column for the TBrowse display + VAR cBorder // Character value defining characters drawn around object (C5.3) VAR cColorSpec // Color table for the TBrowse display VAR aColorSpec // Color table for the TBrowse display (preprocessed) VAR cColSep INIT " " // Column separator character @@ -251,6 +262,7 @@ CREATE CLASS TBrowse VAR nFrozenCols INIT 0 // Number of frozen columns on left side of TBrowse VAR nColumns INIT 0 // Number of columns added to TBrowse VAR lNeverDisplayed INIT .T. // .T. if TBrowse has never been stabilized() + VAR lHiLited INIT .F. #ifdef HB_COMPAT_C53 VAR n_Row INIT 0 // Row number for the actual cell VAR n_Col INIT 0 // Col number for the actual cell @@ -312,6 +324,30 @@ METHOD configure( nMode ) CLASS TBrowse local nRight #endif + // ; Fill the column info array +/* + local xVal + + if nMode == 2 + + for n := 1 to ::nColumns + + xVal := Eval( ::aColumns[ n ]:block ) + + aCol[ TBCI_HEADING ] := ::aColumns[ n ]:heading + aCol[ TBCI_FOOTING ] := ::aColumns[ n ]:footing + aCol[ TBCI_WIDTH ] := ::SetColumnWidth( ::aColumns[ n ] ) + aCol[ TBCI_WIDTHCELL ] := Min( aCol[ TBCI_WIDTH ], tbr_CalcWidth( xVal, ValType( xValue ), ::aColumns[ n ]:picture ) ) + aCol[ TBCI_COLSEP ] := iif( aCol[ TBCI_OBJ ]:ColSep != NIL, aCol[ TBCI_OBJ ]:ColSep, ::ColSep ) + aCol[ TBCI_DEFCOLOR ] := tbr_DefColor( ::aColumns[ n ]:defColor, ::aColorSpec ) + aCol[ TBCI_SEPWIDTH ] := Len( aCol[ TBCI_COLSEP ] ) + aCol[ TBCI_LCOLSEP ] := aCol[ TBCI_WIDTH ] > 0 + aCol[ TBCI_COLSEP ] := iif( aCol[ TBCI_OBJ ]:ColSep != NIL, aCol[ TBCI_OBJ ]:ColSep, ::ColSep ) + next + endif +*/ + // ; + ::lHeaders := .F. ::lFooters := .F. ::lRedrawFrame := .T. @@ -462,6 +498,7 @@ METHOD insColumn( nPos, oCol ) CLASS TBrowse ::aColumns[ nPos ] := oCol ::aColsWidth[ nPos ] := ::SetColumnWidth( oCol ) ::aColsPos[ nPos ] := 0 + ::aColsInfo[ nPos ] := ::InitColumn( oCol, .F. ) endif @@ -474,12 +511,16 @@ METHOD insColumn( nPos, oCol ) CLASS TBrowse // Replaces one TBColumn object with another METHOD setColumn( nPos, oCol ) CLASS TBrowse + LOCAL oOldCol + /* NOTE: CA-Cl*pper doesn't check this, but crashes instead. */ if nPos >= 1 .and. nPos <= ::nColumns ::Moved() /* TOFIX: This logic should go inside ::configure() */ + oOldCol := ::aColumns[ nPos ] + ::aColumns[ nPos ] := oCol ::aColsWidth[ nPos ] := ::SetColumnWidth( oCol ) ::aColsPos[ nPos ] := 0 @@ -489,7 +530,15 @@ METHOD setColumn( nPos, oCol ) CLASS TBrowse endif - return oCol + /* NOTE: CA-Cl*pper 5.2 NG says this will return the previously set + column, but it's returning Self instead. In C5.3 this bug + was fixed and it works as expected (except when wrong + parameter is passed, when it returns NIL). [vszakats] */ +#ifdef HB_C52_STRICT + return Self +#else + return oOldCol +#endif METHOD delColumn( nPos ) CLASS TBrowse @@ -542,7 +591,7 @@ METHOD colWidth( nColumn ) CLASS TBrowse return iif( nColumn > 0 .and. nColumn <= ::nColumns, ::aColsWidth[ nColumn ], 0 ) METHOD colCount() CLASS TBrowse - return ::nColumns + return Len( ::aColumns ) METHOD freeze( nFrozenCols ) CLASS TBrowse @@ -850,58 +899,63 @@ METHOD panRight() CLASS TBrowse METHOD forceStable() CLASS TBrowse - do while !::Stabilize() - enddo + DO WHILE !::Stabilize() + ENDDO - return Self + RETURN Self METHOD deHilite() CLASS TBrowse local nRow - local cType + LOCAL nCol - if ::nColPos > 0 .and. ::nColPos <= Len( ::aColumns ) + IF ::rowPos < 1 .OR. ::rowPos > ::rowCount + ::rowPos := 0 + ELSEIF ::nColPos > 0 .AND. ::nColPos <= Len( ::aColumns ) - nRow := ::n_Top + ::nRowPos + iif( ::lHeaders, ::nHeaderHeight, 0 ) + iif( Empty( ::cHeadSep ) .or. ! ::lHeaders, 0, 1 ) - 1 + nRow := ::n_Top +; // TOFIX + ::nRowPos +; + iif( ::lHeaders, ::nHeaderHeight, 0 ) +; + iif( Empty( ::cHeadSep ) .or. ! ::lHeaders, 0, 1 ) - 1 + nCol := ::aColsPos[ ::nColPos ] // TOFIX - SetPos( nRow, ::aColsPos[ ::nColPos ] ) - - cType := ::DispCell( ::nRowPos, ::nColPos, TBC_CLR_STANDARD ) - - SetPos( nRow, ::aColsPos[ ::nColPos ] + iif( cType == "L", ::aColsWidth[ ::nColPos ] / 2, 0 ) ) + SetPos( nRow, nCol ) // TOFIX + nCol += ::DispCell( ::nRowPos, ::nColPos, TBC_CLR_STANDARD ) + SetPos( nRow, nCol ) + ENDIF - endif + ::lHiLited := .F. - return Self + RETURN Self METHOD hilite() CLASS TBrowse - local nRow - local nCol - local cType + LOCAL nRow + LOCAL nCol - if ::nColPos > 0 .and. ::nColPos <= Len( ::aColumns ) + IF ::rowPos < 1 .OR. ::rowPos > ::rowCount + ::rowPos := 0 + ELSEIF ::nColPos >= 1 .AND. ::nColPos <= Len( ::aColumns ) - nRow := ::n_Top + ::nRowPos + iif( ::lHeaders, ::nHeaderHeight, 0 ) + iif( Empty( ::cHeadSep ) .or. ! ::lHeaders, 0, 1 ) - 1 - nCol := ::aColsPos[ ::nColPos ] + nRow := ::n_Top +; // TOFIX + ::nRowPos +; + iif( ::lHeaders, ::nHeaderHeight, 0 ) +; + iif( Empty( ::cHeadSep ) .or. ! ::lHeaders, 0, 1 ) - 1 + nCol := ::aColsPos[ ::nColPos ] // TOFIX - // Start of cell SetPos( nRow, nCol ) - - cType := ::DispCell( ::nRowPos, ::nColPos, TBC_CLR_ENHANCED ) - nCol += iif( cType == "L", ::aColsWidth[ ::nColPos ] / 2, 0 ) - - // Put cursor back on first char of cell value + nCol += ::DispCell( ::nRowPos, ::nColPos, TBC_CLR_ENHANCED ) SetPos( nRow, nCol ) + + ::lHiLited := .T. + ENDIF - #ifdef HB_COMPAT_C53 - ::n_Row := nRow - ::n_Col := nCol - #endif + #ifdef HB_COMPAT_C53 + ::n_Row := nRow + ::n_Col := nCol + #endif - endif - - return Self + RETURN Self METHOD stabilize() CLASS TBrowse @@ -923,6 +977,12 @@ METHOD stabilize() CLASS TBrowse // I need to set columns width If TBrowse was never displayed before if ::lNeverDisplayed + + if !Empty( ::cBorder ) + /* NOTE: Intentionally the external version of coordinate messages. */ + DispBox( ::nTop, ::nLeft, ::nBottom, ::nRight, ::cBorder, ::cColorSpec[ 1 ] ) + endif + ::Configure( 0 ) //AEval( ::aColumns, {| oCol | ::SetColumnWidth( oCol ) } ) @@ -1198,15 +1258,13 @@ METHOD InitColumn( oCol, lAddColumn ) CLASS TBrowse IF !lAddColumn .AND. ISOBJECT( oCol ) .AND. ISBLOCK( oCol:block ) RETURN {; oCol ,; // TBCI_OBJ - ValType( Eval( oCol:block ) ) ,; // TBCI_TYPE ::SetColumnWidth( oCol ) ,; // TBCI_WIDTH + 0 ,; // TBCI_WIDTHCELL "" ,; // TBCI_HEADING "" ,; // TBCI_FOOTING - "" ,; // TBCI_PICT - 0 ,; // TBCI_WIDTHCELL "" ,; // TBCI_COLSEP 0 ,; // TBCI_SEPWIDTH - oCol:defColor ,; // TBCI_DEFCOLOR + oCol:defColor ,; // TBCI_DEFCOLOR .F. ,; // TBCI_SETWIDTH .T. ,; // TBCI_LCOLSEP 0 } // TBCI_SCRCOLPOS @@ -1214,15 +1272,13 @@ METHOD InitColumn( oCol, lAddColumn ) CLASS TBrowse RETURN {; oCol ,; // TBCI_OBJ - "" ,; // TBCI_TYPE 0 ,; // TBCI_WIDTH + 0 ,; // TBCI_WIDTHCELL "" ,; // TBCI_HEADING "" ,; // TBCI_FOOTING - "" ,; // TBCI_PICT - 0 ,; // TBCI_WIDTHCELL "" ,; // TBCI_COLSEP 0 ,; // TBCI_SEPWIDTH - {} ,; // TBCI_DEFCOLOR + {} ,; // TBCI_DEFCOLOR .F. ,; // TBCI_SETWIDTH .T. ,; // TBCI_LCOLSEP 0 } // TBCI_SCRCOLPOS @@ -1460,56 +1516,63 @@ METHOD Moved() CLASS TBrowse METHOD DispCell( nRow, nCol, nMode ) CLASS TBrowse - local oCol := ::aColumns[ nCol ] - local nWidth := ::aColsWidth[ nCol ] - local ftmp := Eval( oCol:block ) - local cType := ValType( ftmp ) - local cPict := iif( Empty( oCol:Picture ), "", oCol:Picture ) - local aDefColor + LOCAL oCol := ::aColumns[ nCol ] // TOFIX + LOCAL nWidth := ::aColsWidth[ nCol ] // TOFIX + LOCAL ftmp := Eval( oCol:block ) + LOCAL cType := ValType( ftmp ) + LOCAL cPicture := oCol:Picture + LOCAL nSkip := 0 + LOCAL aDefColor + LOCAL cColor - local tmp + IF !ISCHARACTER( cPicture ) + cPicture := "" + ENDIF - local cColor - - if ! Empty( ::aRect ) .and. ; - nCol >= ::aRect[ 2 ] .and. ; - nCol <= ::aRect[ 4 ] .and. ; - nRow >= ::aRect[ 1 ] .and. ; - nRow <= ::aRect[ 3 ] .and. ; - ! Empty( ::aRectColor ) + IF ! Empty( ::aRect ) .AND. ; // TOFIX: aRect validation ? + nCol >= ::aRect[ 2 ] .AND. ; + nCol <= ::aRect[ 4 ] .AND. ; + nRow >= ::aRect[ 1 ] .AND. ; + nRow <= ::aRect[ 3 ] .AND. ; + ! Empty( ::aRectColor ) // TOFIX: ISEMPTY ? cColor := tbr_GetColor( ::aColorSpec, ::aRectColor, nMode ) - else + ELSE /* NOTE: Not very optimal that we're evaluating this block all the time. But CA-Cl*pper always has a block here, and there is no other way to tell if the code in it is NIL (the default) or something valuable. [vszakats] */ aDefColor := Eval( oCol:colorBlock, ftmp ) - cColor := tbr_GetColor( ::aColorSpec, iif( ISARRAY( aDefColor ), aDefColor, oCol:defColor ), nMode ) - endif + cColor := tbr_GetColor( ::aColorSpec, iif( ISARRAY( aDefColor ), aDefColor, oCol:defColor ), nMode ) // TOFIX: ISARRAY ? + ENDIF - do case - case cType $ "CM" - DispOut( PadR( Transform( ftmp, cPict ), nWidth ), cColor ) + SWITCH cType + CASE "C" + CASE "M" + DispOut( PadR( Transform( ftmp, cPicture ), nWidth ), cColor ) + EXIT - case cType == "N" - DispOut( PadL( Transform( ftmp, cPict ), nWidth ), cColor ) + CASE "N" + DispOut( PadL( Transform( ftmp, cPicture ), nWidth ), cColor ) + EXIT - case cType == "D" - cPict := iif( cPict == "", "@D", cPict ) - DispOut( PadR( Transform( ftmp, cPict ), nWidth ), cColor ) + CASE "D" + DispOut( PadR( Transform( ftmp, iif( cPicture == "", "@D", cPicture ) ), nWidth ), cColor ) + EXIT - case cType == "L" - tmp := PadC( "X", nWidth ) - DispOut( Space( Len( tmp ) - Len( LTrim( tmp ) ) ), cColor ) - DispOut( iif( ftmp, "T", "F" ), cColor ) - DispOut( Space( Len( tmp ) - Len( RTrim( tmp ) ) ), cColor ) + CASE "L" + ftmp := PadC( iif( ftmp, "T", "F" ), nWidth ) + nSkip := nWidth - Len( LTrim( ftmp ) ) - 1 + DispOut( Space( Len( ftmp ) - Len( LTrim( ftmp ) ) ), ::aColorSpec[ 1 ] ) + DispOut( ftmp, cColor ) + DispOut( Space( Len( ftmp ) - Len( RTrim( ftmp ) ) ), ::aColorSpec[ 1 ] ) + EXIT - otherwise + OTHERWISE DispOut( Space( nWidth ), cColor ) - endcase + ENDSWITCH - return cType + RETURN nSkip METHOD WriteMLineText( cStr, nPadLen, lHeader, cColor ) CLASS TBrowse @@ -1757,47 +1820,87 @@ METHOD autoLite( lAutoLite ) CLASS TBrowse METHOD nTop( nTop ) CLASS TBrowse - if nTop != NIL + IF nTop != NIL #ifdef HB_COMPAT_C53 ::n_Top := _eInstVar( Self, "NTOP", nTop, "N", 1001 ) + IF !Empty( ::cBorder ) + ::n_Top++ + ENDIF #else ::n_Top := _eInstVar( Self, "NTOP", nTop, "N", 1001, {| o, x | HB_SYMBOL_UNUSED( o ), x >= 0 } ) #endif ::Configure( 2 ) - endif + ENDIF - return ::n_Top + #ifdef HB_COMPAT_C53 + IF !Empty( ::cBorder ) + RETURN ::n_Top - 1 + ENDIF + #endif + + RETURN ::n_Top METHOD nLeft( nLeft ) CLASS TBrowse - if nLeft != NIL + IF nLeft != NIL #ifdef HB_COMPAT_C53 ::n_Left := _eInstVar( Self, "NLEFT", nLeft, "N", 1001 ) + IF !Empty( ::cBorder ) + ::n_Left++ + ENDIF #else ::n_Left := _eInstVar( Self, "NLEFT", nLeft, "N", 1001, {| o, x | HB_SYMBOL_UNUSED( o ), x >= 0 } ) #endif ::Configure( 2 ) - endif + ENDIF - return ::n_Left + #ifdef HB_COMPAT_C53 + IF !Empty( ::cBorder ) + RETURN ::n_Left - 1 + ENDIF + #endif + + RETURN ::n_Left METHOD nBottom( nBottom ) CLASS TBrowse - if nBottom != NIL + IF nBottom != NIL ::n_Bottom := _eInstVar( Self, "NBOTTOM", nBottom, "N", 1001, {| o, x | x >= o:nTop } ) + #ifdef HB_COMPAT_C53 + IF !Empty( ::cBorder ) + ::n_Bottom-- + ENDIF + #endif ::Configure( 2 ) - endif + ENDIF - return ::n_Bottom + #ifdef HB_COMPAT_C53 + IF !Empty( ::cBorder ) + RETURN ::n_Bottom + 1 + ENDIF + #endif + + RETURN ::n_Bottom METHOD nRight( nRight ) CLASS TBrowse - if nRight != NIL + IF nRight != NIL ::n_Right := _eInstVar( Self, "NRIGHT", nRight, "N", 1001, {| o, x | x >= o:nLeft } ) + #ifdef HB_COMPAT_C53 + IF !Empty( ::cBorder ) + ::n_Right-- + ENDIF + #endif ::Configure( 2 ) - endif + ENDIF - return ::n_Right + #ifdef HB_COMPAT_C53 + IF !Empty( ::cBorder ) + RETURN ::n_Right + 1 + ENDIF + #endif + + RETURN ::n_Right METHOD colorSpec( cColorSpec ) CLASS TBrowse @@ -1928,74 +2031,72 @@ METHOD skipBlock( bSkipBlock ) CLASS TBrowse #ifdef HB_COMPAT_C53 -METHOD ApplyKey( nKey ) CLASS TBrowse +#define _TBC_SETKEY_KEY 1 +#define _TBC_SETKEY_BLOCK 2 - return ::TApplyKey( nKey, self ) +METHOD setKey( nKey, bBlock ) CLASS TBrowse -METHOD SetKey( nKey, bBlock ) CLASS TBrowse + LOCAL bReturn + LOCAL nPos - local bReturn - local nPos + /* NOTE: Assigned codeblock receives two parameters: + {| oTBrowse, nKey | } */ - // ; Assigned codeblock receives two parameters: {| oTBrowse, nKey | } - - if ::aKeys == NIL - ::aKeys := { { K_DOWN , {| oB | oB:Down() , TBR_CONTINUE } },; - { K_END , {| oB | oB:End() , TBR_CONTINUE } },; - { K_CTRL_PGDN , {| oB | oB:GoBottom(), TBR_CONTINUE } },; - { K_CTRL_PGUP , {| oB | oB:GoTop() , TBR_CONTINUE } },; - { K_HOME , {| oB | oB:Home() , TBR_CONTINUE } },; - { K_LEFT , {| oB | oB:Left() , TBR_CONTINUE } },; - { K_PGDN , {| oB | oB:PageDown(), TBR_CONTINUE } },; - { K_PGUP , {| oB | oB:PageUp() , TBR_CONTINUE } },; - { K_CTRL_END , {| oB | oB:PanEnd() , TBR_CONTINUE } },; - { K_CTRL_HOME , {| oB | oB:PanHome() , TBR_CONTINUE } },; - { K_CTRL_LEFT , {| oB | oB:PanLeft() , TBR_CONTINUE } },; - { K_CTRL_RIGHT , {| oB | oB:PanRight(), TBR_CONTINUE } },; - { K_RIGHT , {| oB | oB:Right() , TBR_CONTINUE } },; - { K_UP , {| oB | oB:Up() , TBR_CONTINUE } },; - { K_ESC , {| | TBR_EXIT } },; - { K_LBUTTONDOWN, {| oB | TBMouse( oB, MRow(), MCol() ) } } } + IF ::aKeys == NIL + ::aKeys := { { K_DOWN , {| o | o:Down() , TBR_CONTINUE } },; + { K_END , {| o | o:End() , TBR_CONTINUE } },; + { K_CTRL_PGDN , {| o | o:GoBottom(), TBR_CONTINUE } },; + { K_CTRL_PGUP , {| o | o:GoTop() , TBR_CONTINUE } },; + { K_HOME , {| o | o:Home() , TBR_CONTINUE } },; + { K_LEFT , {| o | o:Left() , TBR_CONTINUE } },; + { K_PGDN , {| o | o:PageDown(), TBR_CONTINUE } },; + { K_PGUP , {| o | o:PageUp() , TBR_CONTINUE } },; + { K_CTRL_END , {| o | o:PanEnd() , TBR_CONTINUE } },; + { K_CTRL_HOME , {| o | o:PanHome() , TBR_CONTINUE } },; + { K_CTRL_LEFT , {| o | o:PanLeft() , TBR_CONTINUE } },; + { K_CTRL_RIGHT , {| o | o:PanRight(), TBR_CONTINUE } },; + { K_RIGHT , {| o | o:Right() , TBR_CONTINUE } },; + { K_UP , {| o | o:Up() , TBR_CONTINUE } },; + { K_ESC , {| | TBR_EXIT } },; + { K_LBUTTONDOWN, {| o | TBMouse( o, MRow(), MCol() ) } } } #ifdef HB_EXTENSION - AAdd( ::aKeys, { K_MWFORWARD , {| oB | oB:Up() , TBR_CONTINUE } } ) - AAdd( ::aKeys, { K_MWBACKWARD , {| oB | oB:Down() , TBR_CONTINUE } } ) + AAdd( ::aKeys, { K_MWFORWARD , {| o | o:Up() , TBR_CONTINUE } } ) + AAdd( ::aKeys, { K_MWBACKWARD , {| o | o:Down() , TBR_CONTINUE } } ) #endif - endif + ENDIF - if ( nPos := AScan( ::aKeys, {| x | x[ 1 ] == nKey } ) ) == 0 - if ISBLOCK( bBlock ) + IF ( nPos := AScan( ::aKeys, {| x | x[ _TBC_SETKEY_KEY ] == nKey } ) ) == 0 + IF ISBLOCK( bBlock ) AAdd( ::aKeys, { nKey, bBlock } ) - endif + ENDIF bReturn := bBlock - - elseif ISBLOCK( bBlock ) - ::aKeys[ nPos ][ 2 ] := bBlock + ELSEIF ISBLOCK( bBlock ) + ::aKeys[ nPos ][ _TBC_SETKEY_BLOCK ] := bBlock bReturn := bBlock + ELSEIF PCount() == 1 + bReturn := ::aKeys[ nPos ][ _TBC_SETKEY_BLOCK ] + ELSE + bReturn := ::aKeys[ nPos ][ _TBC_SETKEY_BLOCK ] + IF PCount() == 2 .AND. bBlock == NIL .AND. nKey != 0 + ADel( ::aKeys, nPos ) + ASize( ::aKeys, Len( ::aKeys ) - 1 ) + ENDIF + ENDIF - elseif PCount() == 1 - bReturn := ::aKeys[ nPos ][ 2 ] + RETURN bReturn - elseif ( bReturn := ::aKeys[ nPos ][ 2 ], PCount() == 2 .and. ; - bBlock == NIL .and. nKey != 0 ) +METHOD applyKey( nKey ) CLASS TBrowse - ADel( ::aKeys, nPos ) - ASize( ::aKeys, Len( ::aKeys ) - 1 ) - endif + LOCAL bBlock := ::setKey( nKey ) - return bReturn + DEFAULT bBlock TO ::setKey( 0 ) -METHOD TApplyKey( nKey, oBrowse ) CLASS TBrowse + IF bBlock == NIL + RETURN TBR_EXCEPTION + ENDIF - local bBlock := oBrowse:setKey( nKey ) - - DEFAULT bBlock TO oBrowse:setKey( 0 ) - - if bBlock == NIL - return TBR_EXCEPTION - endif - - return Eval( bBlock, oBrowse, nKey ) + RETURN Eval( bBlock, Self, nKey ) METHOD hitTest( nMRow, nMCol ) CLASS TBrowse local i @@ -2023,6 +2124,35 @@ METHOD hitTest( nMRow, nMCol ) CLASS TBrowse return HTCELL +METHOD border( cBorder ) CLASS TBrowse + + IF PCount() > 0 + + cBorder := _eInstVar( Self, "BORDER", cBorder, "C", 1001 ) + + IF Len( cBorder ) == 0 .OR. ; + Len( cBorder ) == 8 + + IF Empty( ::cBorder ) .AND. !Empty( cBorder ) + ::n_Top++ + ::n_Left++ + ::n_Bottom-- + ::n_Right-- + ::configure( 2 ) + ELSEIF !Empty( ::cBorder ) .AND. Empty( cBorder ) + ::n_Top-- + ::n_Left-- + ::n_Bottom++ + ::n_Right++ + ::configure( 2 ) + ENDIF + + ::cBorder := cBorder + ENDIF + ENDIF + + RETURN ::cBorder + METHOD nRow() CLASS TBrowse return ::n_Row @@ -2037,63 +2167,26 @@ METHOD mColPos() CLASS TBrowse METHOD message( cMessage ) CLASS TBrowse - if cMessage != NIL + IF cMessage != NIL ::cMessage := _eInstVar( Self, "MESSAGE", cMessage, "C", 1001 ) - endif + ENDIF - return ::cMessage + RETURN ::cMessage METHOD setStyle( nStyle, lNewValue ) CLASS TBrowse /* NOTE: CA-Cl*pper 5.3 does no checks on the value of nStyle, so in case it is zero or non-numeric, a regular RTE will happen. [vszakats] */ - if nStyle > Len( ::aSetStyle ) .and. nStyle <= 4096 /* Some reasonable limit for maximum number of styles */ + IF nStyle > Len( ::aSetStyle ) .AND. nStyle <= 4096 /* Some reasonable limit for maximum number of styles */ ASize( ::aSetStyle, nStyle ) - endif + ENDIF - if ISLOGICAL( lNewValue ) + IF ISLOGICAL( lNewValue ) ::aSetStyle[ nStyle ] := lNewValue - endif + ENDIF - return ::aSetStyle[ nStyle ] - -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():forceStable() - enddo - - do while n > 0 - n-- - oBrowse:down():forceStable() - enddo - - n := oBrowse:mColPos - oBrowse:colPos - if n < oBrowse:leftVisible - oBrowse:colPos .and. oBrowse:freeze + 1 < oBrowse:leftVisible - n += oBrowse:freeze + 1 - oBrowse:leftVisible // hidden columns - endif - - do while n < 0 - n++ - oBrowse:left() - enddo - - do while n > 0 - n-- - oBrowse:right() - enddo - - return TBR_CONTINUE - endif - - return TBR_EXCEPTION + RETURN ::aSetStyle[ nStyle ] #endif @@ -2132,48 +2225,83 @@ FUNCTION TBrowseNew( nTop, nLeft, nBottom, nRight ) to "N/N". [vszakats] */ STATIC FUNCTION tbr_CookColor( cColorSpec ) - local nCount := Max( hb_TokenCount( cColorSpec, "," ), 2 ) - local aColorSpec := Array( nCount ) - local cColor - local nPos + LOCAL nCount := Max( hb_TokenCount( cColorSpec, "," ), 2 ) + LOCAL aColorSpec := Array( nCount ) + LOCAL cColor + LOCAL nPos - for nPos := 1 TO nCount + FOR nPos := 1 TO nCount cColor := hb_TokenGet( @cColorSpec, nPos, "," ) - if nPos <= 2 + IF nPos <= 2 aColorSpec[ nPos ] := iif( hb_ColorToN( cColor ) == 0 .AND. !( Upper( StrTran( cColor, " ", "" ) ) == "N/N" ), hb_ColorIndex( "W/N,N/W", nPos - 1 ), cColor ) - else + ELSE aColorSpec[ nPos ] := iif( hb_ColorToN( cColor ) == 0, "N/N", cColor ) - endif - next + ENDIF + NEXT - return aColorSpec + RETURN aColorSpec +/* NOTE: Preprocess defColor so that it can be used "blindly" afterwards. */ +STATIC FUNCTION tbr_DefColor( aDefColor, aColorSpec ) + + IF !ISARRAY( aDefColor ) + aDefColor := {} + ENDIF + + ASize( aDefColor, TBC_CLR_MAX_ ) + + IF !ISNUMBER( aDefColor[ TBC_CLR_STANDARD ] ) .OR. aDefColor[ TBC_CLR_STANDARD ] > Len( aColorSpec ) + aDefColor[ TBC_CLR_STANDARD ] := 1 + ENDIF + IF !ISNUMBER( aDefColor[ TBC_CLR_ENHANCED ] ) .OR. aDefColor[ TBC_CLR_ENHANCED ] > Len( aColorSpec ) + aDefColor[ TBC_CLR_ENHANCED ] := 2 + ENDIF +#ifdef HB_COMPAT_C53 + /* NOTE: To be backwards compatible, C5.3 will fall back to C5.2 colors + if the extra HEADING/FOOTING positions are not specified. [vszakats] */ + IF !ISNUMBER( aDefColor[ TBC_CLR_HEADING ] ) .OR. aDefColor[ TBC_CLR_HEADING ] > Len( aColorSpec ) + aDefColor[ TBC_CLR_HEADING ] := aDefColor[ TBC_CLR_STANDARD ] + ENDIF + IF !ISNUMBER( aDefColor[ TBC_CLR_FOOTING ] ) .OR. aDefColor[ TBC_CLR_FOOTING ] > Len( aColorSpec ) + aDefColor[ TBC_CLR_FOOTING ] := aDefColor[ TBC_CLR_STANDARD ] + ENDIF +#endif + + RETURN aDefColor + +/* NOTE: Strict sanity check for a color array. We need to use this + for the array returned by a :colorBlock. */ STATIC FUNCTION tbr_GetColor( aColorSpec, aDefColor, nMode ) - if !ISARRAY( aDefColor ) + IF !ISARRAY( aDefColor ) /* NOTE: This fits both C5.2 and C5.3. In C5.2 nMode is 1 or 2. [vszakats] */ - return aColorSpec[ { 1, 2, 1, 1 }[ nMode ] ] - elseif nMode > Len( aDefColor ) + RETURN aColorSpec[ { 1, 2, 1, 1 }[ nMode ] ] + ELSEIF nMode > Len( aDefColor ) /* NOTE: C5.3 and C5.2 compatible method. To be backwards compatible, C5.3 will fall back to C5.2 colors if the extra HEADING/FOOTING positions are not specified. [vszakats] */ - switch nMode - case TBC_CLR_STANDARD ; return aColorSpec[ 1 ] - case TBC_CLR_ENHANCED ; return aColorSpec[ 2 ] - case TBC_CLR_HEADING ; return aColorSpec[ iif( Len( aDefColor ) >= 1 .AND. ISNUMBER( aDefColor[ 1 ] ) .AND. aDefColor[ 1 ] <= Len( aColorSpec ), aDefColor[ 1 ], 1 ) ] - case TBC_CLR_FOOTING ; return aColorSpec[ iif( Len( aDefColor ) >= 1 .AND. ISNUMBER( aDefColor[ 1 ] ) .AND. aDefColor[ 1 ] <= Len( aColorSpec ), aDefColor[ 1 ], 1 ) ] - endswitch - endif + SWITCH NMODE + CASE TBC_CLR_STANDARD ; RETURN aColorSpec[ 1 ] + CASE TBC_CLR_ENHANCED ; RETURN aColorSpec[ 2 ] + CASE TBC_CLR_HEADING ; RETURN aColorSpec[ iif( Len( aDefColor ) >= TBC_CLR_STANDARD .AND. ISNUMBER( aDefColor[ TBC_CLR_STANDARD ] ) .AND. aDefColor[ 1 ] <= Len( aColorSpec ), aDefColor[ TBC_CLR_STANDARD ], 1 ) ] + CASE TBC_CLR_FOOTING ; RETURN aColorSpec[ iif( Len( aDefColor ) >= TBC_CLR_STANDARD .AND. ISNUMBER( aDefColor[ TBC_CLR_STANDARD ] ) .AND. aDefColor[ 1 ] <= Len( aColorSpec ), aDefColor[ TBC_CLR_STANDARD ], 1 ) ] + ENDSWITCH + ENDIF - return aColorSpec[ iif( ISNUMBER( aDefColor[ nMode ] ) .AND. aDefColor[ nMode ] <= Len( aColorSpec ), aDefColor[ nMode ], { 1, 2, 1, 1 }[ nMode ] ) ] + RETURN aColorSpec[ iif( ISNUMBER( aDefColor[ nMode ] ) .AND. aDefColor[ nMode ] <= Len( aColorSpec ), aDefColor[ nMode ], { 1, 2, 1, 1 }[ nMode ] ) ] STATIC FUNCTION tbr_CalcWidth( xValue, cType, cPicture ) - do case - case cType $ "CM" ; return Len( iif( Empty( cPicture ), xValue , Transform( xValue, cPicture ) ) ) - case cType == "N" ; return Len( iif( Empty( cPicture ), Str( xValue ) , Transform( xValue, cPicture ) ) ) - case cType == "D" ; return Len( iif( Empty( cPicture ), DToC( xValue ), Transform( xValue, cPicture ) ) ) - case cType == "L" ; return 1 - endcase + IF !ISCHARACTER( cPicture ) + cPicture := "" + ENDIF - return 0 + SWITCH cType + CASE "M" + CASE "C" ; RETURN Len( iif( Empty( cPicture ), xValue , Transform( xValue, cPicture ) ) ) + CASE "N" ; RETURN Len( iif( Empty( cPicture ), Str( xValue ) , Transform( xValue, cPicture ) ) ) + CASE "D" ; RETURN Len( iif( Empty( cPicture ), DToC( xValue ), Transform( xValue, cPicture ) ) ) + CASE "L" ; RETURN 1 + ENDSWITCH + + RETURN 0 diff --git a/harbour/source/rtl/teditor.prg b/harbour/source/rtl/teditor.prg index 5d4ddf1294..7c1cc8b709 100644 --- a/harbour/source/rtl/teditor.prg +++ b/harbour/source/rtl/teditor.prg @@ -147,6 +147,9 @@ CREATE CLASS HBEditor VAR cColorSpec AS CHARACTER // Color string used for screen writes + METHOD GetParagraph( nRow ) + METHOD BrowseText( nPassedKey ) + ENDCLASS /* -------------------------------------------- */ @@ -348,7 +351,7 @@ METHOD SplitLine( nRow ) CLASS HBEditor nPosInWord := Len( ::GetLine( nRow ) ) - ::nCol nStartRow := nRow - cLine := GetParagraph( Self, nRow ) + cLine := ::GetParagraph( nRow ) do while !Empty(cLine) @@ -647,7 +650,7 @@ METHOD Edit( nPassedKey ) CLASS HBEditor LOCAL lSingleKeyProcess := .F. // .T. if I have to process passed key and then exit if ! ::lEditAllow - BrowseText( Self, nPassedKey ) + ::BrowseText( nPassedKey ) else @@ -868,11 +871,6 @@ METHOD RowPos() CLASS HBEditor METHOD ColPos() CLASS HBEditor return ::nCol -/* -METHOD LineColor( nRow ) CLASS HBEditor - return ::cColorSpec -*/ - METHOD Saved() CLASS HBEditor return ::lSaved @@ -898,6 +896,66 @@ METHOD hitTest( nMRow, nMCol ) CLASS HBEditor /* -------------------------------------------- */ +// Rebuild a long line from multiple short ones (wrapped at soft CR) +METHOD GetParagraph( nRow ) + + LOCAL cLine := "" + + do while nRow <= Len( ::aText ) .and. ::aText[ nRow ]:lSoftCR + cLine += ::aText[ nRow ]:cText + // I don't need to increment nRow since I'm removing lines, ie line n is + // a different line each time I add it to cLine + ::RemoveLine( nRow ) + enddo + + if nRow <= Len( ::aText ) + // Last line, or only one line + cLine += ::aText[ nRow ]:cText + ::RemoveLine( nRow ) + endif + + return cLine + +// if editing isn't allowed we enter this loop which +// handles only movement keys and discards all the others +METHOD BrowseText( nPassedKey ) + + LOCAL nKey + LOCAL bKeyBlock + + do while ! ::lExitEdit + + // If I haven't been called with a key already preset, evaluate this key and then exit + if nPassedKey == NIL + + if NextKey() == 0 + ::IdleHook() + endif + + nKey := InKey( 0 ) + else + nKey := nPassedKey + endif + + if ( bKeyBlock := Setkey( nKey ) ) != NIL + Eval( bKeyBlock ) + loop + endif + + if nKey == K_ESC + ::lExitEdit := .T. + else + if !::MoveCursor( nKey ) + ::KeyboardHook( nKey ) + endif + endif + + enddo + + return Self + +/* -------------------------------------------- */ + METHOD New( cString, nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabSize ) CLASS HBEditor DEFAULT cString TO "" @@ -1034,61 +1092,3 @@ STATIC FUNCTION Text2Array( cString, nWordWrapCol ) enddo return aArray - -// Rebuild a long line from multiple short ones (wrapped at soft CR) -STATIC FUNCTION GetParagraph( oSelf, nRow ) - - LOCAL cLine := "" - - do while nRow <= Len( oSelf:aText ) .and. oSelf:aText[ nRow ]:lSoftCR - cLine += oSelf:aText[ nRow ]:cText - // I don't need to increment nRow since I'm removing lines, ie line n is - // a different line each time I add it to cLine - oSelf:RemoveLine( nRow ) - enddo - - if nRow <= Len( oSelf:aText ) - // Last line, or only one line - cLine += oSelf:aText[ nRow ]:cText - oSelf:RemoveLine( nRow ) - endif - - return cLine - -// if editing isn't allowed we enter this loop which -// handles only movement keys and discards all the others -STATIC PROCEDURE BrowseText( oSelf, nPassedKey ) - - LOCAL nKey - LOCAL bKeyBlock - - do while ! oSelf:lExitEdit - - // If I haven't been called with a key already preset, evaluate this key and then exit - if nPassedKey == NIL - - if NextKey() == 0 - oSelf:IdleHook() - endif - - nKey := InKey( 0 ) - else - nKey := nPassedKey - endif - - if ( bKeyBlock := Setkey( nKey ) ) != NIL - Eval( bKeyBlock ) - loop - endif - - if nKey == K_ESC - oSelf:lExitEdit := .T. - else - if !oSelf:MoveCursor( nKey ) - oSelf:KeyboardHook( nKey ) - endif - endif - - enddo - - return diff --git a/harbour/source/rtl/tscalar.prg b/harbour/source/rtl/tscalar.prg new file mode 100644 index 0000000000..f92566c6c9 --- /dev/null +++ b/harbour/source/rtl/tscalar.prg @@ -0,0 +1,315 @@ +/* + * $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 ScalarObject FUNCTION HBArray + + METHOD Init() + + METHOD AsString() + METHOD At + METHOD AtPut() + METHOD Add + METHOD AddAll() + METHOD Append() + 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 ScalarObject FUNCTION HBBlock + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS Block + RETURN "{ || ... }" + +/* -------------------------------------------- */ + +CREATE CLASS Character INHERIT ScalarObject FUNCTION HBCharacter + + METHOD AsString() + METHOD AsExpStr() + +ENDCLASS + +METHOD AsString() CLASS Character + RETURN Self + +METHOD AsExpStr() CLASS Character + RETURN '"' + Self + '"' + +/* -------------------------------------------- */ + +CREATE CLASS Date INHERIT ScalarObject 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 ScalarObject FUNCTION HBLogical + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS Logical + RETURN iif( Self, ".T.", ".F." ) + +/* -------------------------------------------- */ + +CREATE CLASS HBNil INHERIT ScalarObject + + VAR ClassName INIT "NIL" + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS HBNil + RETURN "NIL" + +/* -------------------------------------------- */ + +CREATE CLASS Numeric INHERIT ScalarObject FUNCTION HBNumeric + + METHOD AsString() + +ENDCLASS + +METHOD AsString() CLASS Numeric + RETURN LTrim( Str( Self ) ) + +/* -------------------------------------------- */