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

2007-09-14 18:46 UTC+0100 Viktor Szakats (harbour.01 syenar.hu)

Browse Source 
* source/rtl/tbrowse.prg
     ! Color handling made fully C5.x compatible. Pls test.
     + One C5.3 bug replicated where no special header/footer 
       colors are being used if there is not header/footer separator 
       sepcified.
     ! Fixed compile error (because of unused var warning) when 
       HB_COMPAT_C53 is not defined.

   * source/rtl/numeric.prg
   * source/rtl/memoedit.prg
   * source/rtl/typefile.prg
   * source/rtl/block.prg
   * source/rtl/symbol.prg
   * source/rtl/errorsys.prg
   * source/rtl/scalar.prg
   * source/rtl/nil.prg
   * source/rtl/radiogrp.prg
   * source/rtl/logical.prg
   * source/rtl/array.prg
   * source/rtl/listbox.prg
   * source/rtl/browse.prg
   * source/rtl/characte.prg
   * source/rtl/pushbtn.prg
   * source/rtl/ttextlin.prg
   * source/rtl/profiler.prg
   * source/rtl/date.prg
   * source/rtl/persist.prg
   * source/debug/dbgbrwsr.prg
   * source/debug/tbrwtext.prg
   * source/debug/dbgtmenu.prg
     + Enabled "PROTECTED:" keyword in profiler.prg
     * Finished CLASS declarations to use a more or less consistent syntax 
       inside Harbour (Class(y) compatible except SETGET and the METHOD 
       parameter lists, maybe some more).
     * Finished WHILE, iif(), END, string quotation to be consistent along Harbour.
     ! Fixed some indentations.
     * Some other minor cleanups.
This commit is contained in:
Viktor Szakats
2007-09-15 11:54:39 +00:00
parent 3a3f290a9f
commit 1091b1a150
24 changed files with 423 additions and 336 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
harbour/ChangeLog
View File

@@ -8,6 +8,45 @@
2002-12-01 13:30 UTC+0100 Foo Bar <foo.bar@foobar.org>
*/
2007-09-14 13:53 UTC+0100 Viktor Szakats (harbour.01 syenar.hu)
* source/rtl/tbrowse.prg
! Color handling made fully C5.x compatible. Pls test.
+ One C5.3 bug replicated where no special header/footer
colors are being used if there is not header/footer separator
sepcified.
! Fixed compile error (because of unused var warning) when
HB_COMPAT_C53 is not defined.
* source/rtl/numeric.prg
* source/rtl/memoedit.prg
* source/rtl/typefile.prg
* source/rtl/block.prg
* source/rtl/symbol.prg
* source/rtl/errorsys.prg
* source/rtl/scalar.prg
* source/rtl/nil.prg
* source/rtl/radiogrp.prg
* source/rtl/logical.prg
* source/rtl/array.prg
* source/rtl/listbox.prg
* source/rtl/browse.prg
* source/rtl/characte.prg
* source/rtl/pushbtn.prg
* source/rtl/ttextlin.prg
* source/rtl/profiler.prg
* source/rtl/date.prg
* source/rtl/persist.prg
* source/debug/dbgbrwsr.prg
* source/debug/tbrwtext.prg
* source/debug/dbgtmenu.prg
+ Enabled "PROTECTED:" keyword in profiler.prg
* Finished CLASS declarations to use a more or less consistent syntax
inside Harbour (Class(y) compatible except SETGET and the METHOD
parameter lists, maybe some more).
* Finished WHILE, iif(), END, string quotation to be consistent along Harbour.
! Fixed some indentations.
* Some other minor cleanups.
2007-09-14 18:46 UTC+0100 Viktor Szakats (harbour.01 syenar.hu)
* harbour/source/rtl/tbrowse.prg
! Fixed cell color. This was needed because the oCol:colorBlock()

2
harbour/source/debug/dbgbrwsr.prg
View File

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CREATE CLASS HBDbBrowser FROM TBrowse // Debugger browser
CREATE CLASS HBDbBrowser INHERIT TBrowse // Debugger browser
VAR Window

18
harbour/source/debug/dbgtmenu.prg
View File

@@ -281,14 +281,14 @@ METHOD GetItemByIdent( uIdent ) CLASS HBDbMenu
local oItem
for n := 1 to Len( ::aItems )
IF( VALTYPE(::aItems[n]:bAction) == 'O' )
oItem := ::aItems[n]:bAction:GetItemByIdent( uIdent )
IF( oItem != NIL )
IF ISOBJECT( ::aItems[ n ]:bAction )
oItem := ::aItems[ n ]:bAction:GetItemByIdent( uIdent )
IF oItem != NIL
RETURN oItem
ENDIF
ELSE
if VALTYPE(::aItems[ n ]:Ident) == VALTYPE(uIdent) .AND.;
::aItems[n]:Ident == uIdent
if VALTYPE( ::aItems[ n ]:Ident ) == VALTYPE( uIdent ) .AND.;
::aItems[ n ]:Ident == uIdent
return ::aItems[ n ]
ENDIF
endif
@@ -320,10 +320,10 @@ METHOD GoLeft() CLASS HBDbMenu
endif
if ::nOpenPopup > 1
--::nOpenPopup
while ::nOpenPopup > 1 .and. ;
do while ::nOpenPopup > 1 .and. ;
SubStr( ::aItems[ ::nOpenPopup ]:cPrompt, 1, 1 ) == "-"
--::nOpenPopup
end
enddo
::ShowPopup( ::nOpenPopup )
else
::ShowPopup( ::nOpenPopup := Len( ::aItems ) )
@@ -344,10 +344,10 @@ METHOD GoRight() CLASS HBDbMenu
endif
if ::nOpenPopup < Len( ::aItems )
++::nOpenPopup
while ::nOpenPopup < Len( ::aItems ) .and. ;
do while ::nOpenPopup < Len( ::aItems ) .and. ;
SubStr( ::aItems[ ::nOpenPopup ]:cPrompt, 1, 1 ) == "-"
++::nOpenPopup
end
enddo
::ShowPopup( ::nOpenPopup )
else
::ShowPopup( ::nOpenPopup := 1 )

2
harbour/source/debug/tbrwtext.prg
View File

@@ -62,7 +62,7 @@
#define CLR_BKPT 2 // color of breakpoint line
#define CLR_HIBKPT 3 // color of highlighted breakpoint line
CREATE CLASS HBBrwText FROM HBEditor
CREATE CLASS HBBrwText INHERIT HBEditor
VAR cFileName // the name of the browsed file
VAR nActiveLine INIT 1 // Active line inside Code Window (the line to be executed)

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS Array FROM ScalarObject FUNCTION _Array
CREATE CLASS Array INHERIT ScalarObject FUNCTION HBArray
METHOD Init()
@@ -73,17 +73,17 @@ CLASS Array FROM ScalarObject FUNCTION _Array
METHOD Scan()
METHOD _Size // assignment method
END CLASS
ENDCLASS
METHOD Init( nElements ) CLASS Array
::size := If( nElements == nil, 0, nElements )
::size := iif( nElements == NIL, 0, nElements )
return Self
METHOD AddAll( aOtherCollection ) CLASS Array
aOtherCollection:Do( { |e| ::Add( e ) } )
aOtherCollection:Do( {| e | ::Add( e ) } )
return Self
@@ -115,7 +115,7 @@ METHOD Collect( b ) CLASS Array
currElem := Self[ i ]
if Eval( b, currElem )
AAdd( result, currElem )
end
endif
next
return result
@@ -129,7 +129,7 @@ METHOD DeleteAt( n ) CLASS Array
if n > 0 .and. n <= Len( Self )
ADel( Self, n )
ASize( Self, Len( Self ) - 1 )
end
endif
return Self
@@ -138,11 +138,11 @@ METHOD InsertAt( n, x ) CLASS Array
if n > Len( Self )
ASize( Self, n )
Self[ n ] := x
elseif n > 0
elseif n > 0
ASize( Self, Len( Self ) + 1 )
AIns( Self, n )
Self[ n ] := x
end
endif
return Self
@@ -168,7 +168,7 @@ METHOD IndexOf( x ) CLASS Array
for i := 1 to nElems
if Self[ i ] == x
return i
end
endif
next
return 0
@@ -177,7 +177,7 @@ METHOD Remove( e ) CLASS Array
::DeleteAt( ::IndexOf( e ) )
return nil
return NIL
METHOD Scan( b ) CLASS Array
@@ -188,4 +188,3 @@ METHOD _Size( newSize ) CLASS Array
ASize( Self, newSize )
return newSize // so that assignment works according to standard rules

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS Block FROM ScalarObject
CREATE CLASS Block INHERIT ScalarObject
METHOD AsString()

