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

2009-03-19 19:05 UTC+0100 Viktor Szakats (harbour.01 syenar hu)

Browse Source 
* source/vm/maindll.c
  * source/vm/maindllp.c
    ! HB_EXPORT moved to beginning of declaration.

  * contrib/hbmysql/tmysql.prg
  * contrib/hbmysql/tsqlbrw.prg
    * More formatting.

  * xhb/Makefile
  * xhb/hbcompat.ch
  + xhb/xhbis.c
  + xhb/xhbscr.c
  + xhb/xhbat.c
  + xhb/txtline.c
  + xhb/dumpvar.prg
    + Added xhb remaining stuff:
      ISALNUM()
      ISSPACE()
      ISXDIGIT()
      ISCNTRL()
      ISGRAPH()
      ISPRINT()
      ISPUNCT()
      ISASCII()
      SCROLLFIXED()
      ATSKIPSTRINGS()
      HB_TABEXPAND()
      HB_READLINE()
      __OutDebug()
      HB_DumpVar()
      HBCONSOLELOCK() (emulation, might be wrong)
      HBCONSOLEUNLOCK() (emulation, might be wrong)
    ; Please review, my only goal was to make them compile.
This commit is contained in:
Viktor Szakats
2009-03-19 18:13:33 +00:00
parent 6b55002024
commit 7589f0c672
12 changed files with 1343 additions and 204 deletions
Download Patch File Download Diff File Expand all files Collapse all files

35
harbour/ChangeLog
View File

@@ -8,6 +8,41 @@
2009-12-31 13:59 UTC+0100 Foo Bar (foo.bar foobar.org)
*/
2009-03-19 19:05 UTC+0100 Viktor Szakats (harbour.01 syenar hu)
* source/vm/maindll.c
* source/vm/maindllp.c
! HB_EXPORT moved to beginning of declaration.
* contrib/hbmysql/tmysql.prg
* contrib/hbmysql/tsqlbrw.prg
* More formatting.
* xhb/Makefile
* xhb/hbcompat.ch
+ xhb/xhbis.c
+ xhb/xhbscr.c
+ xhb/xhbat.c
+ xhb/txtline.c
+ xhb/dumpvar.prg
+ Added xhb remaining stuff:
ISALNUM()
ISSPACE()
ISXDIGIT()
ISCNTRL()
ISGRAPH()
ISPRINT()
ISPUNCT()
ISASCII()
SCROLLFIXED()
ATSKIPSTRINGS()
HB_TABEXPAND()
HB_READLINE()
__OutDebug()
HB_DumpVar()
HBCONSOLELOCK() (emulation, might be wrong)
HBCONSOLEUNLOCK() (emulation, might be wrong)
; Please review, my only goal was to make them compile.
2009-03-19 18:06 UTC+0100 Viktor Szakats (harbour.01 syenar hu)
* source/vm/maindll.c
* source/vm/maindllp.c

20
harbour/contrib/hbmysql/tmysql.prg
View File

@@ -69,16 +69,16 @@
// Every single row of an answer
CLASS TMySQLRow
CREATE CLASS TMySQLRow
DATA aRow // a single row of answer
DATA aDirty // array of booleans set to .T. if corresponding field of aRow has been changed
DATA aOldValue // If aDirty[n] is .T. aOldValue[n] keeps a copy of changed value if aRow[n] is part of a primary key
VAR aRow // a single row of answer
VAR aDirty // array of booleans set to .T. if corresponding field of aRow has been changed
VAR aOldValue // If aDirty[n] is .T. aOldValue[n] keeps a copy of changed value if aRow[n] is part of a primary key
//DAVID:
DATA aOriValue // Original values ( same as TMySQLtable:aOldValue )
VAR aOriValue // Original values ( same as TMySQLtable:aOldValue )
DATA aFieldStruct // type of each field
DATA cTable // Name of table containing this row, empty if TMySQLQuery returned this row
VAR aFieldStruct // type of each field
VAR cTable // Name of table containing this row, empty if TMySQLQuery returned this row
METHOD New( aRow, aFStruct, cTableName ) // Create a new Row object
@@ -277,7 +277,7 @@ METHOD MakePrimaryKeyWhere() CLASS TMySQLRow
/* ----------------------------------------------------------------------------------------*/
// Every single query submitted to MySQL server
CLASS TMySQLQuery
CREATE CLASS TMySQLQuery
DATA nSocket // connection handle to MySQL server
DATA nResultHandle // result handle received from MySQL
@@ -763,7 +763,7 @@ METHOD FieldType( nNum ) CLASS TMySQLQuery
// A Table is a query without joins; this way I can Insert() e Delete() rows.
// NOTE: it's always a SELECT result, so it will contain a full table only if
// SELECT * FROM ... was issued
CLASS TMySQLTable FROM TMySQLQuery
CREATE CLASS TMySQLTable FROM TMySQLQuery
DATA cTable // name of table
DATA aOldValue // keeps a copy of old value
@@ -1326,7 +1326,7 @@ METHOD MakePrimaryKeyWhere() CLASS TMySQLTable
/* ----------------------------------------------------------------------------------------*/
// Every available MySQL server
CLASS TMySQLServer
CREATE CLASS TMySQLServer
DATA nSocket // connection handle to server (currently pointer to a MYSQL structure)
DATA cServer // server name

384
harbour/contrib/hbmysql/tsqlbrw.prg
View File

