From 7589f0c67291dc3e7ac988f17a72cba225ecb877 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Thu, 19 Mar 2009 18:13:33 +0000 Subject: [PATCH] 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. --- harbour/ChangeLog | 35 +++ harbour/contrib/hbmysql/tmysql.prg | 20 +- harbour/contrib/hbmysql/tsqlbrw.prg | 384 ++++++++++++++-------------- harbour/contrib/xhb/Makefile | 5 + harbour/contrib/xhb/dumpvar.prg | 343 +++++++++++++++++++++++++ harbour/contrib/xhb/hbcompat.ch | 6 + harbour/contrib/xhb/txtline.c | 328 ++++++++++++++++++++++++ harbour/contrib/xhb/xhbat.c | 168 ++++++++++++ harbour/contrib/xhb/xhbis.c | 188 ++++++++++++++ harbour/contrib/xhb/xhbscr.c | 66 +++++ harbour/source/vm/maindll.c | 2 +- harbour/source/vm/maindllp.c | 2 +- 12 files changed, 1343 insertions(+), 204 deletions(-) create mode 100644 harbour/contrib/xhb/dumpvar.prg create mode 100644 harbour/contrib/xhb/txtline.c create mode 100644 harbour/contrib/xhb/xhbat.c create mode 100644 harbour/contrib/xhb/xhbis.c create mode 100644 harbour/contrib/xhb/xhbscr.c diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 0f7486d3de..f4311a96b2 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -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 diff --git a/harbour/contrib/hbmysql/tmysql.prg b/harbour/contrib/hbmysql/tmysql.prg index 3939b0669e..144201b611 100644 --- a/harbour/contrib/hbmysql/tmysql.prg +++ b/harbour/contrib/hbmysql/tmysql.prg @@ -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 diff --git a/harbour/contrib/hbmysql/tsqlbrw.prg b/harbour/contrib/hbmysql/tsqlbrw.prg index 648b01628e..b416b3f348 100644 --- a/harbour/contrib/hbmysql/tsqlbrw.prg +++ b/harbour/contrib/hbmysql/tsqlbrw.prg @@ -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 := "' '" + CASE xType == "M" + xValue := "' '" - 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 diff --git a/harbour/contrib/xhb/Makefile b/harbour/contrib/xhb/Makefile index d18a45771a..2203ba1fac 100644 --- a/harbour/contrib/xhb/Makefile +++ b/harbour/contrib/xhb/Makefile @@ -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 \ diff --git a/harbour/contrib/xhb/dumpvar.prg b/harbour/contrib/xhb/dumpvar.prg new file mode 100644 index 0000000000..6b5be28066 --- /dev/null +++ b/harbour/contrib/xhb/dumpvar.prg @@ -0,0 +1,343 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * Dumpvar function to display var contents + * + * Copyright 2003 Francesco Saverio Giudice + * 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 diff --git a/harbour/contrib/xhb/hbcompat.ch b/harbour/contrib/xhb/hbcompat.ch index 51113e6c4e..816b7e7311 100644 --- a/harbour/contrib/xhb/hbcompat.ch +++ b/harbour/contrib/xhb/hbcompat.ch @@ -119,6 +119,9 @@ #xtranslate hb_DisableWaitLocks([]) => DisableWaitLocks() + #xtranslate hb_gtLock() => HBCONSOLELOCK() + #xtranslate hb_gtUnLock() => HBCONSOLEUNLOCK() + #xtranslate hb_mtvm() => hb_multiThread() #xtranslate hb_threadWaitForAll() => WaitForThreads() #xtranslate hb_mutexNotify() => Notify() @@ -196,6 +199,9 @@ #xtranslate DisableWaitLocks([]) => hb_DisableWaitLocks() + #xtranslate HBCONSOLELOCK() => hb_gtLock() + #xtranslate HBCONSOLEUNLOCK() => hb_gtUnLock() + #xtranslate Str(,[],[],) => iif(, hb_NToS(), Str()) #xtranslate hb_CMDARGARGV([]) => hb_ARGV() diff --git a/harbour/contrib/xhb/txtline.c b/harbour/contrib/xhb/txtline.c new file mode 100644 index 0000000000..439752403f --- /dev/null +++ b/harbour/contrib/xhb/txtline.c @@ -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( , [], , , , [], @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 ); +} diff --git a/harbour/contrib/xhb/xhbat.c b/harbour/contrib/xhb/xhbat.c new file mode 100644 index 0000000000..36e949631f --- /dev/null +++ b/harbour/contrib/xhb/xhbat.c @@ -0,0 +1,168 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * ATSKIPSTRINGS() function + * + * Copyright 1999 Antonio Linares + * Copyright 1999-2001 Viktor Szakats + * 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 ); +} diff --git a/harbour/contrib/xhb/xhbis.c b/harbour/contrib/xhb/xhbis.c new file mode 100644 index 0000000000..3e5cb7e020 --- /dev/null +++ b/harbour/contrib/xhb/xhbis.c @@ -0,0 +1,188 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * IS*() string functions + * + * Copyright 1999 Antonio Linares + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/). + * + * As a special exception, the Harbour Project gives permission for + * additional uses of the text contained in its release of Harbour. + * + * The exception is that, if you link the Harbour libraries with other + * files to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the Harbour library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the Harbour + * Project under the name Harbour. If you copy code from other + * Harbour Project or Free Software Foundation releases into a copy of + * Harbour, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for Harbour, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + * + */ + +#include + +#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 ) ); +} diff --git a/harbour/contrib/xhb/xhbscr.c b/harbour/contrib/xhb/xhbscr.c new file mode 100644 index 0000000000..01fb2ee92c --- /dev/null +++ b/harbour/contrib/xhb/xhbscr.c @@ -0,0 +1,66 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * SCROLL() function + * + * Copyright 1999 David G. Holm + * 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 */ +} diff --git a/harbour/source/vm/maindll.c b/harbour/source/vm/maindll.c index afebe376be..ad63449fb3 100644 --- a/harbour/source/vm/maindll.c +++ b/harbour/source/vm/maindll.c @@ -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 ) { diff --git a/harbour/source/vm/maindllp.c b/harbour/source/vm/maindllp.c index 6232a68924..6ab14c0838 100644 --- a/harbour/source/vm/maindllp.c +++ b/harbour/source/vm/maindllp.c @@ -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 ) {