6
harbour/source/rtl/browse.prg
View File

@@ -106,9 +106,9 @@ FUNCTION Browse( nTop, nLeft, nBottom, nRight )
lKeyPressed := .T.
ENDIF
WHILE ! lExit
DO WHILE ! lExit
WHILE ! lKeyPressed .AND. ! oBrw:Stabilize()
DO WHILE ! lKeyPressed .AND. ! oBrw:Stabilize()
lKeyPressed := ( nKey := Inkey() ) != 0
ENDDO
@@ -402,7 +402,7 @@ STATIC FUNCTION FreshOrder( oBrw )
oBrw:ForceStable()
IF nRec != LastRec() + 1
WHILE RecNo() != nRec .AND. !BOF()
DO WHILE RecNo() != nRec .AND. !BOF()
oBrw:Up()
oBrw:ForceStable()
ENDDO

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS Character FROM ScalarObject
CREATE CLASS Character INHERIT ScalarObject
METHOD AsString()
METHOD AsExpStr()

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS Date FROM ScalarObject FUNCTION _Date
CREATE CLASS Date INHERIT ScalarObject FUNCTION HBDate
METHOD AsString()
METHOD AsExpStr()

11
harbour/source/rtl/errorsys.prg
View File

@@ -105,7 +105,6 @@ STATIC FUNCTION DefError( oError )
aOptions := {}
// AAdd( aOptions, "Break" )
AAdd( aOptions, "Quit" )
IF oError:canRetry
@@ -119,7 +118,7 @@ STATIC FUNCTION DefError( oError )
// Show alert box
nChoice := 0
WHILE nChoice == 0
DO WHILE nChoice == 0
IF ISNIL( cDOSError )
nChoice := Alert( cMessage, aOptions )
@@ -150,7 +149,7 @@ STATIC FUNCTION DefError( oError )
OutErr( cMessage )
n := 1
WHILE ! Empty( ProcName( ++n ) )
DO WHILE ! Empty( ProcName( ++n ) )
OutErr( hb_OSNewLine() )
OutErr( "Called from " + ProcName( n ) + ;
@@ -158,17 +157,11 @@ STATIC FUNCTION DefError( oError )
ENDDO
/// For some strange reason, the DOS prompt gets written on the first line
/// *of* the message instead of on the first line *after* the message after
/// the program quits, unless the screen has scrolled. - dgh
ErrorLevel( 1 )
QUIT
RETURN .F.
// [vszakats]
STATIC FUNCTION ErrorMessage( oError )
LOCAL cMessage

10
harbour/source/rtl/listbox.prg
View File

@@ -435,7 +435,7 @@ METHOD hitTest( nMRow, nMCol ) CLASS LISTBOX
/* Check hit on the scrollbar */
IF ::lIsOpen .AND. ;
::oVScroll != NIL .AND. ;
( nHit := ::oVScroll:hittest( nMRow, nMCol ) ) != 0
( nHit := ::oVScroll:hitTest( nMRow, nMCol ) ) != 0
RETURN nHit
ENDIF
@@ -532,7 +532,7 @@ METHOD insItem( nPos, cText, cData )
RETURN Self
METHOD killFocus() CLASS LISTBOX
LOCAL nCurMCur
LOCAL nOldMCur
IF ::lHasFocus
::lHasFocus := .F.
@@ -541,7 +541,7 @@ METHOD killFocus() CLASS LISTBOX
Eval( ::bFBlock )
ENDIF
nCurMCur := MSetCursor( .F. )
nOldMCur := MSetCursor( .F. )
DispBegin()
IF ::lDropDown .AND. ::lIsOpen
@@ -550,7 +550,7 @@ METHOD killFocus() CLASS LISTBOX
::display()
DispEnd()
MSetCursor( nCurMCur )
MSetCursor( nOldMCur )
SetCursor( ::nCursor )
ENDIF
@@ -719,7 +719,7 @@ METHOD select( xPos ) CLASS LISTBOX
RETURN ::nValue
CASE xPos == ::nValue
RETURN ::nValue
Otherwise
OTHERWISE
nPos := xPos
IF Valtype( ::xBuffer ) $ "NU"
::xBuffer := nPos

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS Logical FROM ScalarObject
CREATE CLASS Logical INHERIT ScalarObject
METHOD AsString()
@@ -60,5 +60,5 @@ ENDCLASS
METHOD AsString() CLASS Logical
return If( Self, ".T.", ".F." )
return iif( Self, ".T.", ".F." )

104
harbour/source/rtl/memoedit.prg
View File

@@ -57,7 +57,7 @@
#include "memoedit.ch"
// A specialized HBEditor which can simulate MemoEdit() behaviour
CREATE CLASS HBMemoEditor FROM HBEditor
CREATE CLASS HBMemoEditor INHERIT HBEditor
VAR xUserFunction // User Function called to change default MemoEdit() behaviour
@@ -80,18 +80,18 @@ METHOD MemoInit( xUserFunction ) CLASS HBMemoEditor
// Save/Init object internal representation of user function
::xUserFunction := xUserFunction
if ISCHARACTER( ::xUserFunction )
IF ISCHARACTER( ::xUserFunction )
// Keep calling user function until it returns 0
do while ( nKey := ::xDo( ME_INIT ) ) != ME_DEFAULT
DO WHILE ( nKey := ::xDo( ME_INIT ) ) != ME_DEFAULT
// At this time there is no input from user of MemoEdit() only handling
// of values returned by ::xUserFunction, so I pass these value on both
// parameters of ::HandleUserKey()
::HandleUserKey( nKey, nKey )
enddo
ENDDO
endif
ENDIF
RETURN Self
@@ -106,35 +106,35 @@ METHOD Edit() CLASS HBMemoEditor
// If I have an user function I need to trap configurable keys and ask to
// user function if handle them the standard way or not
if ::lEditAllow .AND. ISCHARACTER( ::xUserFunction )
IF ::lEditAllow .AND. ISCHARACTER( ::xUserFunction )
do while ! ::lExitEdit
DO WHILE ! ::lExitEdit
// I need to test this condition here since I never block inside HBEditor:Edit()
// if there is an user function
if NextKey() == 0
IF NextKey() == 0
::IdleHook()
endif
ENDIF
nKey := Inkey( 0 )
if ( bKeyBlock := SetKey( nKey ) ) != NIL
IF ( bKeyBlock := SetKey( nKey ) ) != NIL
Eval( bKeyBlock )
loop
endif
LOOP
ENDIF
// Is it a configurable key ?
if AScan( aConfigurableKeys, nKey ) > 0
IF AScan( aConfigurableKeys, nKey ) > 0
::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) )
else
ELSE
::super:Edit( nKey )
endif
enddo
else
ENDIF
ENDDO
ELSE
// If I can't edit text buffer or there is not a user function enter standard HBEditor
// ::Edit() method which is able to handle everything
::super:Edit()
endif
ENDIF
RETURN Self
@@ -147,9 +147,9 @@ METHOD KeyboardHook( nKey ) CLASS HBMemoEditor
LOCAL nRow
LOCAL nCol
if nKey == K_ESC
IF nKey == K_ESC
if ::lDirty
IF ::lDirty
cBackScr := SaveScreen( ::nTop, ::nRight - 18, ::nTop, ::nRight )
nRow := Row()
@@ -161,26 +161,26 @@ METHOD KeyboardHook( nKey ) CLASS HBMemoEditor
RestScreen( ::nTop, ::nRight - 18, ::nTop, ::nRight, cBackScr )
SetPos( nRow, nCol )
if Upper( Chr( nYesNoKey ) ) == "Y"
IF Upper( Chr( nYesNoKey ) ) == "Y"
::lSaved := .F.
::lExitEdit := .T.
endif
else
ENDIF
ELSE
::lExitEdit := .T.
endif
endif
ENDIF
ENDIF
if ISCHARACTER( ::xUserFunction )
IF ISCHARACTER( ::xUserFunction )
::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) )
endif
ENDIF
RETURN Self
METHOD IdleHook() CLASS HBMemoEditor
if ISCHARACTER( ::xUserFunction )
IF ISCHARACTER( ::xUserFunction )
::xDo( ME_IDLE )
endif
ENDIF
RETURN Self
@@ -190,42 +190,42 @@ METHOD HandleUserKey( nKey, nUserKey ) CLASS HBMemoEditor
LOCAL aUnHandledKeys := { K_CTRL_J, K_CTRL_K, K_CTRL_L, K_CTRL_N, K_CTRL_O,;
K_CTRL_P, K_CTRL_Q, K_CTRL_T, K_CTRL_U, K_F1 }
do case
DO CASE
// I won't reach this point during ME_INIT since ME_DEFAULT ends initialization phase of MemoEdit()
case nUserKey == ME_DEFAULT
CASE nUserKey == ME_DEFAULT
// HBEditor is not able to handle keys with a value higher than 256, but I have to tell him
// that user wants to save text
if ( nKey <= 256 .OR. nKey == K_ALT_W ) .AND. AScan( aUnHandledKeys, nKey ) == 0
IF ( nKey <= 256 .OR. nKey == K_ALT_W ) .AND. AScan( aUnHandledKeys, nKey ) == 0
::super:Edit( nKey )
endif
ENDIF
// TOFIX: Not clipper compatible, see teditor.prg
case ( nUserKey >= 1 .AND. nUserKey <= 31 ) .OR. nUserKey == K_ALT_W
if AScan( aUnHandledKeys, nUserKey ) == 0
CASE ( nUserKey >= 1 .AND. nUserKey <= 31 ) .OR. nUserKey == K_ALT_W
IF AScan( aUnHandledKeys, nUserKey ) == 0
::super:Edit( nUserKey )
endif
ENDIF
case nUserKey == ME_DATA
if nKey <= 256 .AND. AScan( aUnHandledKeys, nKey ) == 0
CASE nUserKey == ME_DATA
IF nKey <= 256 .AND. AScan( aUnHandledKeys, nKey ) == 0
::super:Edit( nKey )
endif
ENDIF
case nUserKey == ME_TOGGLEWRAP
CASE nUserKey == ME_TOGGLEWRAP
::lWordWrap := !::lWordWrap
case nUserKey == ME_TOGGLESCROLL
CASE nUserKey == ME_TOGGLESCROLL
// TODO: HBEditor does not support vertical scrolling of text inside window without moving cursor position
case nUserKey == ME_WORDRIGHT
CASE nUserKey == ME_WORDRIGHT
::MoveCursor( K_CTRL_RIGHT )
case nUserKey == ME_BOTTOMRIGHT
CASE nUserKey == ME_BOTTOMRIGHT
::MoveCursor( K_CTRL_END )
otherwise
OTHERWISE
// Do nothing
endcase
ENDCASE
RETURN Self
@@ -244,12 +244,12 @@ METHOD xDo( nStatus ) CLASS HBMemoEditor
METHOD MoveCursor( nKey ) CLASS HBMemoEditor
if nKey == K_CTRL_END // same value as CTRL-W
IF nKey == K_CTRL_END // same value as CTRL-W
::lSaved := .T.
::lExitEdit := .T.
else
ELSE
RETURN ::Super:MoveCursor( nKey )
endif
ENDIF
RETURN .f.
@@ -287,14 +287,14 @@ FUNCTION MemoEdit( cString,;
oEd:MemoInit( xUserFunction )
oEd:display()
if ! ISLOGICAL( xUserFunction ) .OR. xUserFunction == .T.
IF ! ISLOGICAL( xUserFunction ) .OR. xUserFunction == .T.
oEd:Edit()
if oEd:Changed()
IF oEd:Changed()
cString := oEd:GetText()
// dbu tests for LastKey() == K_CTRL_END, so I try to make it happy
KEYBOARD Chr( K_CTRL_END )
Inkey()
endif
endif
ENDIF
ENDIF
RETURN cString

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS _Nil FROM ScalarObject
CREATE CLASS _Nil INHERIT ScalarObject
METHOD AsString()

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

@@ -52,7 +52,7 @@
#include "hbclass.ch"
CLASS Numeric FROM ScalarObject
CREATE CLASS Numeric INHERIT ScalarObject
METHOD AsString()

62
harbour/source/rtl/persist.prg
View File

@@ -55,16 +55,12 @@
extern HB_STOD
CLASS HBPersistent
CREATE CLASS HBPersistent
METHOD CreateNew() INLINE Self
METHOD LoadFromFile( cFileName ) INLINE ::LoadFromText( MemoRead( cFileName ) )
METHOD LoadFromText( cObjectText )
METHOD SaveToText( cObjectName )
METHOD SaveToFile( cFileName ) INLINE MemoWrit( cFileName, ::SaveToText() )
ENDCLASS
@@ -79,10 +75,10 @@ METHOD LoadFromText( cObjectText ) CLASS HBPersistent
return .F.
endif
while Empty( ExtractLine( cObjectText, @nFrom ) ) // We skip the first empty lines
end
do while Empty( ExtractLine( cObjectText, @nFrom ) ) // We skip the first empty lines
enddo
while nFrom <= Len( cObjectText )
do while nFrom <= Len( cObjectText )
cLine := ExtractLine( cObjectText, @nFrom )
do case
@@ -108,7 +104,7 @@ METHOD LoadFromText( cObjectText ) CLASS HBPersistent
endcase
end
enddo
return .T.
@@ -122,9 +118,9 @@ METHOD SaveToText( cObjectName ) CLASS HBPersistent
DEFAULT cObjectName TO "o" + ::ClassName()
nIndent += 3
cObject := iif( nIndent > 0, hb_OsNewLine(), "" ) + Space( nIndent ) + ;
cObject := iif( nIndent > 0, hb_OSNewLine(), "" ) + Space( nIndent ) + ;
"OBJECT " + iif( nIndent != 0, "::", "" ) + cObjectName + " AS " + ;
::ClassName() + hb_OsNewLine()
::ClassName() + hb_OSNewLine()
aProperties := __ClsGetProperties( ::ClassH )
@@ -141,7 +137,7 @@ METHOD SaveToText( cObjectName ) CLASS HBPersistent
cObject += ArrayToText( uValue, aProperties[ n ], nIndent )
nIndent -= 3
if n < Len( aProperties )
cObject += hb_OsNewLine()
cObject += hb_OSNewLine()
endif
case cType == "O"
@@ -149,31 +145,31 @@ METHOD SaveToText( cObjectName ) CLASS HBPersistent
cObject += uValue:SaveToText( aProperties[ n ] )
endif
if n < Len( aProperties )
cObject += hb_OsNewLine()
cObject += hb_OSNewLine()
endif
otherwise
if n == 1
cObject += hb_OsNewLine()
cObject += hb_OSNewLine()
endif
cObject += Space( nIndent ) + " ::" + ;
aProperties[ n ] + " = " + ValToText( uValue ) + ;
hb_OsNewLine()
hb_OSNewLine()
endcase
endif
next
cObject += hb_OsNewLine() + Space( nIndent ) + "ENDOBJECT" + hb_OsNewLine()
cObject += hb_OSNewLine() + Space( nIndent ) + "ENDOBJECT" + hb_OSNewLine()
nIndent -= 3
return cObject
static function ArrayToText( aArray, cName, nIndent )
local cArray := hb_OsNewLine() + Space( nIndent ) + "ARRAY ::" + cName + ;
" LEN " + AllTrim( Str( Len( aArray ) ) ) + hb_OsNewLine()
local cArray := hb_OSNewLine() + Space( nIndent ) + "ARRAY ::" + cName + ;
" LEN " + AllTrim( Str( Len( aArray ) ) ) + hb_OSNewLine()
local n, uValue, cType
for n := 1 to Len( aArray )
@@ -184,7 +180,7 @@ static function ArrayToText( aArray, cName, nIndent )
case cType == "A"
nIndent += 3
cArray += ArrayToText( uValue, cName + "[ " + ;
AllTrim( Str( n ) ) + " ]", nIndent ) + hb_OsNewLine()
AllTrim( Str( n ) ) + " ]", nIndent ) + hb_OSNewLine()
nIndent -= 3
case cType == "O"
@@ -195,15 +191,15 @@ static function ArrayToText( aArray, cName, nIndent )
otherwise
if n == 1
cArray += hb_OsNewLine()
cArray += hb_OSNewLine()
endif
cArray += Space( nIndent ) + " ::" + cName + ;
+ "[ " + AllTrim( Str( n ) ) + " ]" + " = " + ;
ValToText( uValue ) + hb_OsNewLine()
ValToText( uValue ) + hb_OSNewLine()
endcase
next
cArray += hb_OsNewLine() + Space( nIndent ) + "ENDARRAY" + hb_OsNewLine()
cArray += hb_OSNewLine() + Space( nIndent ) + "ENDARRAY" + hb_OSNewLine()
return cArray
@@ -214,7 +210,7 @@ static function ValToText( uValue )
do case
case cType == "C"
cText := HB_StrToExp( uValue )
cText := hb_StrToExp( uValue )
case cType == "N"
cText := AllTrim( Str( uValue ) )
@@ -224,7 +220,7 @@ static function ValToText( uValue )
cText := "0d" + iif( Empty( cText ), "00000000", cText )
otherwise
cText := HB_ValToStr( uValue )
cText := hb_ValToStr( uValue )
endcase
return cText
@@ -233,14 +229,14 @@ return cText
static function ExtractLine( cText, nFrom )
local nAt := At( hb_OsNewLine(), cText, nFrom )
if nAt > 0
cText := Substr( cText, nFrom, nAt - nFrom )
nFrom := nAt + 2
else
cText := Substr( cText, nFrom )
nFrom := Len( cText ) + 1
endif
local nAt := At( hb_OSNewLine(), cText, nFrom )
if nAt > 0
cText := Substr( cText, nFrom, nAt - nFrom )
nFrom := nAt + 2
else
cText := Substr( cText, nFrom )
nFrom := Len( cText ) + 1
endif
return cText

