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

2014-12-03 00:41 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)

Browse Source 
* include/hbsocket.ch
    + added HB_SOCKET_ERR_NONE

  * src/rtl/hbsocket.c
    * clear socket error when hb_socketRecv*() or hb_socketSend*() returns
      value greater then 0
    % removed unnecessary error code setting in MS-Windows builds
      of hb_socketGetIFaces()

  * src/rtl/filesys.c
    ! allocate dynamically buffer for current directory name if default
      one is too small when current disk is checked

  * src/rtl/hbzlib.c
    * use hb_xalloc()/hb_xfree() to allocate/free memory during
      ZLIB compression and decompression instead of ZLIB default
      ones (finished code started in Viktor's branch)

  * src/rtl/tlabel.prg
  * src/rtl/treport.prg
    % use hb_ATokens() instead of local functions ListAsArray()
    * simplified reading labels and reports from files

  * src/rtl/teditor.prg
  * src/rtl/tget.prg
  * src/rtl/tlabel.prg
  * src/rtl/treport.prg
    * synced with Viktor's branch:
      removed explicit NIL from parameters, formatting, updated comments
      and variable names, use FOR EACH and SWITCH statements,
      use hb_defaultValue(), use hb_StrShrink(), formatting, few fixes

  * src/rtl/langcomp.prg
    * synced with Viktor's branch

  * src/rtl/memoedit.prg
    * synced with Viktor's branch, optimizations, formatting and fixes:
    ; 2014-03-28 13:09 UTC+0100 Viktor Szakats
       + MemoEdit(): allow BLOCK and SYMBOL types for user callbacks
         (only in the default, non-strict mode)
       ! MemoEdit(): fixed to only handle certain types of events in ME_INIT
         stage in harmony with Cl*pper documentation
       ! MemoEdit(): fixed to not get into an infinite loop on initialization
         when user callback is returning unhandled value
         https://github.com/harbour/core/issues/21
       ! MemoEdit()/HBMemoEditor():KeyboardHook(): fixed to fall back to
         default handling of K_ESC if getting called recursively
         https://github.com/harbour/core/issues/21
       + HBMemoEditor():HandleUserKey(): now returns whether the event was
         handled (as logical value) (previously: Self) [INCOMPATIBLE]
       * fixed some misleading variable names
    ; 2014-01-28 03:11 UTC+0100 Viktor Szakáts
       ! MemoEdit() fixed to pass-through without interactivity
         when the user function is a boolean .F.
    ; 2014-01-27 15:15 UTC+0100 Viktor Szakáts
       % abort key checking optimized and made unicode compatible

  * src/rtl/listbox.prg
    * synced with Viktor's branch, optimizations, formatting and fixes:
    ; 2014-07-21 08:56 UTC+0200 Viktor Szakats
       ! ListBox():findData(): fixed to be able to search for non-string
         data, to the same extent Cl*ipper is able to.
       ! ListBox():findData(): fixed exact/case-insensitive regression
         from 6f8508ff54a3955822b36bf4a65a2775a11bab23
    ; 2014-07-21 03:26 UTC+0200 Viktor Szakats
       + LISTBOX object instance area made compatible with Cl*pper
         (relevant when object is accessed as array)
    ; 2014-07-21 01:20 UTC+0200 Viktor Szakats
       * renamed variable and macro to reflect their type
       + ListBox():findData(): documented potential RTE
    ; 2014-07-21 01:04 UTC+0200 Viktor Szakats
       % ListBox():findText(), ListBox():findData(): use hb_LeftEq[I]()
       ! ListBox():findText(), ListBox():findData(): fixed to not RTrim()
         while searching in EXACT mode. Regression from f61409bf19
       + ListBox():findText(), ListBox():findData(): allow to search
         for any type of data in HB_CLP_STRICT mode to mimic Cl*pper behavior
       ! ListBox():findText(): fixed to allow zero length search text,
         like Cl*pper. Regression from 93d3a46d84
       ! ListBox():addItem( cText, cData ): fixed to allow any type for cData,
         not just NIL and string, like Cl*pper
       + ListBox():setData(): documented a Cl*pper bug
    ; 2014-03-09 18:19 UTC+0100 Viktor Szakáts
       ! ListBox():scroll() fixed to ignore non-numeric parameter
         (like Cl*pper) instead of an RTE
This commit is contained in:
Przemysław Czerpak
2014-12-03 00:41:38 +01:00
parent bc7ff4d5c6
commit b9b235cff9
12 changed files with 925 additions and 1040 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
ChangeLog.txt
View File

@@ -10,6 +10,92 @@
* Change, ! Fix, % Optimization, + Addition, - Removal, ; Comment
*/
2014-12-03 00:41 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* include/hbsocket.ch
+ added HB_SOCKET_ERR_NONE
* src/rtl/hbsocket.c
* clear socket error when hb_socketRecv*() or hb_socketSend*() returns
value greater then 0
% removed unnecessary error code setting in MS-Windows builds
of hb_socketGetIFaces()
* src/rtl/filesys.c
! allocate dynamically buffer for current directory name if default
one is too small when current disk is checked
* src/rtl/hbzlib.c
* use hb_xalloc()/hb_xfree() to allocate/free memory during
ZLIB compression and decompression instead of ZLIB default
ones (finished code started in Viktor's branch)
* src/rtl/tlabel.prg
* src/rtl/treport.prg
% use hb_ATokens() instead of local functions ListAsArray()
* simplified reading labels and reports from files
* src/rtl/teditor.prg
* src/rtl/tget.prg
* src/rtl/tlabel.prg
* src/rtl/treport.prg
* synced with Viktor's branch:
removed explicit NIL from parameters, formatting, updated comments
and variable names, use FOR EACH and SWITCH statements,
use hb_defaultValue(), use hb_StrShrink(), formatting, few fixes
* src/rtl/langcomp.prg
* synced with Viktor's branch
* src/rtl/memoedit.prg
* synced with Viktor's branch, optimizations, formatting and fixes:
; 2014-03-28 13:09 UTC+0100 Viktor Szakats
+ MemoEdit(): allow BLOCK and SYMBOL types for user callbacks
(only in the default, non-strict mode)
! MemoEdit(): fixed to only handle certain types of events in ME_INIT
stage in harmony with Cl*pper documentation
! MemoEdit(): fixed to not get into an infinite loop on initialization
when user callback is returning unhandled value
https://github.com/harbour/core/issues/21
! MemoEdit()/HBMemoEditor():KeyboardHook(): fixed to fall back to
default handling of K_ESC if getting called recursively
https://github.com/harbour/core/issues/21
+ HBMemoEditor():HandleUserKey(): now returns whether the event was
handled (as logical value) (previously: Self) [INCOMPATIBLE]
* fixed some misleading variable names
; 2014-01-28 03:11 UTC+0100 Viktor Szakáts
! MemoEdit() fixed to pass-through without interactivity
when the user function is a boolean .F.
; 2014-01-27 15:15 UTC+0100 Viktor Szakáts
% abort key checking optimized and made unicode compatible
* src/rtl/listbox.prg
* synced with Viktor's branch, optimizations, formatting and fixes:
; 2014-07-21 08:56 UTC+0200 Viktor Szakats
! ListBox():findData(): fixed to be able to search for non-string
data, to the same extent Cl*ipper is able to.
! ListBox():findData(): fixed exact/case-insensitive regression
from 6f8508ff54a3955822b36bf4a65a2775a11bab23
; 2014-07-21 03:26 UTC+0200 Viktor Szakats
+ LISTBOX object instance area made compatible with Cl*pper
(relevant when object is accessed as array)
; 2014-07-21 01:20 UTC+0200 Viktor Szakats
* renamed variable and macro to reflect their type
+ ListBox():findData(): documented potential RTE
; 2014-07-21 01:04 UTC+0200 Viktor Szakats
% ListBox():findText(), ListBox():findData(): use hb_LeftEq[I]()
! ListBox():findText(), ListBox():findData(): fixed to not RTrim()
while searching in EXACT mode. Regression from f61409bf19731c8485aa29bae273cae090c77502
+ ListBox():findText(), ListBox():findData(): allow to search
for any type of data in HB_CLP_STRICT mode to mimic Cl*pper behavior
! ListBox():findText(): fixed to allow zero length search text,
like Cl*pper. Regression from 93d3a46d843daaf6d08149d83fa5203ff910c484
! ListBox():addItem( cText, cData ): fixed to allow any type for cData,
not just NIL and string, like Cl*pper
+ ListBox():setData(): documented a Cl*pper bug
; 2014-03-09 18:19 UTC+0100 Viktor Szakáts
! ListBox():scroll() fixed to ignore non-numeric parameter
(like Cl*pper) instead of an RTE
2014-11-29 06:03 UTC+0100 Przemyslaw Czerpak (druzus/at/poczta.onet.pl)
* include/hbapifs.h
* src/common/hbffind.c

1
include/hbsocket.ch
View File

@@ -52,6 +52,7 @@
#define HB_SOCKET_CH_
/* Harbour socket error codes */
#define HB_SOCKET_ERR_NONE 0
#define HB_SOCKET_ERR_PIPE 1
#define HB_SOCKET_ERR_TIMEOUT 2
#define HB_SOCKET_ERR_WRONGADDR 3

13
src/rtl/filesys.c
View File

@@ -350,12 +350,17 @@ static HB_BOOL s_fUseWaitLocks = HB_TRUE;
static int fs_win_get_drive( void )
{
TCHAR lpBuffer[ HB_PATH_MAX ];
TCHAR pBuffer[ HB_PATH_MAX ];
LPTSTR lpBuffer = pBuffer;
DWORD dwResult;
int iDrive = 0;
lpBuffer[ 0 ] = TEXT( '\0' );
dwResult = GetCurrentDirectory( HB_SIZEOFARRAY( lpBuffer ), lpBuffer );
dwResult = GetCurrentDirectory( HB_SIZEOFARRAY( pBuffer ), lpBuffer );
if( dwResult > HB_SIZEOFARRAY( lpBuffer ) )
{
lpBuffer = ( TCHAR * ) hb_xgrab( dwResult * sizeof( TCHAR ) );
dwResult = GetCurrentDirectory( dwResult, lpBuffer );
}
hb_fsSetIOError( dwResult != 0, 0 );
if( dwResult >= 2 && lpBuffer[ 1 ] == HB_OS_DRIVE_DELIM_CHR )
{
@@ -365,6 +370,8 @@ static int fs_win_get_drive( void )
else
iDrive = 0;
}
if( lpBuffer != pBuffer )
hb_xfree( lpBuffer );
return iDrive;
}

10
src/rtl/hbsocket.c
View File

@@ -2341,7 +2341,7 @@ long hb_socketSend( HB_SOCKET sd, const void * data, long len, int flags, HB_MAX
do
{
lSent = send( sd, ( const char * ) data, len, flags );
iError = HB_SOCK_GETERROR();
iError = lSent > 0 ? 0 : HB_SOCK_GETERROR();
hb_socketSetOsError( iError );
}
while( lSent == -1 && HB_SOCK_IS_EINTR( iError ) &&
@@ -2380,7 +2380,7 @@ long hb_socketSendTo( HB_SOCKET sd, const void * data, long len, int flags,
{
lSent = sendto( sd, ( const char * ) data, len, flags,
( const struct sockaddr * ) pSockAddr, ( socklen_t ) uiSockLen );
iError = HB_SOCK_GETERROR();
iError = lSent > 0 ? 0 : HB_SOCK_GETERROR();
hb_socketSetOsError( iError );
}
while( lSent == -1 && HB_SOCK_IS_EINTR( iError ) &&
@@ -2413,7 +2413,7 @@ long hb_socketRecv( HB_SOCKET sd, void * data, long len, int flags, HB_MAXINT ti
do
{
lReceived = recv( sd, ( char * ) data, len, flags );
iError = HB_SOCK_GETERROR();
iError = lReceived > 0 ? 0 : HB_SOCK_GETERROR();
hb_socketSetOsError( iError );
}
while( lReceived == -1 && HB_SOCK_IS_EINTR( iError ) &&
@@ -2454,7 +2454,7 @@ long hb_socketRecvFrom( HB_SOCKET sd, void * data, long len, int flags, void **
do
{
lReceived = recvfrom( sd, ( char * ) data, len, flags, &st.sa, &salen );
iError = HB_SOCK_GETERROR();
iError = lReceived > 0 ? 0 : HB_SOCK_GETERROR();
hb_socketSetOsError( iError );
}
while( lReceived == -1 && HB_SOCK_IS_EINTR( iError ) &&
@@ -3604,8 +3604,6 @@ PHB_ITEM hb_socketGetIFaces( int af, HB_BOOL fNoAliases )
hb_xfree( pBuffer );
hb_socketClose( sd );
}
else
iError = HB_SOCK_GETERROR();
#else
int iTODO;
HB_SYMBOL_UNUSED( af );

222
src/rtl/hbzlib.c
View File

@@ -61,13 +61,13 @@
we have to miss compressBound() when using zlib 1.2.0. [vszakats] */
/* ZLIB_VERNUM were added in version 1.2.0.2 so it cannot be used for older
zlib libraries */
#if defined( Z_RLE )
#define _HB_Z_COMPRESSBOUND
#if defined( Z_RLE ) && ! defined( Z_SOLO )
#define _HB_Z_COMPRESSBOUND
#endif
#if ! defined( _HB_Z_COMPRESSBOUND )
/* additional 12 bytes is for GZIP compression which uses bigger header */
#define deflateBound( s, n ) ( hb_zlibCompressBound( n ) + 12 )
#define deflateBound( s, n ) ( hb_zlibCompressBound( n ) + ( fGZip ? 12 : 0 ) )
#endif
static HB_SIZE s_zlibCompressBound( HB_SIZE nLen )
@@ -79,101 +79,36 @@ static HB_SIZE s_zlibCompressBound( HB_SIZE nLen )
#endif
}
static HB_SIZE s_zlibUncompressedSize( const char * szSrc, HB_SIZE nLen,
int * piResult )
static void * s_zlib_alloc( void * cargo, uInt items, uInt size )
{
HB_SYMBOL_UNUSED( cargo );
return ( items > 0 && size > 0 ) ? hb_xalloc( ( HB_SIZE ) items * size ) : NULL;
}
static void s_zlib_free( void * cargo, void * address )
{
HB_SYMBOL_UNUSED( cargo );
if( address )
hb_xfree( address );
}
static int s_zlibCompress2( char ** pDstPtr, HB_SIZE * pnDst,
const char * pSrc, HB_SIZE nSrc,
HB_BOOL fGZip, int level )
{
Byte buffer[ 1024 ];
z_stream stream;
HB_SIZE nDest = 0;
int iResult;
memset( &stream, 0, sizeof( z_stream ) );
stream.next_in = ( Bytef * ) szSrc;
stream.avail_in = ( uInt ) nLen;
/*
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.zalloc = s_zlib_alloc;
stream.zfree = s_zlib_free;
stream.opaque = NULL;
*/
*piResult = inflateInit2( &stream, 15 + 32 );
if( *piResult == Z_OK )
{
do
{
stream.next_out = buffer;
stream.avail_out = sizeof( buffer );
*piResult = inflate( &stream, Z_NO_FLUSH );
}
while( *piResult == Z_OK );
if( *piResult == Z_STREAM_END )
{
nDest = stream.total_out;
*piResult = Z_OK;
}
inflateEnd( &stream );
}
return nDest;
}
static int s_zlibUncompress( char * pDst, HB_SIZE * pnDst,
const char * pSrc, HB_SIZE nSrc )
{
z_stream stream;
int iResult;
memset( &stream, 0, sizeof( z_stream ) );
stream.next_in = ( Bytef* ) pSrc;
stream.avail_in = ( uInt ) nSrc;
iResult = inflateInit2( &stream, 15 + 32 );
if( iResult == Z_OK )
{
stream.next_out = ( Bytef* ) pDst;
stream.avail_out = ( uInt ) *pnDst;
do
{
iResult = inflate( &stream, Z_FINISH );
}
while( iResult == Z_OK );
if( iResult == Z_STREAM_END )
{
*pnDst = stream.total_out;
iResult = Z_OK;
}
inflateEnd( &stream );
}
return iResult;
}
static int s_zlibCompress( char * pDst, HB_SIZE * pnDst,
const char * pSrc, HB_SIZE nSrc, int level )
{
uLong ulDst = ( uLong ) *pnDst;
int iResult;
iResult = compress2( ( Bytef * ) pDst, &ulDst,
( Bytef * ) pSrc, ( uLong ) nSrc, level );
*pnDst = ulDst;
return iResult;
}
static int hb_gz_compress( char ** pDstPtr, HB_SIZE * pnDst,
const char * pSrc, HB_SIZE nSrc, int level )
{
z_stream stream;
int iResult;
memset( &stream, 0, sizeof( z_stream ) );
stream.next_in = ( Bytef* ) pSrc;
stream.avail_in = ( uInt ) nSrc;
iResult = deflateInit2( &stream, level, Z_DEFLATED, 15 + 16, 8,
iResult = deflateInit2( &stream, level, Z_DEFLATED,
15 + ( fGZip ? 16 : 0 ), 8,
Z_DEFAULT_STRATEGY );
if( iResult == Z_OK )
{
@@ -209,6 +144,84 @@ static int hb_gz_compress( char ** pDstPtr, HB_SIZE * pnDst,
return iResult;
}
static int s_zlibCompress( char * pDst, HB_SIZE * pnDst,
const char * pSrc, HB_SIZE nSrc, int level )
{
return s_zlibCompress2( &pDst, pnDst, pSrc, nSrc, HB_FALSE, level );
}
static HB_SIZE s_zlibUncompressedSize( const char * szSrc, HB_SIZE nLen,
int * piResult )
{
Byte buffer[ 1024 ];
z_stream stream;
HB_SIZE nDest = 0;
memset( &stream, 0, sizeof( z_stream ) );
stream.zalloc = s_zlib_alloc;
stream.zfree = s_zlib_free;
stream.opaque = NULL;
stream.next_in = ( Bytef * ) szSrc;
stream.avail_in = ( uInt ) nLen;
*piResult = inflateInit2( &stream, 15 + 32 );
if( *piResult == Z_OK )
{
do
{
stream.next_out = buffer;
stream.avail_out = sizeof( buffer );
*piResult = inflate( &stream, Z_NO_FLUSH );
}
while( *piResult == Z_OK );
if( *piResult == Z_STREAM_END )
{
nDest = stream.total_out;
*piResult = Z_OK;
}
inflateEnd( &stream );
}
return nDest;
}
static int s_zlibUncompress( char * pDst, HB_SIZE * pnDst,
const char * pSrc, HB_SIZE nSrc )
{
z_stream stream;
int iResult;
memset( &stream, 0, sizeof( z_stream ) );
stream.zalloc = s_zlib_alloc;
stream.zfree = s_zlib_free;
stream.opaque = NULL;
stream.next_in = ( Bytef* ) pSrc;
stream.avail_in = ( uInt ) nSrc;
iResult = inflateInit2( &stream, 15 + 32 );
if( iResult == Z_OK )
{
stream.next_out = ( Bytef* ) pDst;
stream.avail_out = ( uInt ) *pnDst;
do
{
iResult = inflate( &stream, Z_FINISH );
}
while( iResult == Z_OK );
if( iResult == Z_STREAM_END )
{
*pnDst = stream.total_out;
iResult = Z_OK;
}
inflateEnd( &stream );
}
return iResult;
}
/*
* hb_ZLibVersion( [<nType>] ) -> <cZlibVersion>
*/
@@ -280,6 +293,7 @@ HB_FUNC( HB_ZCOMPRESS )
if( nLen )
{
PHB_ITEM pBuffer = HB_ISBYREF( 2 ) ? hb_param( 2, HB_IT_STRING ) : NULL;
HB_BOOL fAlloc = HB_FALSE;
HB_SIZE nDstLen;
char * pDest;
int iResult;
@@ -291,20 +305,28 @@ HB_FUNC( HB_ZCOMPRESS )
}
else
{
nDstLen = HB_ISNUM( 2 ) ? ( HB_SIZE ) hb_parns( 2 ) :
s_zlibCompressBound( nLen );
pDest = ( char * ) hb_xalloc( nDstLen + 1 );
if( HB_ISNUM( 2 ) )
{
nDstLen = hb_parns( 2 );
pDest = ( char * ) hb_xalloc( nDstLen + 1 );
}
else
{
pDest = NULL;
nDstLen = 0;
fAlloc = HB_TRUE;
}
}
if( pDest )
if( pDest || fAlloc )
{
iResult = s_zlibCompress( pDest, &nDstLen, szData, nLen,
hb_parnidef( 4, Z_DEFAULT_COMPRESSION ) );
iResult = s_zlibCompress2( &pDest, &nDstLen, szData, nLen, HB_FALSE,
hb_parnidef( 4, Z_DEFAULT_COMPRESSION ) );
if( ! pBuffer )
{
if( iResult == Z_OK )
hb_retclen_buffer( pDest, nDstLen );
else
else if( pDest )
hb_xfree( pDest );
}
else if( iResult == Z_OK )
@@ -445,8 +467,8 @@ HB_FUNC( HB_GZCOMPRESS )
if( pDest || fAlloc )
{
iResult = hb_gz_compress( &pDest, &nDstLen, szData, nLen,
hb_parnidef( 4, Z_DEFAULT_COMPRESSION ) );
iResult = s_zlibCompress2( &pDest, &nDstLen, szData, nLen, HB_TRUE,
hb_parnidef( 4, Z_DEFAULT_COMPRESSION ) );
if( ! pBuffer )
{
if( iResult == Z_OK )

60
src/rtl/langcomp.prg
View File

@@ -46,13 +46,11 @@
*
*/
REQUEST HB_CODEPAGE_UTF8
#ifdef HB_LEGACY_LEVEL4
/* Required for legacy language modules with a two character ID.
These cannot have a compatibility puller symbol in langlgcy.prg,
which in turn pulls all CP modules, so we're pulling them from
here. */
/* Required for legacy language modules with a two character ID.
These cannot have a compatibility puller symbol in langlgcy.prg,
which in turn pulls all CP modules, so we're pulling them from
here. */
REQUEST HB_CODEPAGE_CS852
REQUEST HB_CODEPAGE_DE850
REQUEST HB_CODEPAGE_EL737
@@ -154,19 +152,19 @@ FUNCTION hb_langSelect( cLangID, cCP )
ENDIF
#ifdef HB_LEGACY_LEVEL4
IF ! Empty( cLangIDBase )
/* Legacy emulation */
cLangID := cLangIDBase
ELSE
IF Empty( cLangIDBase )
#endif
/* Support standard ISO language IDs */
IF ! Empty( tmp := __LangStdToLangHb( cLangID ) )
cLangID := cLangIDBase := tmp
ELSE
IF Empty( tmp := __LangStdToLangHb( cLangID ) )
/* Normal case */
cLangIDBase := cLangID
ELSE
cLangID := cLangIDBase := tmp
ENDIF
#ifdef HB_LEGACY_LEVEL4
ELSE
/* Legacy emulation */
cLangID := cLangIDBase
ENDIF
#endif
@@ -184,6 +182,7 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
IF HB_ISSTRING( cLangStd )
SWITCH Lower( StrTran( cLangStd, "_", "-" ) )
#if 0
CASE "af-za" ; EXIT
CASE "af" ; EXIT
CASE "ar-ae" ; EXIT
@@ -207,24 +206,31 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "az-az-latn" ; EXIT
CASE "az" ; EXIT
CASE "be-by" ; EXIT
#endif
CASE "be" ; cLangHb := "be" ; EXIT
CASE "bg-bg"
CASE "bg" ; cLangHb := "bg" ; EXIT
CASE "ca-es"
CASE "ca" ; cLangHb := "ca" ; EXIT
#if 0
CASE "cy-gb" ; EXIT
#endif
CASE "cs-cz"
CASE "cs" ; cLangHb := "cs" ; EXIT
#if 0
CASE "da-dk" ; EXIT
CASE "da" ; EXIT
#endif
CASE "de-at"
CASE "de-ch"
CASE "de-de"
CASE "de-li"
CASE "de-lu"
CASE "de" ; cLangHb := "de" ; EXIT
#if 0
CASE "div-mv" ; EXIT
CASE "div" ; EXIT
#endif
CASE "el-gr"
CASE "el" ; cLangHb := "el" ; EXIT
CASE "en-au"
@@ -263,16 +269,20 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "es-uy"
CASE "es-ve"
CASE "es" ; cLangHb := "es" ; EXIT
#if 0
CASE "et-ee" ; EXIT
CASE "et" ; EXIT
#endif
CASE "eu-es"
CASE "eu" ; cLangHb := "eu" ; EXIT
#if 0
CASE "fa-ir" ; EXIT
CASE "fa" ; EXIT
CASE "fi-fi" ; EXIT
CASE "fi" ; EXIT
CASE "fo-fo" ; EXIT
CASE "fo" ; EXIT
#endif
CASE "fr-be"
CASE "fr-ca"
CASE "fr-ch"
@@ -282,18 +292,24 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "fr" ; cLangHb := "fr" ; EXIT
CASE "gl-es"
CASE "gl" ; cLangHb := "gl" ; EXIT
#if 0
CASE "gu-in" ; EXIT
CASE "gu" ; EXIT
#endif
CASE "he-il"
CASE "he" ; cLangHb := "he" ; EXIT
#if 0
CASE "hi-in" ; EXIT
CASE "hi" ; EXIT
#endif
CASE "hr-hr"
CASE "hr" ; cLangHb := "hr" ; EXIT
CASE "hu-hu"
CASE "hu" ; cLangHb := "hu" ; EXIT
#if 0
CASE "hy-am" ; EXIT
CASE "hy" ; EXIT
#endif
CASE "id-id"
CASE "id" ; cLangHb := "id" ; EXIT
CASE "is-is"
@@ -301,6 +317,7 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "it-ch"
CASE "it-it"
CASE "it" ; cLangHb := "it" ; EXIT
#if 0
CASE "ja-jp" ; EXIT
CASE "ja" ; EXIT
CASE "ka-ge" ; EXIT
@@ -309,14 +326,18 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "kk" ; EXIT
CASE "kn-in" ; EXIT
CASE "kn" ; EXIT
#endif
CASE "ko-kr"
CASE "ko" ; cLangHb := "ko" ; EXIT
#if 0
CASE "kok-in" ; EXIT
CASE "kok" ; EXIT
CASE "ky-kz" ; EXIT
CASE "ky" ; EXIT
#endif
CASE "lt-lt"
CASE "lt" ; cLangHb := "lt" ; EXIT
#if 0
CASE "lv-lv" ; EXIT
CASE "lv" ; EXIT
CASE "mk-mk" ; EXIT
@@ -329,13 +350,16 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "ms-my" ; EXIT
CASE "ms" ; EXIT
CASE "nb-no" ; EXIT
#endif
CASE "nl-be"
CASE "nl-nl"
CASE "nl" ; cLangHb := "nl" ; EXIT
#if 0
CASE "nn-no" ; EXIT
CASE "no" ; EXIT
CASE "pa-in" ; EXIT
CASE "pa" ; EXIT
#endif
CASE "pl-pl"
CASE "pl" ; cLangHb := "pl" ; EXIT
CASE "pt-br" ; cLangHb := "pt_br" ; EXIT
@@ -345,19 +369,24 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "ro" ; cLangHb := "ro" ; EXIT
CASE "ru-ru"
CASE "ru" ; cLangHb := "ru" ; EXIT
#if 0
CASE "sa-in" ; EXIT
CASE "sa" ; EXIT
#endif
CASE "sk-sk"
CASE "sk" ; cLangHb := "sk" ; EXIT
CASE "sl-si"
CASE "sl" ; cLangHb := "sl" ; EXIT
#if 0
CASE "sq-al" ; EXIT
CASE "sq" ; EXIT
#endif
CASE "sr-sp-cyrl" ; cLangHb := "sr_cyr" ; EXIT
CASE "sr-sp-latn" ; cLangHb := "sr_lat" ; EXIT
CASE "sv-fi"
CASE "sv-se"
CASE "sv" ; cLangHb := "sv" ; EXIT
#if 0
CASE "sw-ke" ; EXIT
CASE "sw" ; EXIT
CASE "syr-sy" ; EXIT
@@ -368,12 +397,16 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "te" ; EXIT
CASE "th-th" ; EXIT
CASE "th" ; EXIT
#endif
CASE "tr-tr"
CASE "tr" ; cLangHb := "tr" ; EXIT
#if 0
CASE "tt-ru" ; EXIT
CASE "tt" ; EXIT
#endif
CASE "uk-ua"
CASE "uk" ; cLangHb := "uk" ; EXIT
#if 0
CASE "ur-pk" ; EXIT
CASE "ur" ; EXIT
CASE "uz-uz-cyrl" ; EXIT
@@ -381,6 +414,7 @@ STATIC FUNCTION __LangStdToLangHb( cLangStd )
CASE "uz" ; EXIT
CASE "vi-vn" ; EXIT
CASE "vi" ; EXIT
#endif
CASE "zh-chs" ; cLangHb := "zh_sim" ; EXIT
CASE "zh-cht"
CASE "zh-cn"

339
src/rtl/listbox.prg
View File

@@ -63,35 +63,65 @@
#ifdef HB_COMPAT_C53
#define _ITEM_cTEXT 1
#define _ITEM_cDATA 2
#define _ITEM_cText 1
#define _ITEM_xData 2
#define _LISTBOX_ITEMDATA( aItem ) iif( aItem[ _ITEM_cDATA ] == NIL, aItem[ _ITEM_cTEXT ], aItem[ _ITEM_cDATA ] )
#define _LISTBOX_ITEMDATA( aItem ) iif( aItem[ _ITEM_xData ] == NIL, aItem[ _ITEM_cText ], aItem[ _ITEM_xData ] )
CREATE CLASS ListBox FUNCTION HBListBox
PROTECTED:
/* --- Start of CA-Cl*pper compatible instance area --- */
VAR nBottom
VAR xBuffer
VAR cCaption INIT ""
VAR nCapCol
VAR nCapRow
VAR cargo EXPORTED
VAR cColdBox INIT HB_B_SINGLE_UNI
VAR cColorSpec
VAR aItems INIT {}
VAR lDropDown
VAR bFBlock
VAR lHasFocus INIT .F.
VAR cHotBox INIT HB_B_DOUBLE_UNI
VAR nItemCount INIT 0
VAR nLeft
VAR cMessage INIT ""
VAR aSaveScr
VAR lIsOpen
VAR nRight
VAR bSBlock
VAR nCursor
VAR cStyle INIT Chr( 31 ) /* LOW-ASCII "▼" */
VAR cTextValue INIT ""
VAR nTop
VAR nTopItem INIT 0
VAR oVScroll
VAR nValue INIT 0
VAR cBitmap INIT "dropbox.bmu"
EXPORTED:
VAR cargo
METHOD addItem( cText, cData )
METHOD addItem( cText, xData )
METHOD close()
METHOD delItem( nPos )
METHOD display()
METHOD findText( cText, nPos, lCaseSensitive, lExact )
METHOD findData( cData, nPos, lCaseSensitive, lExact ) /* NOTE: Undocumented CA-Cl*pper method. */
METHOD findData( xData, nPos, lCaseSensitive, lExact ) /* NOTE: Undocumented CA-Cl*pper method. */
METHOD getData( nPos )
METHOD getItem( nPos )
METHOD getText( nPos )
METHOD hitTest( nMRow, nMCol )
METHOD insItem( nPos, cText, cData )
METHOD insItem( nPos, cText, xData )
METHOD killFocus()
METHOD nextItem()
METHOD open()
METHOD prevItem()
METHOD scroll( nMethod )
METHOD select( xPos )
METHOD setData( nPos, cData )
METHOD setData( nPos, xData )
METHOD setFocus()
METHOD setItem( nPos, aItem )
METHOD setText( nPos, cText )
@@ -114,57 +144,28 @@ CREATE CLASS ListBox FUNCTION HBListBox
METHOD message( cMessage ) SETGET
METHOD right( nRight ) SETGET
METHOD sBlock( bSBlock ) SETGET
METHOD style( cStyle ) SETGET /* NOTE: Undocumented CA-Cl*pper method. */
METHOD textValue() SETGET /* NOTE: Undocumented CA-Cl*pper method. */
METHOD style( cStyle ) SETGET /* NOTE: Undocumented CA-Cl*pper method. */
METHOD textValue() SETGET /* NOTE: Undocumented CA-Cl*pper method. */
METHOD top( nTop ) SETGET
METHOD topItem( nTopItem ) SETGET
METHOD typeOut() SETGET
METHOD value() SETGET /* NOTE: Undocumented CA-Cl*pper method. */
METHOD value() SETGET /* NOTE: Undocumented CA-Cl*pper method. */
METHOD vScroll( oVScroll ) SETGET
METHOD New( nTop, nLeft, nBottom, nRight, lDropDown ) /* NOTE: This method is a Harbour extension [vszakats] */
METHOD New( nTop, nLeft, nBottom, nRight, lDropDown ) /* NOTE: This method is a Harbour extension [vszakats] */
PROTECTED:
VAR cBitmap INIT "dropbox.bmu"
VAR nBottom
VAR xBuffer
VAR nCapCol
VAR nCapRow
VAR cCaption INIT ""
VAR cColdBox INIT HB_B_SINGLE_UNI
VAR cColorSpec
VAR lDropDown
VAR bFBlock
VAR lHasFocus INIT .F.
VAR cHotBox INIT HB_B_DOUBLE_UNI
VAR lIsOpen
VAR nItemCount INIT 0
VAR nLeft
VAR cMessage INIT ""
VAR nRight
VAR bSBlock
VAR cStyle INIT Chr( 31 ) /* LOW-ASCII "▼" */
VAR cTextValue INIT ""
VAR nTop
VAR nTopItem INIT 0
VAR nValue INIT 0
VAR oVScroll
VAR aItems INIT {}
VAR aSaveScr
VAR nCursor
METHOD changeItem( nOldPos, nNewPos )
METHOD scrollbarPos()
ENDCLASS
METHOD addItem( cText, cData ) CLASS ListBox
METHOD addItem( cText, xData ) CLASS ListBox
IF HB_ISSTRING( cText ) .AND. ValType( cData ) $ "CU"
IF HB_ISSTRING( cText )
AAdd( ::aItems, { cText, cData } )
AAdd( ::aItems, { cText, xData } )
::nItemCount++
@@ -206,7 +207,6 @@ METHOD delItem( nPos ) CLASS ListBox
ELSEIF ::nValue > 0
::xBuffer := ::cTextValue
ENDIF
ENDIF
IF ::nTopItem > ::nItemCount
@@ -254,7 +254,7 @@ METHOD display() CLASS ListBox
IF ::lDropDown
hb_DispOutAt( nTop, nLeft, ;
iif( ::nValue == 0, Space( nSize - 1 ), PadR( ::aItems[ ::nValue ][ _ITEM_cTEXT ], nSize - 1 ) ), ;
iif( ::nValue == 0, Space( nSize - 1 ), PadR( ::aItems[ ::nValue ][ _ITEM_cText ], nSize - 1 ) ), ;
cColorAny )
hb_DispOutAt( nTop++, nLeft + nSize - 1, ::cStyle, hb_ColorIndex( ::cColorSpec, 7 ) )
@@ -277,7 +277,6 @@ METHOD display() CLASS ListBox
nLeft++
nSize -= 2
nEnd -= 2
ENDIF
IF nEnd > ::nItemCount
@@ -285,7 +284,7 @@ METHOD display() CLASS ListBox
ENDIF
FOR nItem := ::nTopItem TO nEnd
hb_DispOutAt( nTop++, nLeft, PadR( ::aItems[ nItem ][ _ITEM_cTEXT ], nSize ), iif( nItem == ::nValue, cColor4, cColor3 ) )
hb_DispOutAt( nTop++, nLeft, PadR( ::aItems[ nItem ][ _ITEM_cText ], nSize ), iif( nItem == ::nValue, cColor4, cColor3 ) )
NEXT
ENDIF
@@ -303,7 +302,6 @@ METHOD display() CLASS ListBox
IF nPos != 0
hb_DispOutAt( ::nCapRow, ::nCapCol + nPos - 2, SubStr( cCaption, nPos, 1 ), hb_ColorIndex( ::cColorSpec, 6 ) )
ENDIF
ENDIF
DispEnd()
@@ -313,12 +311,14 @@ METHOD display() CLASS ListBox
METHOD findText( cText, nPos, lCaseSensitive, lExact ) CLASS ListBox
LOCAL nPosFound
LOCAL nLen
LOCAL bSearch
IF ! HB_ISSTRING( cText ) .OR. Len( cText ) == 0
#ifndef HB_CLP_STRICT
/* NOTE: Cl*pper will RTE if passed a non-string cText */
IF ! HB_ISSTRING( cText )
RETURN 0
ENDIF
#endif
hb_default( @nPos, 1 )
hb_default( @lCaseSensitive, .T. )
@@ -327,40 +327,35 @@ METHOD findText( cText, nPos, lCaseSensitive, lExact ) CLASS ListBox
ENDIF
IF lExact
cText := RTrim( cText )
IF lCaseSensitive
bSearch := {| aItem | RTrim( aItem[ _ITEM_cTEXT ] ) == cText }
bSearch := {| aItem | aItem[ _ITEM_cText ] == cText }
ELSE
cText := Lower( cText )
bSearch := {| aItem | Lower( RTrim( aItem[ _ITEM_cTEXT ] ) ) == cText }
bSearch := {| aItem | Lower( aItem[ _ITEM_cText ] ) == cText }
ENDIF
ELSE
nLen := Len( cText )
IF lCaseSensitive
bSearch := {| aItem | Left( aItem[ _ITEM_cTEXT ], nLen ) == cText }
bSearch := {| aItem | hb_LeftEq( aItem[ _ITEM_cText ], cText ) }
ELSE
cText := Lower( cText )
bSearch := {| aItem | Lower( Left( aItem[ _ITEM_cTEXT ], nLen ) ) == cText }
bSearch := {| aItem | hb_LeftEqI( aItem[ _ITEM_cText ], cText ) }
ENDIF
ENDIF
nPosFound := AScan( ::aItems, bSearch, nPos, Len( ::aItems ) - nPos + 1 )
IF nPosFound == 0 .AND. nPos > 1
IF ( nPosFound := AScan( ::aItems, bSearch, nPos, Len( ::aItems ) - nPos + 1 ) ) == 0 .AND. nPos > 1
nPosFound := AScan( ::aItems, bSearch, 1, nPos - 1 )
ENDIF
RETURN nPosFound
METHOD findData( cData, nPos, lCaseSensitive, lExact ) CLASS ListBox
/* NOTE: Both Cl*pper and Harbour may RTE when searching for
a different type than present in an item value. The RTE
will be different and in Cl*pper, but will occur under
the same conditions. */
METHOD findData( xData, nPos, lCaseSensitive, lExact ) CLASS ListBox
LOCAL nPosFound
LOCAL nLen
LOCAL bSearch
IF ! HB_ISSTRING( cData )
RETURN 0
ENDIF
hb_default( @nPos, 1 )
hb_default( @lCaseSensitive, .T. )
IF ! HB_ISLOGICAL( lExact )
@@ -368,38 +363,38 @@ METHOD findData( cData, nPos, lCaseSensitive, lExact ) CLASS ListBox
ENDIF
IF lExact
cData := RTrim( cData )
IF lCaseSensitive
bSearch := {| aItem | RTrim( _LISTBOX_ITEMDATA( aItem ) ) == cData }
bSearch := {| aItem | _LISTBOX_ITEMDATA( aItem ) == xData }
ELSE
cData := Lower( cData )
bSearch := {| aItem | Lower( RTrim( _LISTBOX_ITEMDATA( aItem ) ) ) == cData }
/* Cl*pper will also RTE here, if xData is not a string */
xData := Lower( xData )
bSearch := {| aItem | Lower( _LISTBOX_ITEMDATA( aItem ) ) == xData }
ENDIF
ELSE
nLen := Len( cData )
IF lCaseSensitive
bSearch := {| aItem | Left( _LISTBOX_ITEMDATA( aItem ), nLen ) == cData }
bSearch := {| aItem, xItemData | xItemData := _LISTBOX_ITEMDATA( aItem ), ;
iif( HB_ISSTRING( xItemData ), hb_LeftEq( xItemData, xData ), ;
xItemData == xData ) }
ELSE
cData := Lower( cData )
bSearch := {| aItem | Lower( Left( _LISTBOX_ITEMDATA( aItem ), nLen ) ) == cData }
/* Cl*pper will also RTE here, if xData is not a string */
bSearch := {| aItem | hb_LeftEqI( _LISTBOX_ITEMDATA( aItem ), xData ) }
ENDIF
ENDIF
nPosFound := AScan( ::aItems, bSearch, nPos, Len( ::aItems ) - nPos + 1 )
IF nPosFound == 0 .AND. nPos > 1
IF ( nPosFound := AScan( ::aItems, bSearch, nPos, Len( ::aItems ) - nPos + 1 ) ) == 0 .AND. nPos > 1
nPosFound := AScan( ::aItems, bSearch, 1, nPos - 1 )
ENDIF
RETURN nPosFound
METHOD getData( nPos ) CLASS ListBox
RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ][ _ITEM_cDATA ], NIL )
RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ][ _ITEM_xData ], NIL )
METHOD getItem( nPos ) CLASS ListBox
RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ], NIL )
METHOD getText( nPos ) CLASS ListBox
RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ][ _ITEM_cTEXT ], NIL )
RETURN iif( nPos >= 1 .AND. nPos <= ::nItemCount, ::aItems[ nPos ][ _ITEM_cText ], NIL )
METHOD hitTest( nMRow, nMCol ) CLASS ListBox
@@ -485,13 +480,13 @@ METHOD hitTest( nMRow, nMCol ) CLASS ListBox
RETURN 0
METHOD insItem( nPos, cText, cData ) CLASS ListBox
METHOD insItem( nPos, cText, xData ) CLASS ListBox
IF HB_ISSTRING( cText ) .AND. ;
HB_ISNUMERIC( nPos ) .AND. ;
nPos < ::nItemCount
hb_AIns( ::aItems, nPos, { cText, cData }, .T. )
hb_AIns( ::aItems, nPos, { cText, xData }, .T. )
::nItemCount++
IF ::nItemCount == 1
@@ -589,91 +584,94 @@ METHOD scroll( nMethod ) CLASS ListBox
LOCAL nKey
LOCAL nCount
SWITCH nMethod
CASE HTSCROLLTHUMBDRAG
IF HB_ISNUMERIC( nMethod )
nPrevMRow := MRow()
SWITCH nMethod
CASE HTSCROLLTHUMBDRAG
DO WHILE ( ( nKey := Inkey( 0 ) ) != K_LBUTTONUP )
nPrevMRow := MRow()
IF nKey == K_MOUSEMOVE
DO WHILE ( ( nKey := Inkey( 0 ) ) != K_LBUTTONUP )
nMRow := MRow()
IF nKey == K_MOUSEMOVE
IF nMRow <= ::oVScroll:start()
nMRow := ::oVScroll:start() + 1
ENDIF
IF nMRow >= ::oVScroll:end()
nMRow := ::oVScroll:end() - 1
ENDIF
nMRow := MRow()
IF nMRow != nPrevMRow
nThumbPos := ::oVScroll:thumbPos() + ( nMRow - nPrevMRow )
nBarLength := ::oVScroll:barLength()
nTotal := ::oVScroll:total()
nSize := Min( Max( ( nThumbPos * ( nTotal - nBarLength - 2 ) + 2 * nBarLength + 1 - nTotal ) / ( nBarLength - 1 ), 1 ), nTotal )
nCurrent := ::oVScroll:current()
IF nSize - nCurrent > 0
FOR nCount := 1 TO nSize - nCurrent
::scroll( HTSCROLLUNITINC )
NEXT
ELSE
FOR nCount := 1 TO nCurrent - nSize
::scroll( HTSCROLLUNITDEC )
NEXT
IF nMRow <= ::oVScroll:start()
nMRow := ::oVScroll:start() + 1
ENDIF
IF nMRow >= ::oVScroll:end()
nMRow := ::oVScroll:end() - 1
ENDIF
nPrevMRow := nMRow
IF nMRow != nPrevMRow
nThumbPos := ::oVScroll:thumbPos() + ( nMRow - nPrevMRow )
nBarLength := ::oVScroll:barLength()
nTotal := ::oVScroll:total()
nSize := Min( Max( ( nThumbPos * ( nTotal - nBarLength - 2 ) + 2 * nBarLength + 1 - nTotal ) / ( nBarLength - 1 ), 1 ), nTotal )
nCurrent := ::oVScroll:current()
IF nSize - nCurrent > 0
FOR nCount := 1 TO nSize - nCurrent
::scroll( HTSCROLLUNITINC )
NEXT
ELSE
FOR nCount := 1 TO nCurrent - nSize
::scroll( HTSCROLLUNITDEC )
NEXT
ENDIF
nPrevMRow := nMRow
ENDIF
ENDIF
ENDDO
EXIT
CASE HTSCROLLUNITDEC
IF ::nTopItem > 1
::nTopItem--
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
ENDDO
EXIT
EXIT
CASE HTSCROLLUNITDEC
CASE HTSCROLLUNITINC
IF ::nTopItem > 1
::nTopItem--
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
EXIT
CASE HTSCROLLUNITINC
IF ( ::nTopItem + ::nBottom - ::nTop ) <= ::nItemCount + 1
::nTopItem++
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
EXIT
CASE HTSCROLLBLOCKDEC
nPos := ::nBottom - ::nTop - iif( ::lDropDown, 2, 1 )
nTopItem := ::nTopItem - nPos
IF ::nTopItem > 1
::nTopItem := Max( nTopItem, 1 )
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
EXIT
CASE HTSCROLLBLOCKINC
nPos := ::nBottom - ::nTop - 1
nItemCount := ::nItemCount
nTopItem := ::nTopItem + nPos
IF ::nTopItem < nItemCount - nPos + 1
IF nTopItem + nPos - 1 > nItemCount
nTopItem := nItemCount - nPos + 1
IF ( ::nTopItem + ::nBottom - ::nTop ) <= ::nItemCount + 1
::nTopItem++
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
::nTopItem := nTopItem
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
EXIT
EXIT
ENDSWITCH
CASE HTSCROLLBLOCKDEC
nPos := ::nBottom - ::nTop - iif( ::lDropDown, 2, 1 )
nTopItem := ::nTopItem - nPos
IF ::nTopItem > 1
::nTopItem := Max( nTopItem, 1 )
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
EXIT
CASE HTSCROLLBLOCKINC
nPos := ::nBottom - ::nTop - 1
nItemCount := ::nItemCount
nTopItem := ::nTopItem + nPos
IF ::nTopItem < nItemCount - nPos + 1
IF nTopItem + nPos - 1 > nItemCount
nTopItem := nItemCount - nPos + 1
ENDIF
::nTopItem := nTopItem
::oVScroll:current := ::scrollbarPos()
::display()
ENDIF
EXIT
ENDSWITCH
ENDIF
RETURN Self
@@ -715,9 +713,7 @@ METHOD select( xPos ) CLASS ListBox
::cTextValue := iif( nPos == 0, "", _LISTBOX_ITEMDATA( ::aItems[ nPos ] ) )
nPos := iif( Empty( ::cHotBox + ::cColdBox ), 0, 2 )
nValue := ::nValue - ( ::nBottom - ::nTop - nPos )
nValue := ::nValue - ( ::nBottom - ::nTop - iif( Empty( ::cHotBox + ::cColdBox ), 0, 2 ) )
IF ::nTopItem <= nValue
::nTopItem := nValue
IF ::oVScroll != NIL
@@ -738,10 +734,11 @@ METHOD select( xPos ) CLASS ListBox
RETURN ::nValue
METHOD setData( nPos, cData ) CLASS ListBox
/* NOTE: This function does nothing in Cl*pper, due to a bug. */
METHOD setData( nPos, xData ) CLASS ListBox
IF nPos >= 1 .AND. nPos <= ::nItemCount
::aItems[ nPos ][ _ITEM_cDATA ] := cData
::aItems[ nPos ][ _ITEM_xData ] := xData
ENDIF
RETURN Self
@@ -758,7 +755,6 @@ METHOD setFocus() CLASS ListBox
IF HB_ISEVALITEM( ::bFBlock )
Eval( ::bFBlock )
ENDIF
ENDIF
RETURN Self
@@ -767,7 +763,7 @@ METHOD setItem( nPos, aItem ) CLASS ListBox
IF nPos >= 1 .AND. nPos <= ::nItemCount .AND. ;
Len( aItem ) == 2 .AND. ;
HB_ISSTRING( aItem[ _ITEM_cTEXT ] )
HB_ISSTRING( aItem[ _ITEM_cText ] )
::aItems[ nPos ] := aItem
ENDIF
@@ -777,7 +773,7 @@ METHOD setItem( nPos, aItem ) CLASS ListBox
METHOD setText( nPos, cText ) CLASS ListBox
IF nPos >= 1 .AND. nPos <= ::nItemCount
::aItems[ nPos ][ _ITEM_cTEXT ] := cText
::aItems[ nPos ][ _ITEM_cText ] := cText
ENDIF
RETURN Self
@@ -1088,13 +1084,10 @@ FUNCTION ListBox( nTop, nLeft, nBottom, nRight, lDropDown )
FUNCTION _LISTBOX_( nTop, nLeft, nBottom, nRight, xPos, aItems, cCaption, ;
cMessage, cColorSpec, bFBlock, bSBlock, lDropDown, lScrollBar, cBitmap )
LOCAL o := HBListBox():New( nTop, nLeft, nBottom, nRight, lDropDown )
LOCAL nPos
LOCAL nLen
LOCAL o
LOCAL xItem
IF o != NIL
IF ( o := HBListBox():New( nTop, nLeft, nBottom, nRight, lDropDown ) ) != NIL
IF HB_ISSTRING( cCaption )
o:caption := cCaption
@@ -1106,22 +1099,18 @@ FUNCTION _LISTBOX_( nTop, nLeft, nBottom, nRight, xPos, aItems, cCaption, ;
o:fBlock := bFBlock
o:sBlock := bSBlock
nLen := Len( aItems )
FOR nPos := 1 TO nLen
xItem := aItems[ nPos ]
FOR EACH xItem IN aItems
IF ! HB_ISARRAY( xItem )
o:addItem( xItem )
ELSEIF Len( xItem ) == _ITEM_cTEXT
o:addItem( xItem[ _ITEM_cTEXT ] )
ELSEIF Len( xItem ) == _ITEM_cText
o:addItem( xItem[ _ITEM_cText ] )
ELSE
o:addItem( xItem[ _ITEM_cTEXT ], xItem[ _ITEM_cDATA ] )
o:addItem( xItem[ _ITEM_cText ], xItem[ _ITEM_xData ] )
ENDIF
NEXT
IF HB_ISLOGICAL( lScrollBar ) .AND. lScrollBar
IF HB_ISLOGICAL( lDropDown ) .AND. lDropDown
IF hb_defaultValue( lScrollBar, .F. )
IF hb_defaultValue( lDropDown, .F. )
nTop++
ENDIF
o:VScroll := ScrollBar( nTop + 1, nBottom - 1, nRight )

220
src/rtl/memoedit.prg
View File

@@ -65,31 +65,41 @@ CREATE CLASS HBMemoEditor INHERIT HBEditor
METHOD KeyboardHook( nKey ) // Gets called every time there is a key not handled directly by HBEditor
METHOD IdleHook() // Gets called every time there are no more keys to hanlde
METHOD HandleUserKey( nKey, nUserKey ) // Handles keys returned to MemoEdit() by user function
METHOD HandleUserKey( nKey, nUdfReturn ) // Handles keys returned to MemoEdit() by user function
METHOD xDo( nStatus ) // Calls xUserFunction saving and restoring cursor position and shape
METHOD MoveCursor( nKey ) // Redefined to properly managed CTRL-W
PROTECTED:
METHOD UserFunctionIsValid()
ENDCLASS
METHOD UserFunctionIsValid() CLASS HBMemoEditor
#ifdef HB_CLP_STRICT
RETURN HB_ISSTRING( ::xUserFunction )
#else
RETURN HB_ISSTRING( ::xUserFunction ) .OR. HB_ISEVALITEM( ::xUserFunction )
#endif
METHOD MemoInit( xUserFunction ) CLASS HBMemoEditor
LOCAL nKey
LOCAL nUdfReturn
// Save/Init object internal representation of user function
::xUserFunction := xUserFunction
IF HB_ISSTRING( ::xUserFunction )
IF ::UserFunctionIsValid()
// Keep calling user function until it returns ME_DEFAULT
DO WHILE ( nKey := ::xDo( ME_INIT ) ) != ME_DEFAULT
DO WHILE ( nUdfReturn := ::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 )
// of values returned by ::xUserFunction, so I pass NIL as the key code.
IF ! ::HandleUserKey( , nUdfReturn )
EXIT
ENDIF
ENDDO
ENDIF
RETURN Self
@@ -98,14 +108,14 @@ METHOD Edit() CLASS HBMemoEditor
LOCAL nKey
// NOTE: K_ALT_W is not compatible with clipper exit memo and save key, but I cannot discriminate
// K_CTRL_W and K_CTRL_END from harbour code.
// NOTE: K_ALT_W is not compatible with Cl*pper exit memo and save key, but I cannot discriminate
// K_CTRL_W and K_CTRL_END from Harbour code.
LOCAL aConfigurableKeys := { K_CTRL_Y, K_CTRL_T, K_CTRL_B, K_CTRL_V, K_ALT_W, K_ESC }
LOCAL bKeyBlock
// 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. HB_ISSTRING( ::xUserFunction )
IF ::lEditAllow .AND. ::UserFunctionIsValid()
DO WHILE ! ::lExitEdit
@@ -121,9 +131,11 @@ METHOD Edit() CLASS HBMemoEditor
LOOP
ENDIF
// Is it a configurable key ?
// Is it a configurable key?
IF AScan( aConfigurableKeys, nKey ) > 0
::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) )
IF ::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) )
ENDIF
ELSE
::super:Edit( nKey )
ENDIF
@@ -145,36 +157,35 @@ METHOD KeyboardHook( nKey ) CLASS HBMemoEditor
LOCAL nRow
LOCAL nCol
IF HB_ISSTRING( ::xUserFunction )
IF ! ::lCallKeyboardHook // To avoid recursive calls in endless loop. [jarabal]
::lCallKeyboardHook := .T.
::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) )
::lCallKeyboardHook := .F.
ENDIF
ELSE
IF nKey == K_ESC
IF ::lDirty .AND. Set( _SET_SCOREBOARD )
cBackScr := SaveScreen( 0, MaxCol() - 18, 0, MaxCol() )
IF ::UserFunctionIsValid() .AND. ! ::lCallKeyboardHook // To avoid recursive calls in endless loop. [jarabal]
nRow := Row()
nCol := Col()
hb_DispOutAt( 0, MaxCol() - 18, "Abort Edit? (Y/N)" )
SetPos( 0, MaxCol() - 1 )
::lCallKeyboardHook := .T.
::HandleUserKey( nKey, ::xDo( iif( ::lDirty, ME_UNKEYX, ME_UNKEY ) ) )
::lCallKeyboardHook := .F.
nYesNoKey := Inkey( 0 )
ELSEIF nKey == K_ESC
RestScreen( 0, MaxCol() - 18, 0, MaxCol(), cBackScr )
SetPos( nRow, nCol )
IF ::lDirty .AND. Set( _SET_SCOREBOARD )
cBackScr := SaveScreen( 0, MaxCol() - 18, 0, MaxCol() )
IF nYesNoKey == Asc( "Y" ) .OR. nYesNoKey == Asc( "y" )
hb_keySetLast( K_ESC ) /* Cl*pper compatibility */
::lSaved := .F.
::lExitEdit := .T.
ENDIF
ELSE
nRow := Row()
nCol := Col()
hb_DispOutAt( 0, MaxCol() - 18, "Abort Edit? (Y/N)" )
SetPos( 0, MaxCol() - 1 )
nYesNoKey := Inkey( 0 )
RestScreen( 0, MaxCol() - 18, 0, MaxCol(), cBackScr )
SetPos( nRow, nCol )
IF Upper( hb_keyChar( nYesNoKey ) ) == "Y"
hb_keySetLast( K_ESC ) /* Cl*pper compatibility */
::lSaved := .F.
::lExitEdit := .T.
ENDIF
ELSE
::lSaved := .F.
::lExitEdit := .T.
ENDIF
ENDIF
@@ -182,59 +193,71 @@ METHOD KeyboardHook( nKey ) CLASS HBMemoEditor
METHOD IdleHook() CLASS HBMemoEditor
IF HB_ISSTRING( ::xUserFunction )
IF ::UserFunctionIsValid()
::xDo( ME_IDLE )
ENDIF
RETURN Self
METHOD HandleUserKey( nKey, nUserKey ) CLASS HBMemoEditor
METHOD HandleUserKey( nKey, nUdfReturn ) CLASS HBMemoEditor
DO CASE
// I won't reach this point during ME_INIT since ME_DEFAULT ends initialization phase of MemoEdit()
CASE nUserKey == ME_DEFAULT
CASE nUdfReturn == 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
DO CASE
CASE nKey == K_ESC
::lSaved := .F.
::lExitEdit := .T.
CASE nKey <= 256 .OR. nKey == K_ALT_W
::super:Edit( nKey )
ENDCASE
// I won't reach this point during ME_INIT since ME_DEFAULT ends initialization phase of MemoEdit()
// TOFIX: Not CA-Cl*pper compatible, see teditor.prg
CASE ( nUserKey >= 1 .AND. nUserKey <= 31 ) .OR. nUserKey == K_ALT_W
::super:Edit( nUserKey )
CASE nUserKey == ME_DATA
IF nKey <= 256
::super:Edit( nKey )
IF HB_ISNUMERIC( nKey )
// 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
DO CASE
CASE nKey == K_ESC
::lSaved := .F.
::lExitEdit := .T.
CASE nKey <= 256 .OR. nKey == K_ALT_W
::super:Edit( nKey )
ENDCASE
ELSE
RETURN .F.
ENDIF
CASE nUserKey == ME_TOGGLEWRAP
CASE nUdfReturn == ME_DATA
IF HB_ISNUMERIC( nKey )
IF nKey <= 256
::super:Edit( nKey )
ENDIF
ELSE
RETURN .F.
ENDIF
CASE nUdfReturn == ME_TOGGLEWRAP
::lWordWrap := ! ::lWordWrap
CASE nUserKey == ME_TOGGLESCROLL
CASE nUdfReturn == ME_TOGGLESCROLL
// TODO: HBEditor does not support vertical scrolling of text inside window without moving cursor position
CASE nUserKey == ME_WORDRIGHT
CASE nUdfReturn == ME_WORDRIGHT
::MoveCursor( K_CTRL_RIGHT )
CASE nUserKey == ME_BOTTOMRIGHT
CASE nUdfReturn == ME_BOTTOMRIGHT
::MoveCursor( K_CTRL_END )
#ifndef HB_CLP_STRICT
CASE nUserKey == ME_PASTE /* Xbase++ compatibility */
CASE nUdfReturn == ME_PASTE /* Xbase++ compatibility */
hb_gtInfo( HB_GTI_CLIPBOARDPASTE )
#endif
OTHERWISE
// Do nothing
CASE nUdfReturn != ME_IGNORE
// TOFIX: Not CA-Cl*pper compatible, see teditor.prg
IF HB_ISNUMERIC( nKey ) .AND. ( ( nKey >= 1 .AND. nKey <= 31 ) .OR. nKey == K_ALT_W )
::super:Edit( nKey )
ELSE
RETURN .F.
ENDIF
ENDCASE
RETURN Self
RETURN .T.
METHOD xDo( nStatus ) CLASS HBMemoEditor
@@ -244,12 +267,10 @@ METHOD xDo( nStatus ) CLASS HBMemoEditor
LOCAL xResult := Do( ::xUserFunction, nStatus, ::nRow, ::nCol - 1 )
hb_default( @xResult, ME_DEFAULT )
::SetPos( nOldRow, nOldCol )
SetCursor( nOldCur )
RETURN xResult
RETURN hb_defaultValue( xResult, ME_DEFAULT )
METHOD MoveCursor( nKey ) CLASS HBMemoEditor
@@ -259,7 +280,7 @@ METHOD MoveCursor( nKey ) CLASS HBMemoEditor
::lSaved := .T.
::lExitEdit := .T.
ELSE
RETURN ::Super:MoveCursor( nKey )
RETURN ::super:MoveCursor( nKey )
ENDIF
RETURN .F.
@@ -267,43 +288,50 @@ METHOD MoveCursor( nKey ) CLASS HBMemoEditor
/* ------------------------------------------ */
FUNCTION MemoEdit( ;
cString,;
nTop,;
nLeft,;
nBottom,;
nRight,;
lEditMode,;
xUserFunction,;
nLineLength,;
nTabSize,;
nTextBuffRow,;
nTextBuffColumn,;
nWindowRow,;
cString, ;
nTop, ;
nLeft, ;
nBottom, ;
nRight, ;
lEditMode, ;
xUserFunction, ;
nLineLength, ;
nTabSize, ;
nTextBuffRow, ;
nTextBuffColumn, ;
nWindowRow, ;
nWindowColumn )
LOCAL oEd
LOCAL nOldCursor
hb_default( @nTop , 0 )
hb_default( @nLeft , 0 )
hb_default( @nBottom , MaxRow() )
hb_default( @nRight , MaxCol() )
hb_default( @lEditMode , .T. )
hb_default( @nLeft , 0 )
hb_default( @nRight , MaxCol() )
hb_default( @nLineLength , nRight - nLeft + 1 )
hb_default( @nTabSize , 4 )
hb_default( @nTextBuffRow , 1 )
hb_default( @nTextBuffColumn , 0 )
hb_default( @nWindowRow , 0 )
hb_default( @nWindowColumn , nTextBuffColumn )
hb_default( @cString , "" )
hb_default( @nTextBuffColumn , 0 )
hb_default( @nWindowColumn , nTextBuffColumn )
hb_default( @cString , "" )
// Original MemoEdit() converts Tabs into spaces;
oEd := HBMemoEditor():New( StrTran( cString, Chr( 9 ), Space( 1 ) ), nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabSize, nTextBuffRow, nTextBuffColumn, nWindowRow, nWindowColumn )
/* Original MemoEdit() converts tabs into spaces */
oEd := HBMemoEditor():New( StrTran( cString, Chr( 9 ), Space( 1 ) ), ;
hb_defaultValue( nTop, 0 ), ;
nLeft, ;
hb_defaultValue( nBottom, MaxRow() ), ;
nRight, ;
hb_defaultValue( lEditMode, .T. ), ;
nLineLength, ;
hb_defaultValue( nTabSize, 4 ), ;
hb_defaultValue( nTextBuffRow, 1 ), ;
nTextBuffColumn, ;
hb_defaultValue( nWindowRow, 0 ), ;
nWindowColumn )
oEd:MemoInit( xUserFunction )
oEd:display()
IF ! HB_ISLOGICAL( xUserFunction ) .OR. xUserFunction
/* Contrary to what the NG says, any logical value will make it pass
through without any editing. */
IF ! HB_ISLOGICAL( xUserFunction )
nOldCursor := SetCursor( iif( Set( _SET_INSERT ), SC_INSERT, SC_NORMAL ) )
oEd:Edit()
IF oEd:Changed() .AND. oEd:Saved()

157
src/rtl/teditor.prg
View File

@@ -57,6 +57,9 @@
#include "inkey.ch"
#include "setcurs.ch"
/* TOFIX: Leave this here, until this code is cleaned off of RTEs */
#pragma linenumber=on
CREATE CLASS HBEditor
EXPORTED:
@@ -206,7 +209,7 @@ METHOD LoadFile( cFileName ) CLASS HBEditor
cString := ""
ENDIF
::aText := Text2Array( cString, iif( ::lWordWrap, ::nNumCols, NIL ) )
::aText := Text2Array( cString, iif( ::lWordWrap, ::nNumCols, ) )
::naTextLen := Len( ::aText )
IF ::naTextLen == 0
@@ -221,7 +224,7 @@ METHOD LoadFile( cFileName ) CLASS HBEditor
METHOD LoadText( cString ) CLASS HBEditor
::aText := Text2Array( cString, iif( ::lWordWrap, ::nNumCols, NIL ) )
::aText := Text2Array( cString, iif( ::lWordWrap, ::nNumCols, ) )
::naTextLen := Len( ::aText )
IF ::naTextLen == 0
@@ -237,14 +240,11 @@ METHOD LoadText( cString ) CLASS HBEditor
// Saves file being edited, if there is no file name does nothing, returns .T. if OK
METHOD SaveFile() CLASS HBEditor
IF ! Empty( ::cFile )
::lDirty := ! hb_MemoWrit( ::cFile, ::GetText() )
RETURN ! ::lDirty
IF Empty( ::cFile )
RETURN .F.
ENDIF
RETURN .F.
RETURN ! ::lDirty := ! hb_MemoWrit( ::cFile, ::GetText() )
// Add a new Line of text at end of current text
METHOD AddLine( cLine, lSoftCR ) CLASS HBEditor
@@ -257,17 +257,16 @@ METHOD AddLine( cLine, lSoftCR ) CLASS HBEditor
// Insert a line of text at a defined row
METHOD InsertLine( cLine, lSoftCR, nRow ) CLASS HBEditor
::AddLine()
AIns( ::aText, nRow )
::aText[ nRow ] := HBTextLine():New( cLine, lSoftCR )
hb_AIns( ::aText, nRow, HBTextLine():New( cLine, lSoftCR ), .T. )
::naTextLen++
RETURN Self
// Remove a line of text
METHOD RemoveLine( nRow ) CLASS HBEditor
ADel( ::aText, nRow )
ASize( ::aText, --::naTextLen )
hb_ADel( ::aText, nRow, .T. )
::naTextLen--
RETURN Self
@@ -277,7 +276,9 @@ METHOD GetLine( nRow ) CLASS HBEditor
// Return text length of line n
METHOD LineLen( nRow ) CLASS HBEditor
RETURN Len( ::aText[ nRow ]:cText )
/* TOFIX: bounds checking as a workaround for RTE in:
HBEDITOR:LINELEN < HBEDITOR:MOVECURSOR < HBEDITOR:SPLITLINE < HBEDITOR:EDIT */
RETURN iif( nRow >= 1 .AND. nRow <= Len( ::aText ), Len( ::aText[ nRow ]:cText ), 0 )
// Converts an array of text lines to a String
METHOD GetText() CLASS HBEditor
@@ -300,14 +301,14 @@ METHOD GotoLine( nRow ) CLASS HBEditor
IF nRow <= ::naTextLen .AND. nRow > 0
// Back one line
IF ::nRow - nRow == 1
::MoveCursor( K_UP )
ELSEIF ::nRow - nRow == -1
SWITCH ::nRow - nRow
CASE 1
::MoveCursor( K_UP ) // Back one line
EXIT
CASE -1
::MoveCursor( K_DOWN )
ELSE
EXIT
OTHERWISE
// I need to move cursor if is past requested line number and if requested line is
// inside first screen of text otherwise ::nFirstRow would be wrong
IF ::nFirstRow > 1
@@ -322,12 +323,12 @@ METHOD GotoLine( nRow ) CLASS HBEditor
::nRow := nRow
IF ! ( ::nFirstRow == 1 .AND. nRow <= ::nNumRows )
IF !( ::nFirstRow == 1 .AND. nRow <= ::nNumRows )
::nFirstRow := Max( 1, nRow - ( ::Row() - ::nTop ) )
ENDIF
::display()
ENDIF
ENDSWITCH
ENDIF
RETURN Self
@@ -341,7 +342,7 @@ METHOD SplitLine( nRow ) CLASS HBEditor
LOCAL nFirstSpace
LOCAL cLine
LOCAL cSplittedLine
LOCAL cSplitLine
LOCAL nStartRow
LOCAL nOCol
LOCAL nORow
@@ -374,21 +375,21 @@ METHOD SplitLine( nRow ) CLASS HBEditor
// If there is a space before beginning of line split there
IF nFirstSpace > 1
cSplittedLine := Left( cLine, nFirstSpace )
cSplitLine := Left( cLine, nFirstSpace )
ELSE
// else split at current cursor position
cSplittedLine := Left( cLine, ::nCol - 1 )
cSplitLine := Left( cLine, ::nCol - 1 )
ENDIF
::InsertLine( cSplittedLine, .T., nStartRow++ )
::InsertLine( cSplitLine, .T., nStartRow++ )
ELSE
// remainder of line
cSplittedLine := cLine
::InsertLine( cSplittedLine, .F., nStartRow++ )
cSplitLine := cLine
::InsertLine( cSplitLine, .F., nStartRow++ )
ENDIF
cLine := Right( cLine, Len( cLine ) - Len( cSplittedLine ) )
cLine := Right( cLine, Len( cLine ) - Len( cSplitLine ) )
ENDDO
IF lMoveToNextLine
@@ -469,8 +470,6 @@ METHOD LineColor( nRow ) CLASS HBEditor
// Handles cursor movements inside text array
METHOD MoveCursor( nKey ) CLASS HBEditor
LOCAL lMoveKey := .T.
SWITCH nKey
CASE K_DOWN
IF ! ::lEditAllow
@@ -647,11 +646,10 @@ METHOD MoveCursor( nKey ) CLASS HBEditor
EXIT
OTHERWISE
lMoveKey := .F.
RETURN .F.
ENDSWITCH
RETURN lMoveKey
RETURN .T.
// Changes insert state and insertion / overstrike mode of editor
METHOD InsertState( lInsState ) CLASS HBEditor
@@ -675,9 +673,7 @@ METHOD Edit( nPassedKey ) CLASS HBEditor
LOCAL bKeyBlock
LOCAL lSingleKeyProcess := .F. // .T. if I have to process passed key and then exit
IF ! ::lEditAllow
::BrowseText( nPassedKey )
ELSE
IF ::lEditAllow
// If user pressed an exiting key (K_ESC or K_ALT_W) or I've received a key to handle and then exit
DO WHILE ! ::lExitEdit .AND. ! lSingleKeyProcess
@@ -709,7 +705,7 @@ METHOD Edit( nPassedKey ) CLASS HBEditor
::aText[ ::nRow ]:cText += Space( ::nCol - ::LineLen( ::nRow ) )
ENDIF
// insert char if in insert mode or at end of current line
IF Set( _SET_INSERT ) .OR. ( ::nCol > ::LineLen( ::nRow ) )
IF Set( _SET_INSERT ) .OR. ::nCol > ::LineLen( ::nRow )
::aText[ ::nRow ]:cText := Stuff( ::aText[ ::nRow ]:cText, ::nCol, 0, cKey )
ELSE
::aText[ ::nRow ]:cText := Stuff( ::aText[ ::nRow ]:cText, ::nCol, 1, cKey )
@@ -766,7 +762,7 @@ METHOD Edit( nPassedKey ) CLASS HBEditor
CASE nKey == K_TAB
// insert char if in insert mode or at end of current line
IF Set( _SET_INSERT ) .OR. ( ::nCol == ::LineLen( ::nRow ) )
IF Set( _SET_INSERT ) .OR. ::nCol == ::LineLen( ::nRow )
::aText[ ::nRow ]:cText := Stuff( ::aText[ ::nRow ]:cText, ::nCol, 0, Space( ::nTabWidth ) )
::lDirty := .T.
ENDIF
@@ -827,6 +823,8 @@ METHOD Edit( nPassedKey ) CLASS HBEditor
::KeyboardHook( nKey )
ENDCASE
ENDDO
ELSE
::BrowseText( nPassedKey )
ENDIF
RETURN Self
@@ -937,7 +935,7 @@ METHOD hitTest( nMRow, nMCol ) CLASS HBEditor
/* -------------------------------------------- */
// Rebuild a long line from multiple short ones (wrapped at soft CR)
METHOD GetParagraph( nRow )
METHOD GetParagraph( nRow ) CLASS HBEditor
LOCAL cLine := ""
@@ -958,7 +956,7 @@ METHOD GetParagraph( nRow )
// if editing isn't allowed we enter this loop which
// handles only movement keys and discards all the others
METHOD BrowseText( nPassedKey )
METHOD BrowseText( nPassedKey ) CLASS HBEditor
LOCAL nKey
LOCAL bKeyBlock
@@ -982,16 +980,13 @@ METHOD BrowseText( nPassedKey )
IF nKey == K_ESC
::lExitEdit := .T.
ELSE
IF ! ::MoveCursor( nKey )
::KeyboardHook( nKey )
ENDIF
ELSEIF ! ::MoveCursor( nKey )
::KeyboardHook( nKey )
ENDIF
IF nPassedKey != NIL
EXIT
ENDIF
ENDDO
RETURN Self
@@ -1000,25 +995,15 @@ METHOD BrowseText( nPassedKey )
METHOD New( cString, nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabSize, nTextRow, nTextCol, nWndRow, nWndCol ) CLASS HBEditor
hb_default( @cString , "" )
hb_default( @nTop , 0 )
hb_default( @nLeft , 0 )
hb_default( @nBottom , MaxRow() )
hb_default( @nRight , MaxCol() )
hb_default( @lEditMode , .T. )
hb_default( @nTextRow , 1 )
hb_default( @nTextCol , 0 )
hb_default( @nWndRow , 0 )
hb_default( @nWndCol , 0 )
IF ! HB_ISNUMERIC( nLineLength )
// is word wrap required?
IF HB_ISNUMERIC( nLineLength )
::lWordWrap := .T.
::nWordWrapCol := nLineLength
ELSE
nLineLength := NIL
ENDIF
IF ! HB_ISNUMERIC( nTabSize )
nTabSize := NIL
ENDIF
::aText := Text2Array( cString, nLineLength )
::aText := Text2Array( hb_defaultValue( cString, "" ), nLineLength )
::naTextLen := Len( ::aText )
IF ::naTextLen == 0
@@ -1027,10 +1012,10 @@ METHOD New( cString, nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabS
ENDIF
// editor window boundaries
::nTop := nTop
::nLeft := nLeft
::nBottom := nBottom
::nRight := nRight
::nTop := nTop := hb_defaultValue( nTop, 0 )
::nLeft := nLeft := hb_defaultValue( nLeft, 0 )
::nBottom := nBottom := hb_defaultValue( nBottom, MaxRow() )
::nRight := nRight := hb_defaultValue( nRight, MaxCol() )
::cColorSpec := SetColor()
@@ -1038,15 +1023,7 @@ METHOD New( cString, nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabS
::nNumCols := nRight - nLeft + 1
::nNumRows := nBottom - nTop + 1
IF HB_ISLOGICAL( lEditMode )
::lEditAllow := lEditMode
ENDIF
// is word wrap required?
IF HB_ISNUMERIC( nLineLength )
::lWordWrap := .T.
::nWordWrapCol := nLineLength
ENDIF
::lEditAllow := hb_defaultValue( lEditMode, .T. )
// how many spaces for each tab?
IF HB_ISNUMERIC( nTabSize )
@@ -1054,10 +1031,10 @@ METHOD New( cString, nTop, nLeft, nBottom, nRight, lEditMode, nLineLength, nTabS
ENDIF
// textrow/col, wndrow/col management
nTextRow := Max( 1, nTextRow )
nTextCol := Max( 0, nTextCol )
nWndRow := Max( 0, nWndRow )
nWndCol := Max( 0, nWndCol )
nTextRow := Max( 1, hb_defaultValue( nTextRow, 1 ) )
nTextCol := Max( 0, hb_defaultValue( nTextCol, 0 ) )
nWndRow := Max( 0, hb_defaultValue( nWndRow, 0 ) )
nWndCol := Max( 0, hb_defaultValue( nWndCol, 0 ) )
::nFirstRow := Max( 1, nTextRow - nWndRow )
::nFirstCol := nTextCol - nWndCol + 1
@@ -1117,7 +1094,7 @@ STATIC FUNCTION Text2Array( cString, nWordWrapCol )
LOCAL cLine
LOCAL nFirstSpace
LOCAL cSplittedLine
LOCAL cSplitLine
DO WHILE nRetLen < ncSLen
@@ -1137,29 +1114,23 @@ STATIC FUNCTION Text2Array( cString, nWordWrapCol )
ENDDO
IF nFirstSpace > 1
cSplittedLine := Left( cLine, nFirstSpace )
cSplitLine := Left( cLine, nFirstSpace )
ELSE
cSplittedLine := Left( cLine, nWordWrapCol )
cSplitLine := Left( cLine, nWordWrapCol )
ENDIF
AAdd( aArray, HBTextLine():New( cSplittedLine, .T. ) )
AAdd( aArray, HBTextLine():New( cSplitLine, .T. ) )
ELSE
// remainder of line is shorter than split point
cSplittedLine := cLine
AAdd( aArray, HBTextLine():New( cSplittedLine, .F. ) )
cSplitLine := cLine
AAdd( aArray, HBTextLine():New( cSplitLine, .F. ) )
ENDIF
cLine := Right( cLine, Len( cLine ) - Len( cSplittedLine ) )
cLine := Right( cLine, Len( cLine ) - Len( cSplitLine ) )
ENDDO
ELSE
AAdd( aArray, HBTextLine():New( cLine, .F. ) )
ENDIF
ENDDO
RETURN aArray

28
src/rtl/tget.prg
View File

@@ -985,11 +985,9 @@ METHOD setPos( nPos ) CLASS Get
::typeOut := .T.
ENDCASE
ENDIF
RETURN nPos
ENDIF
RETURN 0
@@ -1025,9 +1023,7 @@ METHOD picture( cPicture ) CLASS Get
IF hb_LeftEq( cPicture, "@" )
nAt := At( " ", cPicture )
IF nAt == 0
IF ( nAt := At( " ", cPicture ) ) == 0
::cPicFunc := hb_asciiUpper( cPicture )
::cPicMask := ""
ELSE
@@ -1377,7 +1373,6 @@ METHOD unTransform() CLASS Get
RETURN xValue
METHOD type() CLASS Get
RETURN ::cType := ValType( iif( ::hasFocus, ::xVarGet, ::varGet() ) )
/* The METHOD Block and VAR bBlock allow to replace the
@@ -1416,7 +1411,6 @@ METHOD firstEditable() CLASS Get
RETURN nFor
ENDIF
NEXT
ENDIF
RETURN 0
@@ -1432,7 +1426,6 @@ METHOD lastEditable() CLASS Get
RETURN nFor
ENDIF
NEXT
ENDIF
RETURN 0
@@ -1652,19 +1645,24 @@ METHOD DeleteAll() CLASS Get
::lEdit := .T.
DO CASE
CASE ::cType == "C"
SWITCH ::cType
CASE "C"
xValue := Space( ::nMaxlen )
CASE ::cType == "N"
EXIT
CASE "N"
xValue := 0
::lMinus2 := .F.
CASE ::cType == "D"
EXIT
CASE "D"
xValue := hb_SToD()
CASE ::cType == "T"
EXIT
CASE "T"
xValue := hb_SToT()
CASE ::cType == "L"
EXIT
CASE "L"
xValue := .F.
ENDCASE
EXIT
ENDSWITCH
::cBuffer := ::PutMask( xValue )
::pos := ::FirstEditable()

189
src/rtl/tlabel.prg
View File

@@ -55,9 +55,6 @@
#include "fileio.ch"
#include "inkey.ch"
#define F_OK 0 // No error
#define F_EMPTY -3 // File is empty
#define _LF_SAMPLES 2 // "Do you want more samples?"
#define _LF_YN 12 // "Y/N"
@@ -106,7 +103,7 @@ CREATE CLASS HBLabelForm
VAR nCurrentCol AS NUMERIC // The current column in the band
METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
bWhile, nNext, nRecord, lRest, lSample )
bWhile, nNext, nRecord, lRest, lSample )
METHOD ExecuteLabel()
METHOD SampleLabels()
@@ -124,7 +121,7 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
LOCAL err
LOCAL OldMargin
::aBandToPrint := {} // Array( 5 )
::aBandToPrint := {} // Array( 5 )
::nCurrentCol := 1
// Resolve parameters
@@ -151,7 +148,7 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
ENDIF
lConsoleOn := Set( _SET_CONSOLE )
Set( _SET_CONSOLE, ! ( lNoConsole .OR. ! lConsoleOn ) )
Set( _SET_CONSOLE, ! lNoConsole .AND. lConsoleOn )
IF ! Empty( cAltFile ) // To file
lExtraState := Set( _SET_EXTRA, .T. )
@@ -219,22 +216,20 @@ METHOD New( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
METHOD ExecuteLabel() CLASS HBLabelForm
LOCAL nField, nMoreLines, aBuffer := {}, cBuffer
LOCAL v
LOCAL nField, aField, nMoreLines, aBuffer := {}, cBuffer
LOCAL item
// Load the current record into aBuffer
FOR nField := 1 TO Len( ::aLabelData[ LBL_FIELDS ] )
FOR EACH aField IN ::aLabelData[ LBL_FIELDS ]
IF ::aLabelData[ LBL_FIELDS, nField ] != NIL
v := Eval( ::aLabelData[ LBL_FIELDS, nField, LF_EXP ] )
IF aField != NIL
cBuffer := ;
PadR( v, ::aLabelData[ LBL_WIDTH ] ) + ;
PadR( Eval( aField[ LF_EXP ] ), ::aLabelData[ LBL_WIDTH ] ) + ;
Space( ::aLabelData[ LBL_SPACES ] )
IF ::aLabelData[ LBL_FIELDS, nField, LF_BLANK ]
IF aField[ LF_BLANK ]
IF ! Empty( cBuffer )
AAdd( aBuffer, cBuffer )
ENDIF
@@ -257,8 +252,8 @@ METHOD ExecuteLabel() CLASS HBLabelForm
IF ::nCurrentCol == ::aLabelData[ LBL_ACROSS ]
// trim
FOR nField := 1 TO Len( ::aBandToPrint )
::aBandToPrint[ nField ] := RTrim( ::aBandToPrint[ nField ] )
FOR EACH item IN ::aBandToPrint
item := RTrim( item )
NEXT
::lOneMoreBand := .F.
@@ -268,18 +263,14 @@ METHOD ExecuteLabel() CLASS HBLabelForm
AEval( ::aBandToPrint, {| BandLine | PrintIt( BandLine ) } )
nMoreLines := ::aLabelData[ LBL_HEIGHT ] - Len( ::aBandToPrint )
IF nMoreLines > 0
FOR nField := 1 TO nMoreLines
PrintIt()
NEXT
ENDIF
IF ::aLabelData[ LBL_LINES ] > 0
FOR nField := 1 TO nMoreLines
PrintIt()
NEXT
// Add the spaces between the label lines
FOR nField := 1 TO ::aLabelData[ LBL_LINES ]
PrintIt()
NEXT
ENDIF
// Add the spaces between the label lines
FOR nField := 1 TO ::aLabelData[ LBL_LINES ]
PrintIt()
NEXT
// Clear out the band
AFill( ::aBandToPrint, Space( ::aLabelData[ LBL_LMARGIN ] ) )
@@ -308,17 +299,15 @@ METHOD SampleLabels() CLASS HBLabelForm
// Print the samples
AEval( aBand, {| BandLine | PrintIt( BandLine ) } )
IF ::aLabelData[ LBL_LINES ] > 0
// Add the spaces between the label lines
FOR nField := 1 TO ::aLabelData[ LBL_LINES ]
PrintIt()
NEXT
ENDIF
// Add the spaces between the label lines
FOR nField := 1 TO ::aLabelData[ LBL_LINES ]
PrintIt()
NEXT
// Prompt for more
DispOutAt( Row(), 0, __natMsg( _LF_SAMPLES ) + " (" + __natMsg( _LF_YN ) + ")" )
cKey := hb_keyChar( Inkey( 0 ) )
DispOutAt( Row(), Col(), cKey )
DispOut( cKey )
IF Row() == MaxRow()
hb_Scroll( 0, 0, MaxRow(), MaxCol(), 1 )
SetPos( MaxRow(), 0 )
@@ -337,15 +326,11 @@ METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
LOCAL i // Counters
LOCAL cBuff := Space( BUFFSIZE ) // File buffer
LOCAL nHandle // File handle
LOCAL nReadCount // Bytes read from file
LOCAL nOffset := FILEOFFSET // Offset into file
LOCAL nFileError // File error
LOCAL cFieldText // Text expression container
LOCAL err // error object
LOCAL cDefPath // contents of SET DEFAULT string
LOCAL aPaths // array of paths
LOCAL nPathIndex // iteration counter
LOCAL cPath // iteration variable
// Create and initialize default label array
LOCAL aLabel[ LBL_COUNT ]
@@ -360,83 +345,55 @@ METHOD LoadLabel( cLblFile ) CLASS HBLabelForm
aLabel[ LBL_FIELDS ] := {} // Array of label fields
// Open the label file
nHandle := FOpen( cLblFile )
IF ! Empty( nFileError := FError() ) .AND. !( "\" $ cLblFile .OR. ":" $ cLblFile )
IF ( nHandle := FOpen( cLblFile ) ) == F_ERROR .AND. ;
Empty( hb_FNameDir( cLblFile ) )
// Search through default path; attempt to open label file
cDefPath := Set( _SET_DEFAULT )
cDefPath := StrTran( cDefPath, ",", ";" )
aPaths := ListAsArray( cDefPath, ";" )
FOR nPathIndex := 1 TO Len( aPaths )
nHandle := FOpen( aPaths[ nPathIndex ] + "\" + cLblFile )
// if no error is reported, we have our label file
IF Empty( nFileError := FError() )
FOR EACH cPath IN hb_ATokens( StrTran( Set( _SET_DEFAULT ), ",", ";" ), ";" )
IF ( nHandle := FOpen( hb_DirSepAdd( cPath ) + cLblFile ) ) != F_ERROR
EXIT
ENDIF
NEXT
ENDIF
// File error
IF nFileError != F_OK
IF nHandle == F_ERROR
err := ErrorNew()
err:severity := ES_ERROR
err:genCode := EG_OPEN
err:subSystem := "FRMLBL"
err:osCode := nFileError
err:osCode := FError()
err:filename := cLblFile
Eval( ErrorBlock(), err )
ENDIF
// If we got this far, assume the label file is open and ready to go
// and so go ahead and read it
nReadCount := FRead( nHandle, @cBuff, BUFFSIZE )
// READ ok?
IF nReadCount == 0
nFileError := F_EMPTY // File is empty
ELSE
nFileError := FError() // Check for OS errors
ENDIF
IF FRead( nHandle, @cBuff, BUFFSIZE ) > 0 .AND. FError() == 0
// Load label dimension into aLabel
aLabel[ LBL_REMARK ] := hb_BSubStr( cBuff, REMARKOFFSET, REMARKSIZE )
aLabel[ LBL_HEIGHT ] := Bin2W( hb_BSubStr( cBuff, HEIGHTOFFSET, HEIGHTSIZE ) )
aLabel[ LBL_WIDTH ] := Bin2W( hb_BSubStr( cBuff, WIDTHOFFSET, WIDTHSIZE ) )
aLabel[ LBL_LMARGIN ] := Bin2W( hb_BSubStr( cBuff, LMARGINOFFSET, LMARGINSIZE ) )
aLabel[ LBL_LINES ] := Bin2W( hb_BSubStr( cBuff, LINESOFFSET, LINESSIZE ) )
aLabel[ LBL_SPACES ] := Bin2W( hb_BSubStr( cBuff, SPACESOFFSET, SPACESSIZE ) )
aLabel[ LBL_ACROSS ] := Bin2W( hb_BSubStr( cBuff, ACROSSOFFSET, ACROSSSIZE ) )
IF nFileError == 0
FOR i := 1 TO aLabel[ LBL_HEIGHT ]
// Load label dimension into aLabel
aLabel[ LBL_REMARK ] := hb_BSubStr( cBuff, REMARKOFFSET, REMARKSIZE )
aLabel[ LBL_HEIGHT ] := Bin2W( hb_BSubStr( cBuff, HEIGHTOFFSET, HEIGHTSIZE ) )
aLabel[ LBL_WIDTH ] := Bin2W( hb_BSubStr( cBuff, WIDTHOFFSET, WIDTHSIZE ) )
aLabel[ LBL_LMARGIN ] := Bin2W( hb_BSubStr( cBuff, LMARGINOFFSET, LMARGINSIZE ) )
aLabel[ LBL_LINES ] := Bin2W( hb_BSubStr( cBuff, LINESOFFSET, LINESSIZE ) )
aLabel[ LBL_SPACES ] := Bin2W( hb_BSubStr( cBuff, SPACESOFFSET, SPACESSIZE ) )
aLabel[ LBL_ACROSS ] := Bin2W( hb_BSubStr( cBuff, ACROSSOFFSET, ACROSSSIZE ) )
// Get the text of the expression
cFieldText := RTrim( hb_BSubStr( cBuff, nOffset, FIELDSIZE ) )
nOffset += FIELDSIZE
FOR i := 1 TO aLabel[ LBL_HEIGHT ]
// Get the text of the expression
cFieldText := RTrim( hb_BSubStr( cBuff, nOffset, FIELDSIZE ) )
nOffset += 60
IF ! Empty( cFieldText )
AAdd( aLabel[ LBL_FIELDS ], {} )
// Field expression
AAdd( aLabel[ LBL_FIELDS, i ], hb_macroBlock( cFieldText ) )
// Text of field
AAdd( aLabel[ LBL_FIELDS, i ], cFieldText )
// Compression option
AAdd( aLabel[ LBL_FIELDS, i ], .T. )
ELSE
AAdd( aLabel[ LBL_FIELDS ], NIL )
ENDIF
NEXT
// Close file
FClose( nHandle )
IF Empty( cFieldText )
AAdd( aLabel[ LBL_FIELDS ], NIL )
ELSE
AAdd( aLabel[ LBL_FIELDS ], { ;
/* LF_EXP */ hb_macroBlock( cFieldText ), ;
/* LF_TEXT */ cFieldText, ;
/* LF_BLANK */ .T. } )
ENDIF
NEXT
ENDIF
FClose( nHandle ) // Close file
ENDIF
RETURN aLabel
@@ -449,43 +406,7 @@ FUNCTION __LabelForm( cLBLName, lPrinter, cAltFile, lNoConsole, bFor, ;
STATIC PROCEDURE PrintIt( cString )
hb_default( @cString, "" )
QQOut( cString )
QQOut( hb_defaultValue( cString, "" ) )
QOut()
RETURN
STATIC FUNCTION ListAsArray( cList, cDelimiter )
LOCAL nPos
LOCAL aList := {} // Define an empty array
LOCAL lDelimLast := .F.
hb_default( @cDelimiter, "," )
DO WHILE Len( cList ) != 0
nPos := At( cDelimiter, cList )
IF nPos == 0
nPos := Len( cList )
ENDIF
IF SubStr( cList, nPos, 1 ) == cDelimiter
lDelimLast := .T.
AAdd( aList, SubStr( cList, 1, nPos - 1 ) ) // Add a new element
ELSE
lDelimLast := .F.
AAdd( aList, SubStr( cList, 1, nPos ) ) // Add a new element
ENDIF
cList := SubStr( cList, nPos + 1 )
ENDDO
IF lDelimLast
AAdd( aList, "" )
ENDIF
RETURN aList // Return the array

640
src/rtl/treport.prg
View File

File diff suppressed because it is too large Load Diff