@@ -52,82 +52,84 @@
*/
#include "hbclass.ch"
#include "common.ch"
#include "inkey.ch"
#include "dbstruct.ch"
#include "mysql.ch"
/* NOTE:
In fact no, the 'regular syntax is the same as the VO one,
In fact no, the 'regular syntax is the same as the VO one,
ACCESS Block Method Block()
or
ACCESS Block Inline ::MyVal
ACCESS Block METHOD Block()
or
ACCESS Block INLINE ::MyVal
and
and
ASSIGN Block(x) Method Block(x)
or
ASSIGN Block(x) INLINE ::MyVal := x
ASSIGN Block( x ) METHOD Block( x )
or
ASSIGN Block( x ) INLINE ::MyVal := x
*/
CLASS TBColumnSQL from TBColumn
CREATE CLASS TBColumnSQL FROM TBColumn
DATA oBrw // pointer to Browser containing this column, needed to be able to
VAR oBrw // pointer to Browser containing this column, needed to be able to
// retreive field values from Browse instance variable oCurRow
//DATA Picture // From clipper 5.3
DATA nFieldNum // This column maps field num from query
// VAR Picture // From clipper 5.3
VAR nFieldNum // This column maps field num from query
MESSAGE Block METHOD Block() // When evaluating code block to get data from source this method
// gets called. I need this since inside TBColumn Block I cannot
// reference Column or Browser instance variables
METHOD New(cHeading, bBlock, oBrw) // Saves inside column a copy of container browser
METHOD New( cHeading, bBlock, oBrw ) // Saves inside column a copy of container browser
ENDCLASS
METHOD New(cHeading, bBlock, oBrw) CLASS TBColumnSQL
METHOD New( cHeading, bBlock, oBrw ) CLASS TBColumnSQL
super:New(cHeading, bBlock)
super:New( cHeading, bBlock )
::oBrw := oBrw
return Self
RETURN Self
METHOD Block() CLASS TBColumnSQL
local xValue := ::oBrw:oCurRow:FieldGet(::nFieldNum)
local xType := ::oBrw:oCurRow:FieldType(::nFieldNum)
LOCAL xValue := ::oBrw:oCurRow:FieldGet( ::nFieldNum )
LOCAL xType := ::oBrw:oCurRow:FieldType( ::nFieldNum )
do case
case xType == "N"
xValue := "'"+Str(xValue, ::oBrw:oCurRow:FieldLen(::nFieldNum), ::oBrw:oCurRow:FieldDec(::nFieldNum))+"'"
DO CASE
CASE xType == "N"
xValue := "'" + Str( xValue, ::oBrw:oCurRow:FieldLen( ::nFieldNum ), ::oBrw:oCurRow:FieldDec( ::nFieldNum ) ) + "'"
case xType == "D"
xValue := "'" + DToC(xValue) + "'"
CASE xType == "D"
xValue := "'" + DToC( xValue ) + "'"
case xType == "L"
xValue := iif(xValue, ".T.", ".F.")
CASE xType == "L"
xValue := iif( xValue, ".T.", ".F." )
case xType == "C"
// Chr(34) is a double quote
// That is: if there is a double quote inside text substitute it with a string
// which gets converted back to a double quote by macro operator. If not it would
// give an error because of unbalanced double quotes.
xValue := Chr(34) + StrTran(xValue, Chr(34), Chr(34) + "+Chr(34)+" + Chr(34)) + Chr(34)
CASE xType == "C"
// Chr(34) is a double quote
// That is: if there is a double quote inside text substitute it with a string
// which gets converted back to a double quote by macro operator. If not it would
// give an error because of unbalanced double quotes.
xValue := Chr( 34 ) + StrTran( xValue, Chr( 34 ), Chr( 34 ) + "+Chr(34)+" + Chr( 34 ) ) + Chr( 34 )
case xType == "M"
xValue := "' <MEMO> '"
CASE xType == "M"
xValue := "' <MEMO> '"
otherwise
xValue := "'"+xValue+"'"
endcase
OTHERWISE
xValue := "'" + xValue + "'"
ENDCASE
return &("{||" + xValue + "}")
RETURN hb_macroBlock( xValue )
/*--------------------------------------------------------------------------------------------------*/
@@ -137,284 +139,282 @@ return &("{||" + xValue + "}")
This class is more or less like a TBrowseDB() object in that it receives an oQuery/oTable
object and gives back a browseable view of it
*/
CLASS TBrowseSQL from TBrowse
CREATE CLASS TBrowseSQL FROM TBrowse
DATA oCurRow // Active row inside table / sql query
DATA oQuery // Query / table object which we are browsing
VAR oCurRow // Active row inside table / sql query
VAR oQuery // Query / table object which we are browsing
METHOD New(nTop, nLeft, nBottom, nRight, oServer, oQuery, cTable)
METHOD New( nTop, nLeft, nBottom, nRight, oServer, oQuery, cTable )
METHOD EditField() // Editing of hilighted field, after editing does an update of
// corresponding row inside table
METHOD BrowseTable(lCanEdit, aExitKeys) // Handles standard moving inside table and if lCanEdit == .T.
// allows editing of field. It is the stock ApplyKey() moved inside a table
// if lCanEdit K_DEL deletes current row
// When a key is pressed which is present inside aExitKeys it leaves editing loop
METHOD BrowseTable( lCanEdit, aExitKeys ) // Handles standard moving inside table and if lCanEdit == .T.
// allows editing of field. It is the stock ApplyKey() moved inside a table
// if lCanEdit K_DEL deletes current row
// When a key is pressed which is present inside aExitKeys it leaves editing loop
METHOD KeyboardHook(nKey) // Where do all unknown keys go?
METHOD KeyboardHook( nKey ) // Where do all unknown keys go?
ENDCLASS
METHOD New(nTop, nLeft, nBottom, nRight, oServer, oQuery, cTable) CLASS TBrowseSQL
METHOD New( nTop, nLeft, nBottom, nRight, oServer, oQuery, cTable ) CLASS TBrowseSQL
local i, oCol
LOCAL i, oCol
HB_SYMBOL_UNUSED( oServer )
HB_SYMBOL_UNUSED( cTable )
super:New(nTop, nLeft, nBottom, nRight)
super:New( nTop, nLeft, nBottom, nRight )
::oQuery := oQuery
// Let's get a row to build needed columns
::oCurRow := ::oQuery:GetRow(1)
::oCurRow := ::oQuery:GetRow( 1 )
// positioning blocks
::SkipBlock := {|n| ::oCurRow := Skipper(@n, ::oQuery), n }
::GoBottomBlock := {|| ::oCurRow := ::oQuery:GetRow(::oQuery:LastRec()), 1 }
::GoTopBlock := {|| ::oCurRow := ::oQuery:GetRow(1), 1 }
::SkipBlock := {| n | ::oCurRow := Skipper( @n, ::oQuery ), n }
::GoBottomBlock := {|| ::oCurRow := ::oQuery:GetRow( ::oQuery:LastRec() ), 1 }
::GoTopBlock := {|| ::oCurRow := ::oQuery:GetRow( 1), 1 }
// Add a column for each field
for i := 1 to ::oQuery:FCount()
FOR i := 1 TO ::oQuery:FCount()
// No bBlock now since New() would use it to find column length, but column is not ready yet at this point
oCol := TBColumnSQL():New(::oCurRow:FieldName(i),, Self)
oCol := TBColumnSQL():New( ::oCurRow:FieldName( i ),, Self )
if !( ::oCurRow:FieldType(i) == "M" )
oCol:Width := Max(::oCurRow:FieldLen(i), Len(oCol:Heading))
else
IF !( ::oCurRow:FieldType( i ) == "M" )
oCol:Width := Max( ::oCurRow:FieldLen( i ), Len( oCol:Heading ) )
ELSE
oCol:Width := 10
endif
ENDIF
// which field does this column display
oCol:nFieldNum := i
// Add a picture
do case
case ::oCurRow:FieldType(i) == "N"
oCol:picture := replicate("9", oCol:Width)
DO CASE
CASE ::oCurRow:FieldType( i ) == "N"
oCol:picture := Replicate( "9", oCol:Width )
case ::oCurRow:FieldType(i) $ "CM"
oCol:picture := replicate("!", oCol:Width)
endcase
CASE ::oCurRow:FieldType( i ) $ "CM"
oCol:picture := Replicate( "!", oCol:Width )
ENDCASE
::AddColumn(oCol)
next
::AddColumn( oCol )
NEXT
return Self
RETURN Self
STATIC FUNCTION Skipper( nSkip, oQuery )
static function Skipper(nSkip, oQuery)
LOCAL i := 0
local i := 0
DO CASE
CASE nSkip == 0 .OR. oQuery:LastRec() == 0
oQuery:Skip( 0 )
do case
case (nSkip == 0 .OR. oQuery:LastRec() == 0)
oQuery:Skip(0)
case (nSkip > 0)
while ( i < nSkip ) // Skip Foward
CASE nSkip > 0
DO WHILE i < nSkip // Skip Foward
//DAVID: change in TMySQLquery:eof() definition if oQuery:eof()
if oQuery:recno() == oQuery:lastrec()
exit
endif
oQuery:Skip(1)
IF oQuery:recno() == oQuery:lastrec()
EXIT
ENDIF
oQuery:Skip( 1 )
i++
enddo
ENDDO
case ( nSkip < 0 )
while ( i > nSkip ) // Skip backward
CASE nSkip < 0
DO WHILE i > nSkip // Skip backward
//DAVID: change in TMySQLquery:bof() definition if oQuery:bof()
if oQuery:recno() == 1
exit
endif
IF oQuery:recno() == 1
EXIT
ENDIF
oQuery:Skip(-1)
oQuery:Skip( -1 )
i--
enddo
endcase
ENDDO
ENDCASE
nSkip := i
return oQuery:GetRow(oQuery:RecNo())
RETURN oQuery:GetRow( oQuery:RecNo() )
METHOD EditField() CLASS TBrowseSQL
local oCol
local aGetList
local nKey
local cMemoBuff, cMemo
LOCAL oCol
LOCAL aGetList
LOCAL nKey
LOCAL cMemoBuff, cMemo
// Get the current column object from the browse
oCol := ::getColumn(::colPos)
oCol := ::getColumn( ::colPos )
// Editing of a memo field requires a MemoEdit() window
if ::oCurRow:FieldType(oCol:nFieldNum) == "M"
IF ::oCurRow:FieldType( oCol:nFieldNum ) == "M"
/* save, clear, and frame window for memoedit */
cMemoBuff := SaveScreen(10, 10, 22, 69)
cMemoBuff := SaveScreen( 10, 10, 22, 69 )
Scroll(10, 10, 22, 69, 0)
DispBox(10, 10, 22, 69)
hb_Scroll( 10, 10, 22, 69, 0 )
hb_DispBox( 10, 10, 22, 69 )
/* use fieldspec for title */
//@ 10,((76 - Len(::oCurRow:FieldName(oCol:nFieldNum)) / 2) SAY " " + (::oCurRow:FieldName(oCol:nFieldNum)) + " "
//@ 10, ( ( 76 - Len( ::oCurRow:FieldName( oCol:nFieldNum ) ) / 2 ) SAY " " + ( ::oCurRow:FieldName( oCol:nFieldNum ) ) + " "
/* edit the memo field */
cMemo := MemoEdit(::oCurRow:FieldGet(oCol:nFieldNum), 11, 11, 21, 68, .T.)
cMemo := MemoEdit( ::oCurRow:FieldGet( oCol:nFieldNum ), 11, 11, 21, 68, .T. )
if Lastkey() == K_CTRL_END
::oCurRow:FieldPut(oCol:nFieldNum, cMemo)
IF Lastkey() == K_CTRL_END
::oCurRow:FieldPut( oCol:nFieldNum, cMemo )
/* NOTE: To do in a better way */
if !::oQuery:Update(::oCurRow)
Alert(Left(::oQuery:Error(), 60))
endif
endif
IF !::oQuery:Update( ::oCurRow )
Alert( Left( ::oQuery:Error(), 60 ) )
ENDIF
ENDIF
RestScreen(10, 10, 22, 69, cMemoBuff)
RestScreen( 10, 10, 22, 69, cMemoBuff )
else
ELSE
// Create a corresponding GET
// NOTE: I need to use ::oCurRow:FieldPut(...) when changing values since message redirection doesn't work at present
// time for write access to instance variables but only for reading them
aGetList := { getnew( row(), col(), ;
{|xValue| iif(xValue == nil, Eval(oCol:Block), ::oCurRow:FieldPut(oCol:nFieldNum, xValue))} ,;
oCol:heading, ;
oCol:picture, ;
::colorSpec ) }
aGetList := { GetNew( Row(), Col(),;
{| xValue | iif( xValue == NIL, Eval( oCol:Block ), ::oCurRow:FieldPut( oCol:nFieldNum, xValue ) ) },;
oCol:heading,;
oCol:picture,;
::colorSpec ) }
// Set initial cursor shape
//setcursor( iif( ReadInsert(), SC_INSERT, SC_NORMAL ) )
ReadModal(aGetList)
//setcursor( SC_NONE )
// SetCursor( iif( ReadInsert(), SC_INSERT, SC_NORMAL ) )
ReadModal( aGetList )
// SetCursor( SC_NONE )
/* NOTE: To do in a better way */
if !::oQuery:Update(::oCurRow)
Alert(Left(::oQuery:Error(), 60))
endif
IF ! ::oQuery:Update( ::oCurRow )
Alert( Left( ::oQuery:Error(), 60 ) )
ENDIF
endif
if !::oQuery:Refresh()
Alert(::oQuery:Error())
endif
IF !::oQuery:Refresh()
Alert( ::oQuery:Error() )
ENDIF
::RefreshAll()
// Check exit key from get
nKey := LastKey()
if nKey == K_UP .or. nKey == K_DOWN .or. ;
nKey == K_PGUP .or. nKey == K_PGDN
IF nKey == K_UP .OR. nKey == K_DOWN .OR. ;
nKey == K_PGUP .OR. nKey == K_PGDN
// Ugh
keyboard( chr( nKey ) )
KEYBOARD( Chr( nKey ) )
endif
ENDIF
RETURN Self
RETURN Self
METHOD BrowseTable(lCanEdit, aExitKeys) CLASS TBrowseSQL
METHOD BrowseTable( lCanEdit, aExitKeys ) CLASS TBrowseSQL
local nKey
local lKeepGoing := .T.
LOCAL nKey
LOCAL lKeepGoing := .T.
default nKey to nil
default lCanEdit to .F.
default aExitKeys to {K_ESC}
DEFAULT nKey TO NIL
DEFAULT lCanEdit TO .F.
DEFAULT aExitKeys TO { K_ESC }
DO WHILE lKeepGoing
while lKeepGoing
DO WHILE !::Stabilize() .AND. NextKey() == 0
ENDDO
while !::Stabilize() .and. NextKey() == 0
enddo
nKey := Inkey( 0 )
nKey := Inkey(0)
if AScan(aExitKeys, nKey) > 0
IF AScan( aExitKeys, nKey ) > 0
lKeepGoing := .F.
LOOP
endif
ENDIF
do case
case nKey == K_DOWN
::down()
DO CASE
CASE nKey == K_DOWN
::down()
case nKey == K_PGDN
::pageDown()
CASE nKey == K_PGDN
::pageDown()
case nKey == K_CTRL_PGDN
::goBottom()
CASE nKey == K_CTRL_PGDN
::goBottom()
case nKey == K_UP
::up()
CASE nKey == K_UP
::up()
case nKey == K_PGUP
::pageUp()
CASE nKey == K_PGUP
::pageUp()
case nKey == K_CTRL_PGUP
::goTop()
CASE nKey == K_CTRL_PGUP
::goTop()
case nKey == K_RIGHT
::right()
CASE nKey == K_RIGHT
::right()
case nKey == K_LEFT
::left()
CASE nKey == K_LEFT
::left()
case nKey == K_HOME
::home()
CASE nKey == K_HOME
::home()
case nKey == K_END
::end()
CASE nKey == K_END
::end()
case nKey == K_CTRL_LEFT
::panLeft()
CASE nKey == K_CTRL_LEFT
::panLeft()
case nKey == K_CTRL_RIGHT
::panRight()
CASE nKey == K_CTRL_RIGHT
::panRight()
case nKey == K_CTRL_HOME
::panHome()
CASE nKey == K_CTRL_HOME
::panHome()
case nKey == K_CTRL_END
::panEnd()
CASE nKey == K_CTRL_END
::panEnd()
case nKey == K_RETURN .AND. lCanEdit
::EditField()
CASE nKey == K_RETURN .AND. lCanEdit
::EditField()
/*case nKey == K_DEL
if lCanEdit
if ! ::oQuery:Delete(::oCurRow)
Alert("not deleted " + ::oQuery:Error())
endif
if !::oQuery:Refresh()
Alert(::oQuery:Error())
endif
#if 0
CASE nKey == K_DEL
IF lCanEdit
IF ! ::oQuery:Delete( ::oCurRow )
Alert( "not deleted " + ::oQuery:Error() )
ENDIF
IF !::oQuery:Refresh()
Alert( ::oQuery:Error() )
ENDIF
::inValidate()
::refreshAll():forceStable()
endif*/
::inValidate()
::refreshAll():forceStable()
ENDIF
#endif
otherwise
::KeyboardHook(nKey)
endcase
enddo
return Self
OTHERWISE
::KeyboardHook( nKey )
ENDCASE
ENDDO
RETURN Self
// Empty method to be subclassed
METHOD KeyboardHook(nKey) CLASS TBrowseSQL
METHOD KeyboardHook( nKey ) CLASS TBrowseSQL
HB_SYMBOL_UNUSED( nKey )
return Self
RETURN Self