214
harbour/source/rtl/profiler.prg
View File

@@ -127,19 +127,19 @@ Local n
// Report on calls greater than 0
DrawScreen( "All methods/functions called one or more times" )
memoedit( HBProfileReportToString():new( oProfile:callSort() ):generate( {|o| o:nCalls > 0 } ), 1,,,, .F. )
memoedit( HBProfileReportToString():new( oProfile:callSort() ):generate( {| o | o:nCalls > 0 } ), 1,,,, .F. )
// Sorted by name
DrawScreen( "All methods/functions called one or more times, sorted by name" )
memoedit( HBProfileReportToString():new( oProfile:nameSort() ):generate( {|o| o:nCalls > 0 } ), 1,,,, .F. )
memoedit( HBProfileReportToString():new( oProfile:nameSort() ):generate( {| o | o:nCalls > 0 } ), 1,,,, .F. )
// Sorted by time
DrawScreen( "All methods/functions taking measurable time, sorted by time" )
memoedit( HBProfileReportToString():new( oProfile:timeSort() ):generate( {|o| o:nTicks > 0 } ), 1,,,, .F. )
memoedit( HBProfileReportToString():new( oProfile:timeSort() ):generate( {| o | o:nTicks > 0 } ), 1,,,, .F. )
// TBrowse all calls greater than 0
DrawScreen( "TBrowse all methods/functions called one or more times" )
Browser( HBProfileReportToTBrowse():new( oProfile:callSort() ):generate( {|o| o:nCalls > 0 }, 1 ) )
Browser( HBProfileReportToTBrowse():new( oProfile:callSort() ):generate( {| o | o:nCalls > 0 }, 1 ) )
// Some closing stats
DrawScreen( "Totals" )
@@ -147,24 +147,24 @@ Local n
@ 3, 0 Say " Total Ticks: " + str( oProfile:totalTicks() )
@ 4, 0 Say "Total Seconds: " + str( oProfile:totalSeconds() )
Return( NIL )
Return NIL
Static Function DrawScreen( cTitle )
scroll()
Scroll()
@ 0, 0 Say padr( cTitle, maxcol() + 1 ) Color "n/w"
@ 0, 0 SAY PadR( cTitle, MaxCol() + 1 ) COLOR "N/W"
Return( NIL )
Return NIL
Function DoNothingForTwoSeconds()
inkey( 2 )
Inkey( 2 )
Return( NIL )
Return NIL
Function CallMe500Times()
Return( NIL )
Return NIL
Static Function Browser( oBrowse )
Local lBrowsing := .T.
@@ -174,7 +174,7 @@ Local nKey
oBrowse:forceStable()
nKey := inkey( 0 )
nKey := Inkey( 0 )
Do Case
@@ -205,7 +205,7 @@ Local nKey
EndDo
Return( NIL )
Return NIL
#endif
@@ -227,7 +227,7 @@ Create Class HBProfileEntity
Method init
Method describe
End Class
Endclass
/////
@@ -237,27 +237,27 @@ Method init( cName, aInfo ) Class HBProfileEntity
::nCalls := aInfo[ 1 ]
::nTicks := aInfo[ 2 ]
Return( self )
Return Self
/////
Access nSeconds Class HBProfileEntity
Return( HB_Clocks2Secs( ::nTicks ) )
Return HB_Clocks2Secs( ::nTicks )
/////
Access nMeanTicks Class HBProfileEntity
Return( if( ::nCalls == 0, 0, ::nTicks / ::nCalls ) )
Return iif( ::nCalls == 0, 0, ::nTicks / ::nCalls )
/////
Access nMeanSeconds Class HBProfileEntity
Return( if( ::nCalls == 0, 0, ::nSeconds / ::nCalls ) )
Return iif( ::nCalls == 0, 0, ::nSeconds / ::nCalls )
/////
Method describe Class HBProfileEntity
Return( "Base Entity" )
Return "Base Entity"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileFunction
@@ -268,12 +268,12 @@ Create Class HBProfileFunction Inherit HBProfileEntity
Method describe
End Class
Endclass
/////
Method describe Class HBProfileFunction
Return( "Function" )
Return "Function"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileMethod
@@ -284,12 +284,12 @@ Create Class HBProfileMethod Inherit HBProfileEntity
Method describe
End Class
Endclass
/////
Method describe Class HBProfileMethod
Return( "Method" )
Return "Method"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileOPCode
@@ -300,12 +300,12 @@ Create Class HBProfileOPCode Inherit HBProfileEntity
Method describe
End Class
Endclass
/////
Method describe Class HBProfileOPCode
Return( "OPCode" )
Return "OPCode"
////////////////////////////////////////////////////////////////////////////
// Class: HBProfile
@@ -334,7 +334,7 @@ Create Class HBProfile
Method reset
Method ignoreSymbol
End Class
Endclass
/////
@@ -345,7 +345,7 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return( self )
Return Self
/////
@@ -353,13 +353,13 @@ Method reset Class HBProfile
::aProfile := {}
Return( self )
Return Self
/////
Method ignoreSymbol( cSymbol ) Class HBProfile
Local cProfPrefix := "HBPROFILE"
Return( ( left( cSymbol, len( cProfPrefix ) ) == cProfPrefix ) .Or. ( cSymbol == "__SETPROFILER" ) )
Return Left( cSymbol, Len( cProfPrefix ) ) == cProfPrefix .Or. cSymbol == "__SETPROFILER"
/////
@@ -380,7 +380,7 @@ Local n
// If we're not ignoring the symbol...
If !::ignoreSymbol( cName := __DynSGetName( n ) )
// Yes, it is, add it to the profile.
aadd( ::aProfile, HBProfileFunction():new( cName, __DynSGetPrf( n ) ) )
AAdd( ::aProfile, HBProfileFunction():new( cName, __DynSGetPrf( n ) ) )
EndIf
EndIf
@@ -389,7 +389,7 @@ Local n
__setProfiler( lProfile )
Return( self )
Return Self
/////
@@ -402,20 +402,20 @@ Local aMembers
Local nMember
// For each class in the environment...
Do While !empty( cClass := __className( n ) )
Do While !Empty( cClass := __className( n ) )
// If we're not ignoring the class' methods...
If !::ignoreSymbol( cClass )
// Collect class members.
nMembers := len( aMembers := __classSel( n ) )
nMembers := Len( aMembers := __classSel( n ) )
For nMember := 1 To nMembers
// If we've got a member name...
If !empty( aMembers[ nMember ] )
// Add it to the profile.
aadd( ::aProfile, HBProfileMethod():new( cClass + ":" + aMembers[ nMember ], __GetMsgPrf( n, aMembers[ nMember ] ) ) )
AAdd( ::aProfile, HBProfileMethod():new( cClass + ":" + aMembers[ nMember ], __GetMsgPrf( n, aMembers[ nMember ] ) ) )
EndIf
Next
@@ -428,7 +428,7 @@ Local nMember
__setProfiler( lProfile )
Return( self )
Return Self
/////
@@ -446,62 +446,62 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return( self )
Return Self
/////
Method forEach( b ) Class HBProfile
Local lProfile := __setProfiler( .F. )
aeval( ::aProfile, b )
AEval( ::aProfile, b )
__setProfiler( lProfile )
Return( self )
Return Self
/////
Method sort( b ) Class HBProfile
Local lProfile := __setProfiler( .F. )
asort( ::aProfile,,, b )
ASort( ::aProfile,,, b )
__setProfiler( lProfile )
Return( self )
Return Self
/////
Method nameSort Class HBProfile
Local lProfile := __setProfiler( .F. )
::sort( {|oX, oY| oX:cName < oY:cName } )
::sort( {| oX, oY | oX:cName < oY:cName } )
__setProfiler( lProfile )
Return( self )
Return Self
/////
Method callSort Class HBProfile
Local lProfile := __setProfiler( .F. )
::sort( {|oX, oY| oX:nCalls > oY:nCalls } )
::sort( {| oX, oY | oX:nCalls > oY:nCalls } )
__setProfiler( lProfile )
Return( self )
Return Self
/////
Method timeSort Class HBProfile
Local lProfile := __setProfiler( .F. )
::sort( {|oX, oY| oX:nTicks > oY:nTicks } )
::sort( {| oX, oY | oX:nTicks > oY:nTicks } )
__setProfiler( lProfile )
Return( self )
Return Self
/////
@@ -509,11 +509,11 @@ Method totalCalls Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nCalls := 0
::forEach( {|o| nCalls += o:nCalls } )
::forEach( {| o | nCalls += o:nCalls } )
__setProfiler( lProfile )
Return( nCalls )
Return nCalls
/////
@@ -521,11 +521,11 @@ Method totalTicks Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nTicks := 0
::forEach( {|o| nTicks += o:nTicks } )
::forEach( {| o | nTicks += o:nTicks } )
__setProfiler( lProfile )
Return( nTicks )
Return nTicks
/////
@@ -533,11 +533,11 @@ Method totalSeconds Class HBProfile
Local lProfile := __setProfiler( .F. )
Local nSeconds := 0
::forEach( {|o| nSeconds += o:nSeconds } )
::forEach( {| o | nSeconds += o:nSeconds } )
__setProfiler( lProfile )
Return( nSeconds )
Return nSeconds
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileLowLevel
@@ -552,7 +552,7 @@ Create Class HBProfileLowLevel Inherit HBProfile
Method gatherOPCodes
End Class
Endclass
/////
@@ -567,7 +567,7 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return( self )
Return Self
/////
@@ -579,20 +579,20 @@ Local nOP
// Loop over all the harbour OP codes. Note that they start at 0.
For nOP := 0 To ( nMax - 1 )
// If we're not ignoring this opcode.
If !::ignoreSymbol( cName := "OPCODE( " + padl( nOP, 3 ) + " )" )
If !::ignoreSymbol( cName := "OPCODE( " + PadL( nOP, 3 ) + " )" )
// Add it to the profile.
aadd( ::aProfile, HBProfileOPCode():new( cName, __OpGetPrf( nOP ) ) )
AAdd( ::aProfile, HBProfileOPCode():new( cName, __OpGetPrf( nOP ) ) )
EndIf
Next
Return( self )
Return Self
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReport
Create Class HBProfileReport
// Protected:
Protected:
Var oProfile
@@ -607,7 +607,7 @@ Create Class HBProfileReport
Method init
Method generate
End Class
Endclass
/////
@@ -618,21 +618,21 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return( self )
Return Self
/////
Method writeLines( aLines ) Class HBProfileReport
aeval( aLines, {|c| qout( c ) } )
AEval( aLines, {| c | QOut( c ) } )
Return( self )
Return Self
/////
Method header Class HBProfileReport
Return( { "Name Type Calls Ticks Seconds",;
"=================================== ========== ======== =========== ===========" } )
Return { "Name Type Calls Ticks Seconds",;
"=================================== ========== ======== =========== ===========" }
/////
@@ -640,16 +640,16 @@ Method emitHeader Class HBProfileReport
::writeLines( ::header() )
Return( self )
Return Self
/////
Method line( oEntity ) Class HBProfileReport
Return( { padr( oEntity:cName, 35 ) + " " + ;
padr( oEntity:describe(), 8 ) + " " + ;
padl( oEntity:nCalls, 10 ) + " " + ;
padl( oEntity:nTicks, 11 ) + " " + ;
str( oEntity:nSeconds, 11, 2 ) } )
Return { PadR( oEntity:cName, 35 ) + " " + ;
PadR( oEntity:describe(), 8 ) + " " + ;
PadL( oEntity:nCalls, 10 ) + " " + ;
PadL( oEntity:nTicks, 11 ) + " " + ;
Str( oEntity:nSeconds, 11, 2 ) }
/////
@@ -657,7 +657,7 @@ Method emitLine( oEntity ) Class HBProfileReport
::writeLines( ::line( oEntity ) )
Return( self )
Return Self
/////
@@ -666,18 +666,18 @@ Local lProfile := __setProfiler( .F. )
Default bFilter To {|| .T. }
::emitHeader():oProfile:forEach( {|o| if( eval( bFilter, o ), ::emitLine( o ), NIL ) } )
::emitHeader():oProfile:forEach( {| o | iif( Eval( bFilter, o ), ::emitLine( o ), NIL ) } )
__setProfiler( lProfile )
Return( self )
Return Self
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToFile
Create Class HBProfileReportToFile Inherit HBProfileReport
// Protected:
Protected:
Var hFile
@@ -687,17 +687,17 @@ Create Class HBProfileReportToFile Inherit HBProfileReport
Method generate
End Class
Endclass
/////
Method writeLines( aLines ) Class HBProfileReportToFile
If ::hFile != F_ERROR
aeval( aLines, {|c| fwrite( ::hFile, c + HB_OSNewLine() ) } )
AEval( aLines, {| c | FWrite( ::hFile, c + HB_OSNewLine() ) } )
EndIf
Return( self )
Return Self
/////
@@ -715,14 +715,14 @@ Local lProfile := __setProfiler( .F. )
__setProfiler( lProfile )
Return( self )
Return Self
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToArray
Create Class HBProfileReportToArray Inherit HBProfileReport
// Protected:
Protected:
Var aReport
@@ -732,15 +732,15 @@ Create Class HBProfileReportToArray Inherit HBProfileReport
Method generate
End Class
Endclass
/////
Method writeLines( aLines ) Class HBProfileReportToArray
aeval( aLines, {|c| aadd( ::aReport, c ) } )
AEval( aLines, {| c | AAdd( ::aReport, c ) } )
Return( self )
Return Self
/////
@@ -749,7 +749,7 @@ Method generate( bFilter ) Class HBProfileReportToArray
::aReport := {}
::super:generate( bFilter )
Return( ::aReport )
Return ::aReport
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToString
@@ -760,16 +760,16 @@ Create Class HBProfileReportToString Inherit HBProfileReportToArray
Method generate
End Class
Endclass
/////
Method generate( bFilter ) Class HBProfileReportToString
Local cReport := ""
aeval( ::super:generate( bFilter ), {|c| cReport += c + HB_OSNewLine() } )
AEval( ::super:generate( bFilter ), {| c | cReport += c + HB_OSNewLine() } )
Return( cReport )
Return cReport
////////////////////////////////////////////////////////////////////////////
// Class: HBProfileReportToTBrowse
@@ -777,7 +777,7 @@ Return( cReport )
Create Class HBProfileReportToTBrowse Inherit HBProfileReportToArray
// Protected:
Protected:
Var nEntity
@@ -790,7 +790,7 @@ Create Class HBProfileReportToTBrowse Inherit HBProfileReportToArray
Method generate
Method currentEntity
End Class
Endclass
/////
@@ -798,16 +798,16 @@ Method emitHeader Class HBProfileReportToTBrowse
// No header required.
Return( self )
Return Self
/////
Method emitLine( oEntity ) Class HBProfileReportToTBrowse
// Don't "emit" anything, simply add the entity to the array.
aadd( ::aReport, oEntity )
AAdd( ::aReport, oEntity )
Return( self )
Return Self
/////
@@ -822,39 +822,39 @@ Local oBrowse
::super:generate( bFilter )
// Build the browse.
oBrowse := tbrowsenew( nTop, nLeft, nBottom, nRight )
oBrowse := TBrowseNew( nTop, nLeft, nBottom, nRight )
oBrowse:goTopBlock := {|| ::nEntity := 1 }
oBrowse:goBottomBlock := {|| ::nEntity := len( ::aReport ) }
oBrowse:skipBlock := {|nSkip, nPos| nPos := ::nEntity, ;
::nEntity := if( nSkip > 0, ;
min( len( ::aReport ), ::nEntity + nSkip ), ;
max( 1, ::nEntity + nSkip ) ), ::nEntity - nPos }
oBrowse:goBottomBlock := {|| ::nEntity := Len( ::aReport ) }
oBrowse:skipBlock := {| nSkip, nPos | nPos := ::nEntity, ;
::nEntity := iif( nSkip > 0, ;
Min( Len( ::aReport ), ::nEntity + nSkip ), ;
Max( 1, ::nEntity + nSkip ) ), ::nEntity - nPos }
::addColumns( oBrowse )
__setProfiler( lProfile )
Return( oBrowse )
Return oBrowse
/////
Method addColumns( oBrowse ) Class HBProfileReportToTBrowse
oBrowse:addColumn( tbcolumnnew( "Name", {|| padr( ::currentEntity():cName, 35 ) } ) )
oBrowse:addColumn( tbcolumnnew( "Type", {|| padr( ::currentEntity():describe(), 8 ) } ) )
oBrowse:addColumn( tbcolumnnew( "Calls", {|| padl( ::currentEntity():nCalls, 10 ) } ) )
oBrowse:addColumn( tbcolumnnew( "Ticks", {|| padl( ::currentEntity():nTicks, 11 ) } ) )
oBrowse:addColumn( tbcolumnnew( "Seconds", {|| str( ::currentEntity():nSeconds, 11, 2 ) } ) )
oBrowse:addColumn( tbcolumnnew( "Mean;Ticks", {|| str( ::currentEntity():nMeanTicks, 11, 2 ) } ) )
oBrowse:addColumn( tbcolumnnew( "Mean;Seconds", {|| str( ::currentEntity():nMeanSeconds, 11, 2 ) } ) )
oBrowse:addColumn( TBColumnNew( "Name", {|| PadR( ::currentEntity():cName, 35 ) } ) )
oBrowse:addColumn( TBColumnNew( "Type", {|| PadR( ::currentEntity():describe(), 8 ) } ) )
oBrowse:addColumn( TBColumnNew( "Calls", {|| PadL( ::currentEntity():nCalls, 10 ) } ) )
oBrowse:addColumn( TBColumnNew( "Ticks", {|| PadL( ::currentEntity():nTicks, 11 ) } ) )
oBrowse:addColumn( TBColumnNew( "Seconds", {|| Str( ::currentEntity():nSeconds, 11, 2 ) } ) )
oBrowse:addColumn( TBColumnNew( "Mean;Ticks", {|| Str( ::currentEntity():nMeanTicks, 11, 2 ) } ) )
oBrowse:addColumn( TBColumnNew( "Mean;Seconds", {|| Str( ::currentEntity():nMeanSeconds, 11, 2 ) } ) )
Return( self )
Return Self
/////
Method currentEntity Class HBProfileReportToTBrowse
Return( ::aReport[ ::nEntity ] )
Return ::aReport[ ::nEntity ]
/*
* profiler.prg ends here.

2
harbour/source/rtl/pushbtn.prg
View File

@@ -50,7 +50,7 @@
*
*/
#include 'hbclass.ch'
#include "hbclass.ch"
#include "button.ch"
#include "color.ch"

