fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2007-09-17 12:25 UTC+0100 Viktor Szakats (harbour.01 syenar.hu)

Browse Source 
* 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
This commit is contained in:
Viktor Szakats
2007-09-17 10:28:19 +00:00
parent d9cf2de1ce
commit 9303fd7c30
17 changed files with 825 additions and 1024 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
harbour/ChangeLog
View File

@@ -8,6 +8,64 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
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

10
harbour/common.mak
View File

@@ -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) \

25
harbour/include/hbextern.ch
View File

@@ -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

10
harbour/source/rtl/Makefile
View File

@@ -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 \

190
harbour/source/rtl/array.prg
View File

@@ -1,190 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Array
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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

64
harbour/source/rtl/block.prg
View File

@@ -1,64 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Block
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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 "{ || ... }"

68
harbour/source/rtl/characte.prg
View File

@@ -1,68 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Character
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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 + ["]

69
harbour/source/rtl/date.prg
View File

@@ -1,69 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Date
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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() + [")]

12
harbour/source/rtl/getsys.prg
View File

@@ -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 )

64
harbour/source/rtl/logical.prg
View File

@@ -1,64 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Logical
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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." )

64
harbour/source/rtl/nil.prg
View File

@@ -1,64 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Nil
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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"

63
harbour/source/rtl/numeric.prg
View File

@@ -1,63 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class Numeric
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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 ) )

118
harbour/source/rtl/scalar.prg
View File

@@ -1,118 +0,0 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Harbour implementation of Class(y) Class ScalarObject
*
* Copyright 2004 Antonio Linares <alinares@fivetechsoft.com>
* 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

15
harbour/source/rtl/symbol.prg
View File

@@ -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( ... )

574
harbour/source/rtl/tbrowse.prg
View File

@@ -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 | <action> } */
// ; Assigned codeblock receives two parameters: {| oTBrowse, nKey | <action> }
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

130
harbour/source/rtl/teditor.prg
View File

@@ -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

315
harbour/source/rtl/tscalar.prg Normal file
View File

@@ -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 <alinares@fivetechsoft.com>
* 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 ) )
/* -------------------------------------------- */