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 ) ) + +/* -------------------------------------------- */