16
harbour/source/rtl/radiogrp.prg
View File

@@ -321,7 +321,7 @@ METHOD killFocus() CLASS RADIOGROUP
LOCAL nLen
LOCAL aItems
LOCAL nCurMCur
LOCAL nOldMCur
IF ::lHasFocus
@@ -334,7 +334,7 @@ METHOD killFocus() CLASS RADIOGROUP
aItems := ::aItems
nLen := ::nItemCount
nCurMCur := MSetCursor( .F. )
nOldMCur := MSetCursor( .F. )
DispBegin()
@@ -346,7 +346,7 @@ METHOD killFocus() CLASS RADIOGROUP
DispEnd()
MSetCursor( nCurMCur )
MSetCursor( nOldMCur )
SetCursor( ::nCursor )
ENDIF
@@ -359,7 +359,7 @@ METHOD setFocus() CLASS RADIOGROUP
LOCAL nLen
LOCAL aItems
LOCAL nCurMCur
LOCAL nOldMCur
IF !::lHasFocus
@@ -369,7 +369,7 @@ METHOD setFocus() CLASS RADIOGROUP
aItems := ::aItems
nLen := ::nItemCount
nCurMCur := MSetCursor( .F. )
nOldMCur := MSetCursor( .F. )
DispBegin()
@@ -381,7 +381,7 @@ METHOD setFocus() CLASS RADIOGROUP
DispEnd()
MSetCursor( nCurMCur )
MSetCursor( nOldMCur )
IF ISBLOCK( ::bFBlock )
Eval( ::bFBlock )
@@ -477,7 +477,7 @@ METHOD setStyle( cStyle ) CLASS RADIOGROUP
RETURN Self
METHOD changeButton( nUnselect, nSelect ) CLASS RADIOGROUP
LOCAL nCurMCur := MSetCursor( .F. )
LOCAL nOldMCur := MSetCursor( .F. )
IF nUnselect != nSelect
@@ -500,7 +500,7 @@ METHOD changeButton( nUnselect, nSelect ) CLASS RADIOGROUP
ENDIF
MSetCursor( nCurMCur )
MSetCursor( nOldMCur )
RETURN Self

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