5
harbour/contrib/xhb/Makefile
View File

@@ -19,12 +19,16 @@ C_SOURCES=\
hbserv.c \
hbsyslog.c \
hbxml.c \
txtline.c \
xhbarr.c \
xhbat.c \
xhbcopyf.c \
xhbenum.c \
xhbfunc.c \
xhbis.c \
xhbmsgs.c \
xhbqself.c \
xhbscr.c \
xhbwith.c \
xstrdel.c \
@@ -37,6 +41,7 @@ PRG_SOURCES=\
cstruct.prg \
dbgfx.prg \
dirrec.prg \
dumpvar.prg \
hblog.prg \
hblognet.prg \
hbstruct.prg \

343
harbour/contrib/xhb/dumpvar.prg Normal file
View File

@@ -0,0 +1,343 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* Dumpvar function to display var contents
*
* Copyright 2003 Francesco Saverio Giudice <info@fsgiudice.com>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "common.ch"
#include "hbclass.ch"
#define CRLF HB_OsNewLine()
/*
* (C) 2003 - Francesco Saverio Giudice
*
* Send to hb_OutDebug() more parameters
*
*/
PROCEDURE __OutDebug( ... )
LOCAL xVal
FOR EACH xVal IN hb_aParams()
hb_OutDebug( hb_DumpVar( xVal ) )
NEXT
RETURN
/*
* (C) 2003 - Francesco Saverio Giudice
*
* return a string containing a dump of a variable
*
*
* 24/09/2006 - FSG
* - Added recursion limit
* - Added front function with limited parameters and removed support for TAssociative Array
*/
FUNCTION HB_DumpVar( xVar, lRecursive, nMaxRecursionLevel )
LOCAL nRecursionLevel := 1
LOCAL nIndent := 0
//TraceLog( "HB_DumpVariable: xVar, lAssocAsObj, lRecursive", xVar, lAssocAsObj, lRecursive )
DEFAULT nMaxRecursionLevel TO 0
RETURN __HB_DumpVar( xVar,, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
STATIC FUNCTION __HB_DumpVar( xVar, lAssocAsObj, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL cType := ValType( xVar )
LOCAL cString := "", cKey
DEFAULT lAssocAsObj TO FALSE
DEFAULT lRecursive TO FALSE
//TraceLog( "Recursion: xVar, nRecursionLevel, nMaxRecursionLevel", xVar, nRecursionLevel, nMaxRecursionLevel )
// return if there is limit in recursion
IF nMaxRecursionLevel > 0 .AND. ;
nRecursionLevel > nMaxRecursionLevel
RETURN AsString( xVar )
ENDIF
DO CASE
CASE cType == "O"
IF !lAssocAsObj .AND. xVar:ClassName == "TASSOCIATIVEARRAY"
cString += Space( nIndent ) + "Type='Associative' -> " + CRLF
// Keys extraction.
IF Len( xVar:Keys ) > 0
cString += Space( nIndent ) + "{" + CRLF
FOR EACH cKey IN xVar:Keys
cString += Space( nIndent ) + " '" + cKey + "' => " + asString( xVar:SendKey( cKey ) ) + ", " + CRLF
IF lRecursive .AND. ValType( xVar:SendKey( cKey ) ) $ "AOH"
cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF
cString += __HB_DumpVar( xVar:SendKey( cKey ),, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString )-2 ) + ", " + CRLF
ENDIF
NEXT
cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF
cString += Space( nIndent ) + "}" + CRLF
ENDIF
ELSE
cString += Space( nIndent ) + "<" + xVar:ClassName + " Object>" + CRLF
cString += Space( nIndent ) + " | " + CRLF
cString += Space( nIndent ) + " +- PRIVATE/HIDDEN:" + CRLF
cString += DShowProperties( xVar, HB_OO_CLSTP_HIDDEN, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- PROTECTED:" + CRLF
cString += DShowProperties( xVar, HB_OO_CLSTP_PROTECTED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
cString += Space( nIndent ) + " +- EXPORTED/VISIBLE/PUBLIC:" + CRLF
cString += DShowProperties( xVar, HB_OO_CLSTP_EXPORTED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
#ifdef __XHARBOUR__
cString += Space( nIndent ) + " +- PUBLISHED:" + CRLF
cString += DShowProperties( xVar, HB_OO_CLSTP_PUBLISHED, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
#endif
cString += Space( nIndent ) + " +----------->" + CRLF
ENDIF
CASE cType == "A"
IF nRecursionLevel == 1
cString += Space( nIndent ) + "Type='A' -> { Array of " + LTrim( Str( Len( xVar ) ) ) + " Items }" + CRLF
ENDIF
IF nMaxRecursionLevel > 0 .AND. nRecursionLevel > nMaxRecursionLevel
cString += AsString( xVar )
ELSE
cString += DShowArray( xVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
ENDIF
CASE cType == "H"
IF nRecursionLevel == 1
cString += Space( nIndent ) + "Type='H' -> { Hash of " + LTrim( Str( Len( xVar ) ) ) + " Items }" + CRLF
ENDIF
IF nMaxRecursionLevel > 0 .AND. nRecursionLevel > nMaxRecursionLevel
cString += AsString( xVar )
ELSE
cString += DShowHash( xVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
ENDIF
OTHERWISE
cString += Space( nIndent ) + AsString( xVar ) + CRLF
ENDCASE
RETURN cString
STATIC FUNCTION DShowProperties( oVar, nScope, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL xProp, aProps
LOCAL aMethods, aMth
LOCAL lOldScope
LOCAL cString := ""
DEFAULT nIndent TO 0
IF ValType( oVar ) == "O"
lOldScope := __SetClassScope( .F. )
aMethods := __objGetMsgFullList( oVar, .F., HB_MSGLISTALL, nScope )
aProps := __objGetValueFullList( oVar, NIL, nScope )
__SetClassScope( lOldScope )
IF Len( aProps ) > 0
cString += Space( nIndent ) + " | +- >> Begin Data ------" + CRLF
FOR EACH xProp IN aProps
cString += Space( nIndent ) + " | +- " + PadR( xProp[ HB_OO_DATA_SYMBOL ], 20 ) + " [" + DecodeType( xProp[ HB_OO_DATA_TYPE ] ) + "] [" + DecodeScope( xProp[ HB_OO_DATA_SCOPE ] ) + "] " + ValType( xProp[ HB_OO_DATA_VALUE ] ) + " => " + AsString( xProp[ HB_OO_DATA_VALUE ] ) + CRLF
IF lRecursive .AND. ValType( xProp[ HB_OO_DATA_VALUE ] ) $ "AO"
cString += __HB_DumpVar( xProp[ HB_OO_DATA_VALUE ],, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel ) + CRLF
ENDIF
NEXT
cString += Space( nIndent ) + " | +- >> End Data ------" + CRLF
cString += Space( nIndent ) + " | " + CRLF
ENDIF
IF Len( aMethods ) > 0
cString += Space( nIndent ) + " | +- >> Begin Methods ------" + CRLF
FOR EACH aMth IN aMethods
cString += Space( nIndent ) + " | +- " + PadR( aMth[HB_OO_DATA_SYMBOL], 20 ) + " [" + DecodeType( aMth[HB_OO_DATA_TYPE] ) + "]" + " [" + DecodeScope( aMth[HB_OO_DATA_SCOPE] ) + "] " + CRLF
NEXT
cString += Space( nIndent ) + " | +- >> End Methods ------" + CRLF
cString += Space( nIndent ) + " | " + CRLF
ENDIF
ENDIF
IF Empty( cString )
cString := Space( nIndent ) + " | " + CRLF
ENDIF
RETURN cString
STATIC FUNCTION DShowArray( aVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL xVal, nChar
LOCAL cString := ""
DEFAULT nIndent TO 0
//TraceLog( "DShowArray: aVar, lRecursive", aVar, lRecursive )
IF ValType( aVar ) == "A"
nChar := Len( LTrim( Str( Len( aVar ) ) ) ) // return number of chars to display that value
// i.e. if Len( aVar ) == 99, then nChar := 2
cString += Space( nIndent ) + "{" + CRLF
FOR EACH xVal IN aVar
cString += Space( nIndent ) + " ["+ LTrim( StrZero( HB_EnumIndex(), nChar ) ) + "] => " + AsString( xVal ) + ", " + CRLF
IF lRecursive .AND. ValType( xVal ) $ "AOH"
cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF
cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString )-2 ) + ", " + CRLF
ENDIF
NEXT
IF Len( aVar ) > 0
cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF
ENDIF
cString += Space( nIndent ) + "}" + CRLF
ENDIF
RETURN cString
STATIC FUNCTION DShowHash( hVar, lRecursive, nIndent, nRecursionLevel, nMaxRecursionLevel )
LOCAL xVal, xKey, aKeys
LOCAL cString := ""
DEFAULT nIndent TO 0
//TraceLog( "DShowHash: hVar, ValType( hVar ), lRecursive", hVar, ValType( hVar ), ValToPrg( hVar ), lRecursive )
IF ValType( hVar ) == "H"
aKeys := HGetKeys( hVar )
cString += Space( nIndent ) + "{" + CRLF
FOR EACH xKey IN aKeys
xVal := hVar[ xKey ]
cString += Space( nIndent ) + " ["+ LTrim( AsString( xKey ) ) + "] => " + AsString( xVal ) + ", " + CRLF
IF lRecursive .AND. ValType( xVal ) $ "AOH"
cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF
cString += __HB_DumpVar( xVal,, lRecursive, nIndent+3, nRecursionLevel + 1, nMaxRecursionLevel )
cString := SubStr( cString, 1, Len( cString )-2 ) + ", " + CRLF
ENDIF
NEXT
IF Len( aKeys ) > 0
cString := SubStr( cString, 1, Len( cString )-4 ) + CRLF
ENDIF
cString += Space( nIndent ) + "}" + CRLF
ENDIF
RETURN cString
STATIC FUNCTION DecodeScope( nScope AS NUMERIC )
LOCAL cString := ""
IF hb_BitAnd( nScope, HB_OO_CLSTP_EXPORTED ) # 0 // 1
cString += "Ex,"
ENDIF
#ifdef __XHARBOUR__
IF hb_BitAnd( nScope, HB_OO_CLSTP_PUBLISHED ) # 0 // 2
cString += "Pu,"
ENDIF
#endif
IF hb_BitAnd( nScope, HB_OO_CLSTP_PROTECTED ) # 0 // 4
cString += "Pr,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_HIDDEN ) # 0 // 8
cString += "Hi,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_CTOR ) # 0 // 16
cString += "Ct,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_READONLY ) # 0 // 32
cString += "Ro,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_SHARED ) # 0 // 64
cString += "Sh,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_CLASS ) # 0 // 128
cString += "Cl,"
ENDIF
IF hb_BitAnd( nScope, HB_OO_CLSTP_SUPER ) # 0 // 256
cString += "Su,"
ENDIF
IF cString[-1] == ","
cString := SubStr( cString, 1, Len(cString)-1 )
ENDIF
RETURN PadR( cString, 18 )
STATIC FUNCTION DecodeType( nType AS NUMERIC )
LOCAL cString := ""
DO CASE
CASE nType == HB_OO_MSG_METHOD // 0
cString += "Method"
CASE nType == HB_OO_MSG_DATA // 1
cString += "Data"
CASE nType == HB_OO_MSG_CLASSDATA // 2
cString += "Clsdata"
CASE nType == HB_OO_MSG_INLINE // 3
cString += "Inline"
CASE nType == HB_OO_MSG_VIRTUAL // 4
cString += "Virtual"
CASE nType == HB_OO_MSG_SUPER // 5
cString += "Super"
CASE nType == HB_OO_MSG_ONERROR // 6
cString += "OnError"
CASE nType == HB_OO_MSG_DESTRUCTOR // 7
cString += "Destructor"
CASE nType == HB_OO_PROPERTY // 8
cString += "Property"
CASE nType == HB_OO_MSG_PROPERTY // 9
cString += "MsgPrp"
CASE nType == HB_OO_MSG_CLASSPROPERTY // 10
cString += "ClsPrp"
ENDCASE
RETURN PadR( cString, 7 )
STATIC FUNCTION asString( x )
local v := ValType( x )
DO CASE
CASE v == "C"
RETURN '"' + x + '"'
OTHERWISE
RETURN cStr( x )
ENDCASE
RETURN x

6
harbour/contrib/xhb/hbcompat.ch
View File

@@ -119,6 +119,9 @@
#xtranslate hb_DisableWaitLocks([<x>]) => DisableWaitLocks(<x>)
#xtranslate hb_gtLock() => HBCONSOLELOCK()
#xtranslate hb_gtUnLock() => HBCONSOLEUNLOCK()
#xtranslate hb_mtvm() => hb_multiThread()
#xtranslate hb_threadWaitForAll() => WaitForThreads()
#xtranslate hb_mutexNotify(<x,...>) => Notify(<x>)
@@ -196,6 +199,9 @@
#xtranslate DisableWaitLocks([<x>]) => hb_DisableWaitLocks(<x>)
#xtranslate HBCONSOLELOCK() => hb_gtLock()
#xtranslate HBCONSOLEUNLOCK() => hb_gtUnLock()
#xtranslate Str(<x>,[<y>],[<y>],<z>) => iif(<z>, hb_NToS(<x>), Str(<x>))
#xtranslate hb_CMDARGARGV([<x,...>]) => hb_ARGV(<x>)

328
harbour/contrib/xhb/txtline.c Normal file
View File

@@ -0,0 +1,328 @@
/*
* $Id$
*/
/*
* xHarbour Project source code:
* hb_tabexpand() and hb_readline() functions
*
* Copyright 2004 Marcelo Lombardo - lombardo@uol.com.br
* http://www.xharbour.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbapi.h"
#include "hbapifs.h"
#include "hbset.h"
#include "hbapiitm.h"
#include "hbapierr.h"
void hb_readLine( char * szText, ULONG ulTextLen, ULONG uiLineLen, USHORT uiTabLen, BOOL bWrap, char ** Term, int * iTermSizes, USHORT uiTerms, BOOL * bFound, BOOL * bEOF, LONG * lEnd, ULONG * ulEndOffset )
{
USHORT uiPosTerm, uiPosition;
ULONG ulPos, ulCurrCol, ulLastBlk;
BOOL bBreak = 0;
HB_TRACE(HB_TR_DEBUG, ("hb_readLine(%p, %i, %i, %i, %i, %p, %p, %i, %i, %i, %i, %i)", szText, ulTextLen, uiLineLen, uiTabLen, bWrap, ** Term, * iTermSizes, uiTerms, *bFound, *bEOF, *lEnd, *ulEndOffset ));
*bFound = 0;
*bEOF = 0;
*lEnd = 0;
ulCurrCol = 0;
ulLastBlk = 0;
if( ulTextLen <= 0 )
{
*lEnd = -1;
*ulEndOffset = 0;
*bEOF = 1;
return;
}
if( uiTabLen == 0 )
{
uiTabLen = 4;
}
for( ulPos = 0; ulPos < ulTextLen; ulPos++ )
{
// Check for line terminators
for( uiPosTerm = 0; uiPosTerm < uiTerms; uiPosTerm++ )
{
if( szText[ulPos] == Term[uiPosTerm][0] && (ulPos + iTermSizes[uiPosTerm] - 1) < ulTextLen )
{
*bFound = 1;
for( uiPosition = 1; uiPosition < iTermSizes[uiPosTerm]; uiPosition++ )
{
if( Term[uiPosTerm][uiPosition] != szText[ ulPos+uiPosition ] )
{
*bFound = 0;
break;
}
}
if( *bFound )
{
if( ulPos == 0 )
{
*lEnd = -1;
*ulEndOffset = iTermSizes[uiPosTerm];
}
else
{
*lEnd = ulPos - 1;
*ulEndOffset = ulPos + iTermSizes[uiPosTerm];
}
break;
}
}
}
if( szText[ulPos] == HB_CHAR_HT )
{
ulCurrCol += uiTabLen - ( ulCurrCol % uiTabLen );
}
else if( szText[ulPos] == HB_CHAR_SOFT1 && szText[ulPos + 1] == HB_CHAR_SOFT2 )
{
// Clipper does NOT considers SOFT CR as a word seperator - WHY?
// Should we not fix that?
#if 0
ulLastBlk = ulPos;
#endif
ulPos++;
}
else
{
ulCurrCol++;
}
if( *bFound )
{
break;
}
if( szText[ulPos] == ' ' || szText[ulPos] == HB_CHAR_HT )
{
ulLastBlk = ulPos;
}
if( ulCurrCol > uiLineLen )
{
if( bWrap == FALSE || ulLastBlk == 0 )
{
*lEnd = ulPos-1;
*ulEndOffset = ulPos;
bBreak = 1;
break;
}
else if( bWrap && ulLastBlk != 0 )
{
*lEnd = ulLastBlk;
*ulEndOffset = ulLastBlk + 1;
bBreak = 1;
break;
}
}
}
if( *bFound == FALSE && bBreak == FALSE )
{
*lEnd = ulTextLen - 1;
*ulEndOffset = ulTextLen - 1;
*bEOF = 1;
}
}
LONG hb_tabexpand(char * szString, char * szRet, LONG lEnd, USHORT uiTabLen )
{
LONG lPos, lSpAdded = 0;
for( lPos = 0; lPos <= lEnd; lPos++ )
{
if( szString[ lPos ] == HB_CHAR_HT )
{
lSpAdded += ( (uiTabLen > 0) ? uiTabLen - ( ( lPos + lSpAdded ) % uiTabLen ) - 1 : 0);
}
else if ( ( lPos < lEnd && szString[ lPos ] == HB_CHAR_SOFT1 && szString[ lPos + 1 ] == HB_CHAR_SOFT2 ) || szString[ lPos ] == HB_CHAR_LF )
{
lSpAdded--;
}
else
{
*( szRet + lPos + lSpAdded ) = *( szString + lPos );
}
}
return lSpAdded + lEnd;
}
HB_FUNC( HB_TABEXPAND )
{
char * szText = hb_parcx( 1 );
LONG lStrLen = hb_parclen( 1 );
USHORT uiTabLen = (USHORT) hb_parni( 2 );
USHORT uiTabCount = 0;
LONG lPos, lSize;
char * szRet;
for (lPos = 0; lPos < lStrLen; lPos ++ )
{
if( szText[ lPos ] == HB_CHAR_HT )
{
uiTabCount ++;
}
}
if( (lStrLen == 0) || (uiTabCount == 0) || (uiTabLen == 0) )
{
hb_retc( szText );
}
else
{
lSize = lStrLen + uiTabCount*(uiTabLen - 1);
szRet = (char *) hb_xgrab( lSize + 1 );
memset( szRet, ' ', lSize );
lStrLen = hb_tabexpand( szText, szRet, lStrLen, uiTabLen );
hb_retclenAdopt( szRet, lStrLen);
}
}
// HB_READLINE( <cText>, [<aTerminators | cTerminator>], <nLineLen>, <nTabLen>, <lWrap>, [<nStartOffset>], @nOffSet, @nEnd, @lFound, @lEOF )
HB_FUNC( HB_READLINE )
{
PHB_ITEM pTerm1;
char * szText = hb_parcx( 1 );
char ** Term;
int * iTermSizes;
USHORT uiTabLen, uiTerms;
ULONG ulLineSize = hb_parni(3);
USHORT i;
BOOL bWrap = hb_parl(5);
BOOL bFound, bEOF;
ULONG ulStartOffset;
ULONG ulEndOffset, ulTextLen;
LONG lEnd;
PHB_ITEM pOpt;
BOOL bAlloc_Term1 = FALSE;
if( !ISCHAR( 1 ) )
{
hb_errRT_BASE_SubstR( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, 9, hb_paramError(1), hb_paramError(2), hb_paramError(3), hb_paramError(4), hb_paramError(5), hb_paramError(6), hb_paramError(7), hb_paramError(8), hb_paramError(9), hb_paramError(10) );
return;
}
ulTextLen = hb_parclen(1);
uiTabLen = (USHORT) hb_parclen(4);
if( ISNUM( 6 ) )
{
ulStartOffset = hb_parnl( 6 );
}
else
{
ulStartOffset = 0;
}
if( ! ( ISARRAY( 2 ) || ISCHAR( 2 ) ) )
{
if( ! hb_setGetCPtr( HB_SET_EOL ) )
{
PHB_ITEM pEOL = hb_itemNew( NULL );
hb_itemPutC( pEOL, hb_conNewLine() );
hb_setSetItem( HB_SET_EOL, pEOL );
hb_itemRelease( pEOL );
}
pTerm1 = hb_itemPutC( NULL, hb_setGetCPtr( HB_SET_EOL ) );
bAlloc_Term1 = TRUE;
}
else
{
pTerm1 = hb_param( 2, HB_IT_ANY );
}
pOpt = hb_itemNew( NULL );
if( HB_IS_ARRAY( pTerm1 ) )
{
uiTerms = ( USHORT ) hb_arrayLen( pTerm1 );
Term = ( char** ) hb_xgrab( sizeof(char*) * uiTerms );
iTermSizes = ( int * ) hb_xgrab( sizeof(int) * uiTerms );
for( i = 0; i < uiTerms; i++ )
{
hb_arrayGet( pTerm1, i + 1, pOpt );
Term[ i ] = ( char * ) hb_itemGetCPtr( pOpt );
iTermSizes[ i ] = hb_itemGetCLen( pOpt );
}
}
else
{
Term = ( char** ) hb_xgrab( sizeof( char * ) );
iTermSizes = ( int * ) hb_xgrab( sizeof( int ) );
Term[ 0 ] = ( char * ) hb_itemGetCPtr( pTerm1 );
iTermSizes[ 0 ] = hb_itemGetCLen( pTerm1 );
uiTerms = 1;
}
hb_itemRelease( pOpt );
ulStartOffset--;
hb_readLine( szText + ulStartOffset, ulTextLen - ulStartOffset, ulLineSize, uiTabLen, bWrap, Term, iTermSizes, uiTerms, &bFound, &bEOF, &lEnd, &ulEndOffset );
hb_storl( bFound, 7 );
hb_storl( bEOF, 8 );
hb_stornl( lEnd + ulStartOffset + 1, 9 );
hb_stornl( ulEndOffset + ulStartOffset + 1, 10 );
if( bAlloc_Term1 )
{
hb_itemRelease( pTerm1 );
}
hb_xfree( Term );
hb_xfree( iTermSizes );
}

168
harbour/contrib/xhb/xhbat.c Normal file
View File

@@ -0,0 +1,168 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* ATSKIPSTRINGS() function
*
* Copyright 1999 Antonio Linares <alinares@fivetech.com>
* Copyright 1999-2001 Viktor Szakats <viktor.szakats@syenar.hu>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbapi.h"
#include "hbapiitm.h"
#include "hbapierr.h"
/* locates a substring in a string */
ULONG hb_AtSkipStrings( const char * szSub, ULONG ulSubLen, const char * szText, ULONG ulLen )
{
char cLastChar = ' ';
HB_TRACE(HB_TR_DEBUG, ("hb_AtSkipStrings(%s, %lu, %s, %lu)", szSub, ulSubLen, szText, ulLen));
if( ulSubLen > 0 && ulLen >= ulSubLen )
{
ULONG ulPos = 0;
ULONG ulSubPos = 0;
while( ulPos < ulLen && ulSubPos < ulSubLen )
{
if( szText[ ulPos ] == '"' && szSub[0] != '"' )
{
while( ++ulPos < ulLen && szText[ ulPos ] != '"' )
{
// Skip.
}
ulPos++;
ulSubPos = 0;
continue;
}
if( szText[ ulPos ] == '\'' && szSub[0] != '\'' )
{
while( ++ulPos < ulLen && szText[ ulPos ] != '\'' )
{
// Skip.
}
ulPos++;
ulSubPos = 0;
continue;
}
if( szText[ ulPos ] == '[' && szSub[0] != '[' )
{
if( ! ( HB_ISALPHA( (BYTE) cLastChar ) || HB_ISDIGIT( (BYTE) cLastChar ) || strchr( "])}_.", cLastChar ) ) )
{
while( ++ulPos < ulLen && szText[ ulPos ] != ']' )
{
// Skip.
}
ulPos++;
ulSubPos = 0;
continue;
}
}
if( szText[ ulPos ] == szSub[ ulSubPos ] )
{
ulSubPos++;
ulPos++;
}
else if( ulSubPos )
{
/* Go back to the first character after the first match,
or else tests like "22345" $ "012223456789" will fail. */
ulPos -= ( ulSubPos - 1 );
ulSubPos = 0;
}
else
{
cLastChar = szText[ ulPos ];
ulPos++;
}
}
return ( ulSubPos < ulSubLen ) ? 0 : ( ulPos - ulSubLen + 1 );
}
else
{
return 0;
}
}
HB_FUNC( ATSKIPSTRINGS ) // cFind, cWhere, nStart
{
PHB_ITEM pFind = hb_param( 1, HB_IT_STRING ), pWhere = hb_param( 2, HB_IT_STRING );
if( pFind && pWhere )
{
unsigned long ulStart = (unsigned long) hb_parnl(3);
if( ulStart > 0 )
{
ulStart--;
}
if( ulStart < hb_itemGetCLen( pWhere ) )
{
unsigned long ulRet;
ulRet = hb_AtSkipStrings( hb_itemGetCPtr( pFind ), hb_itemGetCLen( pFind ),
hb_itemGetCPtr( pWhere ) + ulStart, hb_itemGetCLen( pWhere ) - ulStart );
if( ulRet )
{
hb_retnl( ulRet + ulStart );
return;
}
}
}
hb_retnl( 0 );
}

188
harbour/contrib/xhb/xhbis.c Normal file
View File

@@ -0,0 +1,188 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* IS*() string functions
*
* Copyright 1999 Antonio Linares <alinares@fivetech.com>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include <ctype.h>
#include "hbapi.h"
#ifdef __dj_include_inline_ctype_ha_
#undef isalnum
#undef isalpha
#undef iscntrl
#undef isdigit
#undef isgraph
#undef islower
#undef isprint
#undef ispunct
#undef isspace
#undef isupper
#undef isxdigit
#undef tolower
#undef toupper
#define isalnum(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISALNUM)
#define isalpha(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISALPHA)
#define iscntrl(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISCNTRL)
#define isdigit(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISDIGIT)
#define isgraph(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISGRAPH)
#define islower(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISLOWER)
#define isprint(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISPRINT)
#define ispunct(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISPUNCT)
#define isspace(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISSPACE)
#define isupper(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISUPPER)
#define isxdigit(c) (__dj_ctype_flags[(unsigned char)(c)+1] & __dj_ISXDIGIT)
#define tolower(c) (__dj_ctype_tolower[(unsigned char)(c)+1])
#define toupper(c) (__dj_ctype_toupper[(unsigned char)(c)+1])
#endif /* __dj_include_inline_ctype_ha_ */
#if !defined( isascii )
#define isascii( c ) ( ( unsigned ) ( c ) <= 0x7F )
#endif
/* determines if first char of a string is an alphanumeric character */
HB_FUNC( ISALNUM )
{
char * szString = hb_parc( 1 );
if( szString != NULL )
hb_retl( HB_ISALNUM( ( BYTE ) * szString ) );
else
hb_retl( FALSE );
}
/* determines if first char of a string is a white-space character;
that is, a horizontal tab, a new-line, a vertical tab, a form-feed,
a carriage-return or a space.
*/
HB_FUNC( ISSPACE )
{
char * szString = hb_parc( 1 );
if( szString != NULL )
hb_retl( HB_ISSPACE( ( BYTE ) * szString ) );
else
hb_retl( FALSE );
}
/* determines if first char of a string is a hexadecimal digit
('A' - 'F', 'a' - 'f', or '0' -'9').
*/
HB_FUNC( ISXDIGIT )
{
char * szString = hb_parc( 1 );
hb_retl( szString && HB_ISXDIGIT( ( BYTE ) * szString ) );
}
/* determines if first char of a string is a control character;
that is, if it is in the range 0 - 31 or 127 (0x00 - 0x1f or 0x7f).
*/
HB_FUNC( ISCNTRL )
{
char * szString = hb_parc( 1 );
hb_retl( szString && iscntrl( ( BYTE ) * szString ) );
}
/* determines if first char of a string is a printable character.
The space character (' ') is not considered a printable character.
*/
HB_FUNC( ISGRAPH )
{
char * szString = hb_parc( 1 );
hb_retl( szString && isgraph( ( BYTE ) * szString ) );
}
/* determines if first char of a string is a printable character.
Printable characters have an ASCII value between 32 - 126, (0x20 - 0x7e),
a space and the tilde, inclusive.
*/
HB_FUNC( ISPRINT )
{
char * szString = hb_parc( 1 );
hb_retl( szString && isprint( ( BYTE ) * szString ) ) ;
}
/* determines if first char of a string is a punctuation character.
A punctuation character is one that is not alphabetic, not numeric,
not a control character, and not a white space.
*/
HB_FUNC( ISPUNCT )
{
char * szString = hb_parc( 1 );
hb_retl( szString && ispunct( ( BYTE ) * szString ) );
}
/* determines if first char of a string is a member of the 7-bit ASCII
character set; that is, if: 0 <= c <= 127
*/
HB_FUNC( ISASCII )
{
char * szString = hb_parc( 1 );
hb_retl( szString && isascii( ( BYTE ) * szString ) );
}

66
harbour/contrib/xhb/xhbscr.c Normal file
View File

@@ -0,0 +1,66 @@
/*
* $Id$
*/
/*
* Harbour Project source code:
* SCROLL() function
*
* Copyright 1999 David G. Holm <dholm@jsd-llc.com>
* www - http://www.harbour-project.org
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
*
* As a special exception, the Harbour Project gives permission for
* additional uses of the text contained in its release of Harbour.
*
* The exception is that, if you link the Harbour libraries with other
* files to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the Harbour library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the Harbour
* Project under the name Harbour. If you copy code from other
* Harbour Project or Free Software Foundation releases into a copy of
* Harbour, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for Harbour, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*
*/
#include "hbapi.h"
#include "hbapigt.h"
/* Scrolls a screen region */
HB_FUNC( SCROLLFIXED )
{
hb_gtScroll( ( USHORT ) hb_parni( 1 ),
( USHORT ) hb_parni( 2 ),
( USHORT ) hb_parni( 3 ),
( USHORT ) hb_parni( 4 ),
( SHORT ) hb_parni( 5 ), /* Defaults to zero on bad type */
( SHORT ) hb_parni( 6 ) ); /* Defaults to zero on bad type */
}

2
harbour/source/vm/maindll.c
View File

@@ -62,7 +62,7 @@
#if defined(HB_OS_WIN)
BOOL HB_EXPORT WINAPI DllEntryPoint( HINSTANCE hInstance, DWORD fdwReason, PVOID pvReserved );
HB_EXPORT BOOL WINAPI DllEntryPoint( HINSTANCE hInstance, DWORD fdwReason, PVOID pvReserved );
BOOL WINAPI DllEntryPoint( HINSTANCE hInstance, DWORD fdwReason, PVOID pvReserved )
{

2
harbour/source/vm/maindllp.c
View File

@@ -109,7 +109,7 @@ static FARPROC hb_getProcAddress( LPCSTR szProcName )
return pProcAddr;
}
BOOL HB_EXPORT WINAPI DllEntryPoint( HINSTANCE hInstance, DWORD fdwReason, PVOID pvReserved );
HB_EXPORT BOOL WINAPI DllEntryPoint( HINSTANCE hInstance, DWORD fdwReason, PVOID pvReserved );
BOOL WINAPI DllEntryPoint( HINSTANCE hInstance, DWORD fdwReason, PVOID pvReserved )
{