@@ -55,7 +55,7 @@
#include "hbclass.ch"
CLASS ScalarObject
CREATE CLASS ScalarObject
MESSAGE Become METHOD BecomeErr() // a scalar cannot "become" another object
METHOD Copy()
@@ -79,22 +79,22 @@ METHOD AsString() CLASS ScalarObject
local cType := ValType( Self )
do case
case cType == 'B'
case cType == "B"
return "{ || ... }"
case cType == 'C'
case cType == "C"
return Self
case cType == 'D'
case cType == "D"
return DToC( Self )
case cType == 'L'
return If( Self, ".T.", ".F." )
case cType == "L"
return iif( Self, ".T.", ".F." )
case cType == 'N'
case cType == "N"
return LTrim( Str( Self ) )
case cType == 'U'
case cType == "U"
return "NIL"
endcase
@@ -104,16 +104,15 @@ METHOD AsExpStr() CLASS ScalarObject
local cType := ValType( Self )
if cType == 'C'
if cType == "C"
return ["] + Self + ["]
elseif cType == 'D'
elseif cType == "D"
return [CToD("] + DToC( Self ) + [")]
end
endif
return ::AsString()
METHOD BecomeErr() CLASS ScalarObject
// Not implemented yet
// ::error(CSYERR_BECOME, "Message 'become' illegally sent to scalar", ::className)
return nil
// ::error( CSYERR_BECOME, "Message 'become' illegally sent to scalar", ::ClassName() )
return NIL

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

@@ -52,17 +52,18 @@
#include "hbclass.ch"
CLASS Symbol
CREATE CLASS Symbol
DATA nSym HIDDEN // internal pointer to the Symbols table symbol
PROTECTED:
VAR nSym // internal pointer to the Symbols table symbol
EXPORT:
METHOD New( cSymName ) // Constructor. cSymName may already exists or not
METHOD Name() // retrieves the symbol name
METHOD IsEqual( oSymbol ) // Compares two symbol objects
METHOD Exec() // Executes the function referred to by the
METHOD name() // retrieves the symbol name
METHOD isEqual( oSymbol ) // Compares two symbol objects
METHOD exec() // Executes the function referred to by the
// Symbol object, with an optional parameters list
ENDCLASS
@@ -71,11 +72,11 @@ METHOD New( cSymName ) CLASS Symbol
::nSym := __DynSN2Sym( cSymName )
return Self
METHOD Name() CLASS Symbol
METHOD name() CLASS Symbol
return ::nSym:Name
METHOD IsEqual( oSymbol ) CLASS Symbol
METHOD isEqual( oSymbol ) CLASS Symbol
return ::ClassH == oSymbol:ClassH .AND. ::nSym:Name == oSymbol:nSym:Name
METHOD Exec( ... ) CLASS Symbol
METHOD exec( ... ) CLASS Symbol
return ::nSym:exec( ... )

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

@@ -63,9 +63,13 @@
* Copyright 2001 Manu Exposito <maex14@dipusevilla.es>
* Activate data PICTURE DispCell( nColumn, nColor )
*
* Copyright 2007 Viktor Szakats <harbour.01 syenar.hu>
* tbr_CookColor(), tbr_GetColor()
*
* See doc/license.txt for licensing terms.
*
*/
/* NOTE: Don't use SAY in this module, use DispOut(), DispOutAt() instead,
otherwise it will not be CA-Cl*pper compatible.
ADDITION: Same goes for DevPos(), always use SetPos() instead.
@@ -212,6 +216,7 @@ CREATE CLASS TBrowse
VAR n_Bottom INIT 0 // Bottom row number for the TBrowse display
VAR n_Right INIT 0 // Rightmost column for the TBrowse display
VAR cColorSpec // Color table for the TBrowse display
VAR aColorSpec // Color table for the TBrowse display (preprocessed)
VAR cColSep INIT " " // Column separator character
VAR cFootSep INIT "" // Footing separator character
VAR cHeadSep INIT "" // Heading separator character
@@ -302,8 +307,10 @@ METHOD configure( nMode ) CLASS TBrowse
local n
local nHeight
#ifdef HB_COMPAT_C53
local nLeft
local nRight
#endif
::lHeaders := .F.
::lFooters := .F.
@@ -1070,7 +1077,7 @@ METHOD stabilize() CLASS TBrowse
if ::aRedraw[ nRow ]
DispOutAt( ::n_Top + nRow + iif( ::lHeaders, ::nHeaderHeight, 0 ) + iif( Empty( ::cHeadSep ) .or. !::lHeaders, 0, 1 ) - 1, ::n_Left,;
Space( ( nWidth - ::nColsWidth ) / 2 ), ::cColorSpec )
Space( ( nWidth - ::nColsWidth ) / 2 ), ::aColorSpec[ 1 ] )
for n := iif( ::nFrozenCols > 0, 1, ::leftVisible ) to ::rightVisible
@@ -1097,21 +1104,21 @@ METHOD stabilize() CLASS TBrowse
::DispCell( nRow, n, TBC_CLR_STANDARD )
else
// Clear cell
DispOut( Space( ::aColsWidth[ n ] ), tbr_GetColor( ::cColorSpec, ::aColumns[ n ]:defColor, TBC_CLR_STANDARD ) )
DispOut( Space( ::aColsWidth[ n ] ), tbr_GetColor( ::aColorSpec, ::aColumns[ n ]:defColor, TBC_CLR_STANDARD ) )
endif
if n < ::rightVisible
if ::aColumns[ n + 1 ]:ColSep != NIL
DispOut( ::aColumns[ n + 1 ]:ColSep, ::cColorSpec )
DispOut( ::aColumns[ n + 1 ]:ColSep, ::aColorSpec[ 1 ] )
elseif ::cColSep != NIL
DispOut( ::cColSep, ::cColorSpec )
DispOut( ::cColSep, ::aColorSpec[ 1 ] )
endif
endif
next
DispOut( Space( Int( Round( ( nWidth - ::nColsWidth ) / 2, 0 ) ) ), ::cColorSpec )
DispOut( Space( Int( Round( ( nWidth - ::nColsWidth ) / 2, 0 ) ) ), ::aColorSpec[ 1 ] )
// doesn't need to be redrawn
::aRedraw[ nRow ] := .F.
@@ -1470,14 +1477,14 @@ METHOD DispCell( nRow, nCol, nMode ) CLASS TBrowse
nRow >= ::aRect[ 1 ] .and. ;
nRow <= ::aRect[ 3 ] .and. ;
! Empty( ::aRectColor )
cColor := tbr_GetColor( ::cColorSpec, ::aRectColor, nMode )
cColor := tbr_GetColor( ::aColorSpec, ::aRectColor, nMode )
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( ::cColorSpec, iif( ISARRAY( aDefColor ), aDefColor, oCol:defColor ), nMode )
cColor := tbr_GetColor( ::aColorSpec, iif( ISARRAY( aDefColor ), aDefColor, oCol:defColor ), nMode )
endif
do case
@@ -1518,7 +1525,7 @@ METHOD WriteMLineText( cStr, nPadLen, lHeader, cColor ) CLASS TBrowse
DispOut( PadR( cStr, nPadLen ), cColor )
else
// Headers are aligned to bottom
cStr := Replicate( ";", ::nHeaderHeight - hb_TokenCount( cStr, ";" ) + 1 ) + cStr
cStr := Replicate( ";", ::nHeaderHeight - hb_TokenCount( cStr, ";" ) ) + cStr
for n := ::nHeaderHeight to 1 step -1
SetPos( nRow + n - 1, nCol )
@@ -1592,11 +1599,22 @@ METHOD redrawHeaders() CLASS TBrowse
local nScreenRowB
local nLCS // Len( ColSep )
local nWidth := ::n_Right - ::n_Left + 1
local nColor
if ::lHeaders // Drawing headers
if ::lHeaders // Drawing headers
// Clear area of screen occupied by headers
DispBox( ::n_Top, ::n_Left, ::n_Top + ::nHeaderHeight - 1, ::n_Right, cBlankBox, ::cColorSpec )
DispBox( ::n_Top, ::n_Left, ::n_Top + ::nHeaderHeight - 1, ::n_Right, cBlankBox, ::aColorSpec[ 1 ] )
if Empty( ::cHeadSep ) // Draw horizontal heading separator line
nScreenRowT := NIL
/* ; NOTE: This is a bug in CA-Cl*pper 5.3. [vszakats] */
nColor := TBC_CLR_STANDARD
else
DispOutAt( ( nScreenRowT := ::n_Top + ::nHeaderHeight ), ::n_Left,;
Replicate( Right( ::cHeadSep, 1 ), nWidth ), ::aColorSpec[ 1 ] )
nColor := TBC_CLR_HEADING
endif
// Set cursor at first field start of description
SetPos( ::n_Top, ::n_Left + ( ( nWidth - ::nColsWidth ) / 2 ) )
@@ -1606,7 +1624,7 @@ METHOD redrawHeaders() CLASS TBrowse
n := ::leftVisible
endif
::WriteMLineText( ::aColumns[ n ]:Heading, ::aColsWidth[ n ], .T., tbr_GetColor( ::cColorSpec, ::aColumns[ n ]:defColor, TBC_CLR_HEADING ) )
::WriteMLineText( ::aColumns[ n ]:Heading, ::aColsWidth[ n ], .T., tbr_GetColor( ::aColorSpec, ::aColumns[ n ]:defColor, nColor ) )
if n < ::rightVisible
// Set cursor at start of next field description
@@ -1615,49 +1633,20 @@ METHOD redrawHeaders() CLASS TBrowse
next
endif
if ! Empty( ::cHeadSep ) .and. ::lHeaders // Draw horizontal heading separator line
DispOutAt( ( nScreenRowT := ::n_Top + ::nHeaderHeight ), ::n_Left,;
Replicate( Right( ::cHeadSep, 1 ), nWidth ), ::cColorSpec )
else
nScreenRowT := NIL
endif
if ! Empty( ::cFootSep ) .and. ::lFooters // Draw horizontal footing separator line
DispOutAt( ( nScreenRowB := ::n_Bottom - ::nFooterHeight ), ::n_Left,;
Replicate( Right( ::cFootSep, 1 ), nWidth ), ::cColorSpec )
else
nScreenRowB := NIL
endif
nTPos := nBPos := ::n_Left + ( ( nWidth - ::nColsWidth ) / 2 )
// Draw headin/footing column separator
for n := iif( ::nFrozenCols > 0, 1, ::leftVisible ) to ::rightVisible
if ::nFrozenCols > 0 .and. n == ::nFrozenCols + 1
n := ::leftVisible
endif
if n < ::rightVisible
nLCS := iif( ::aColumns[ n + 1 ]:ColSep != NIL, Len( ::aColumns[ n + 1 ]:ColSep ), Len( ::cColSep ) )
if nScreenRowT != NIL
DispOutAt( nScreenRowT, ( nTPos += ::aColsWidth[ n ] ), Left( ::cHeadSep, nLCS ), ::cColorSpec )
nTPos += nLCS
endif
if nScreenRowB != NIL
DispOutAt( nScreenRowB, ( nBPos += ::aColsWidth[ n ] ), Left( ::cFootSep, nLCS ), ::cColorSpec )
nBPos += nLCS
endif
endif
next
if ::lFooters // Drawing footers
if ::lFooters // Drawing footers
// Clear area of screen occupied by footers
DispBox( ::n_Bottom - ::nFooterHeight + 1, ::n_Left, ::n_Bottom, ::n_Right, cBlankBox, ::cColorSpec )
DispBox( ::n_Bottom - ::nFooterHeight + 1, ::n_Left, ::n_Bottom, ::n_Right, cBlankBox, ::aColorSpec[ 1 ] )
if Empty( ::cFootSep ) // Draw horizontal footing separator line
nScreenRowB := NIL
/* ; NOTE: This is a bug in CA-Cl*pper 5.3. [vszakats] */
nColor := TBC_CLR_STANDARD
else
DispOutAt( ( nScreenRowB := ::n_Bottom - ::nFooterHeight ), ::n_Left,;
Replicate( Right( ::cFootSep, 1 ), nWidth ), ::aColorSpec[ 1 ] )
nColor := TBC_CLR_FOOTING
endif
// Set cursor at first field start of description
SetPos( ::n_Bottom, ::n_Left + ( ( nWidth - ::nColsWidth ) / 2 ) )
@@ -1667,7 +1656,7 @@ METHOD redrawHeaders() CLASS TBrowse
n := ::leftVisible
endif
::WriteMLineText( ::aColumns[ n ]:Footing, ::aColsWidth[ n ], .F., tbr_GetColor( ::cColorSpec, ::aColumns[ n ]:defColor, TBC_CLR_FOOTING ) )
::WriteMLineText( ::aColumns[ n ]:Footing, ::aColsWidth[ n ], .F., tbr_GetColor( ::aColorSpec, ::aColumns[ n ]:defColor, nColor ) )
if n < ::rightVisible
// Set cursor at start of next field description
@@ -1676,6 +1665,32 @@ METHOD redrawHeaders() CLASS TBrowse
next
endif
nTPos := nBPos := ::n_Left + ( ( nWidth - ::nColsWidth ) / 2 )
// Draw headin/footing column separator
for n := iif( ::nFrozenCols > 0, 1, ::leftVisible ) to ::rightVisible
if ::nFrozenCols > 0 .and. n == ::nFrozenCols + 1
n := ::leftVisible
endif
if n < ::rightVisible
nLCS := iif( ::aColumns[ n + 1 ]:ColSep != NIL, Len( ::aColumns[ n + 1 ]:ColSep ), Len( ::cColSep ) )
if nScreenRowT != NIL
DispOutAt( nScreenRowT, ( nTPos += ::aColsWidth[ n ] ), Left( ::cHeadSep, nLCS ), ::aColorSpec[ 1 ] )
nTPos += nLCS
endif
if nScreenRowB != NIL
DispOutAt( nScreenRowB, ( nBPos += ::aColsWidth[ n ] ), Left( ::cFootSep, nLCS ), ::aColorSpec[ 1 ] )
nBPos += nLCS
endif
endif
next
return Self
// NOTE: Not tested, could be broken
@@ -1692,10 +1707,10 @@ METHOD MGotoYX( nRow, nCol ) CLASS TBrowse
// if not stable force repositioning of data source; maybe this is not first Stabilize() call after
// TBrowse became unstable, but we need to call Stabilize() al least one time before moving again to be sure
// data source is under cursor position
if ! ::lStable
::Stabilize()
else
if ::lStable
::Moved()
else
::stabilize()
endif
// Set new row position
@@ -1788,6 +1803,7 @@ METHOD colorSpec( cColorSpec ) CLASS TBrowse
if cColorSpec != NIL
::cColorSpec := _eInstVar( Self, "COLORSPEC", cColorSpec, "C", 1001 )
::aColorSpec := tbr_CookColor( ::cColorSpec )
::Configure( 1 )
endif
@@ -2096,6 +2112,7 @@ METHOD New( nTop, nLeft, nBottom, nRight ) CLASS TBrowse
::nRight := nRight
::cColorSpec := SetColor()
::aColorSpec := tbr_CookColor( ::cColorSpec )
#ifdef HB_COMPAT_C53
::rect := { ::n_Top, ::n_Left, ::n_Bottom, ::n_Right }
@@ -2108,9 +2125,53 @@ FUNCTION TBrowseNew( nTop, nLeft, nBottom, nRight )
/* -------------------------------------------- */
/* NOTE: Preprocess user-supplied colorstring for internal usage. This is
needed to keep full C5.x compatibility while maintaining performace.
C5.x would always have at least two items, defaulted to the
current SetColor() values, the rest of the items are defaulted
to "N/N". [vszakats] */
STATIC FUNCTION tbr_CookColor( cColorSpec )
local nCount := Max( hb_TokenCount( cColorSpec, "," ), 2 )
local aColorSpec := Array( nCount )
local cColor
local nPos
for nPos := 1 TO nCount
cColor := hb_TokenGet( @cColorSpec, nPos, "," )
if nPos <= 2
aColorSpec[ nPos ] := iif( hb_ColorToN( cColor ) == 0 .AND. !( Upper( StrTran( cColor, " ", "" ) ) == "N/N" ), hb_ColorIndex( SetColor( "" ), nPos - 1 ), cColor )
else
aColorSpec[ nPos ] := iif( hb_ColorToN( cColor ) == 0, "N/N", cColor )
endif
next
return aColorSpec
/* NOTE: nMode can be 1/2 or 1/2/3/4 when compiled with HB_COMPAT_C53 (default) [vszakats] */
STATIC FUNCTION tbr_GetColor( cColorSpec, aDefColor, nMode )
return hb_ColorIndex( cColorSpec, iif( ISARRAY( aDefColor ) .and. nMode <= Len( aDefColor ), aDefColor, { 1, 2, 1, 1 } )[ nMode ] - 1 )
STATIC FUNCTION tbr_GetColor( aColorSpec, aDefColor, nMode )
/* NOTE: This is what C5.x does when the specified index is out of range
in the color items sepcified in ::cColorSpec. See in tbr_CookColor()
that we always have at least two color items. [vszakats] */
#define _COLORPOS_COOK( nPos ) iif( nPos > Len( aColorSpec ), 2 - ( nPos % 2 ), nPos )
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 )
/* 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, _COLORPOS_COOK( aDefColor[ 1 ] ), 1 ) ]
case TBC_CLR_FOOTING ; return aColorSpec[ iif( Len( aDefColor ) >= 1, _COLORPOS_COOK( aDefColor[ 1 ] ), 1 ) ]
endswitch
endif
return aColorSpec[ _COLORPOS_COOK( aDefColor[ nMode ] ) ]
STATIC FUNCTION tbr_CalcWidth( xValue, cType, cPicture )

7
harbour/source/rtl/ttextlin.prg
View File

@@ -52,10 +52,10 @@
#include "hbclass.ch"
CLASS HBTextLine
CREATE CLASS HBTextLine
DATA cText // A line of text
DATA lSoftCR // true if line doesn't end with a HB_OSNewLine() char (word wrapping)
VAR cText // A line of text
VAR lSoftCR // true if line doesn't end with a hb_OSNewLine() char (word wrapping)
METHOD New( cLine, lSoftCR )
@@ -68,4 +68,3 @@ METHOD New( cLine, lSoftCR ) CLASS HBTextLine
::lSoftCR := iif( Empty( lSoftCR ), .F., lSoftCR )
RETURN Self

2
harbour/source/rtl/typefile.prg
View File

@@ -83,7 +83,7 @@ PROCEDURE __TypeFile( cFile, lPrint )
cTmp := SET( _SET_DEFAULT ) + ";" + SET( _SET_PATH )
cTmp := StrTran( cTmp, ",", ";" )
i := Len( cTmp )
WHILE SubStr( cTmp, i, 1 ) == ";" // remove last ";"
DO WHILE SubStr( cTmp, i, 1 ) == ";" // remove last ";"
cTmp := LEFT( cTmp, --i )
ENDDO
aPath := HB_ATOKENS( cTmp, ";" )