2010-11-16 10:29 UTC+0100 Przemyslaw Czerpak (druzus/at/priv.onet.pl)

* harbour/contrib/xhb/xthrow.prg ! removed unreachable RETURN statement reported by extended BREAK() detection in compiler code * harbour/contrib/xhb/xhbmvinf.c * harbour/contrib/xhb/xhbscr.c * updated header comments * harbour/contrib/xhb/xhb.hbx * harbour/contrib/xhb/xhberr.prg + added xhb_ErrorNew() function which accepts xHarbour ErrorNew() parameters ! fixed xHarbour error handlers to work with Harbour error object which does not contain some local xHarbour extensions * harbour/contrib/xhb/stream.prg * harbour/contrib/xhb/xcstr.prg ! use xhb_ErrorNew() instead of ErrorNew()
2010-11-16 09:30:13 +00:00
parent 4e5a819c80
commit d1183b4073
8 changed files with 139 additions and 34 deletions
--- a/harbour/ChangeLog
+++ b/harbour/ChangeLog
@@ -16,6 +16,26 @@
   The license applies to all entries newer than 2009-04-28.
 */

+2010-11-16 10:29 UTC+0100 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
+  * harbour/contrib/xhb/xthrow.prg
+    ! removed unreachable RETURN statement reported by extended BREAK()
+      detection in compiler code
+
+  * harbour/contrib/xhb/xhbmvinf.c
+  * harbour/contrib/xhb/xhbscr.c
+    * updated header comments
+
+  * harbour/contrib/xhb/xhb.hbx
+  * harbour/contrib/xhb/xhberr.prg
+    + added xhb_ErrorNew() function which accepts xHarbour ErrorNew()
+      parameters
+    ! fixed xHarbour error handlers to work with Harbour error object
+      which does not contain some local xHarbour extensions
+
+  * harbour/contrib/xhb/stream.prg
+  * harbour/contrib/xhb/xcstr.prg
+    ! use xhb_ErrorNew() instead of ErrorNew()
+
 2010-11-15 16:13 UTC+0100 Przemyslaw Czerpak (druzus/at/priv.onet.pl)
  * harbour/src/rtl/gtclip.c
    ! fixed bug in calculation of maximum unicode clipboard buffer size
--- a/harbour/contrib/xhb/stream.prg
+++ b/harbour/contrib/xhb/stream.prg
@@ -102,7 +102,7 @@ METHOD PROCEDURE CopyTo( oTargetStream ) CLASS TStream
   LOCAL nPosition

   IF oTargetStream:lCanWrite == .F.
-      Throw( ErrorNew( "Stream", 0, 1001, ProcName(), "Target not writable.", HB_aParams() ) )
+      Throw( xhb_ErrorNew( "Stream", 0, 1001, ProcName(), "Target not writable.", HB_aParams() ) )
   ENDIF

   // Save.
@@ -154,7 +154,7 @@ METHOD New( cFile, nMode ) CLASS TStreamFileReader

   ::Handle := FOpen( cFile, nMode )
   IF ::Handle <= 0
-      Throw( ErrorNew( "Stream", 0, 1004, ProcName(), "Open Error: " + Str( FError() ), HB_aParams() ) )
+      Throw( xhb_ErrorNew( "Stream", 0, 1004, ProcName(), "Open Error: " + Str( FError() ), HB_aParams() ) )
   ENDIF

   ::nPosition := 0
@@ -174,7 +174,7 @@ METHOD Read( sBuffer, nOffset, nCount ) CLASS TStreamFileReader

 /*
   IF ! HB_IsByRef( @sBuffer )
-      Throw( ErrorNew( "Stream", 0, 1002, ProcName(), "Buffer not BYREF.", HB_aParams() ) )
+      Throw( xhb_ErrorNew( "Stream", 0, 1002, ProcName(), "Buffer not BYREF.", HB_aParams() ) )
   ENDIF
 */

@@ -223,7 +223,7 @@ METHOD New( cFile, nMode ) CLASS TStreamFileWriter

      ::Handle := FOpen( cFile, nMode )
      IF ::Handle <= 0
-         Throw( ErrorNew( "Stream", 0, 1004, ProcName(), "Open Error: " + Str( FError() ), HB_aParams() ) )
+         Throw( xhb_ErrorNew( "Stream", 0, 1004, ProcName(), "Open Error: " + Str( FError() ), HB_aParams() ) )
      ENDIF

      ::nLength := FSeek( ::Handle, 0, FS_END )
@@ -233,7 +233,7 @@ METHOD New( cFile, nMode ) CLASS TStreamFileWriter

      ::Handle := FCreate( cFile, nMode )
      IF ::Handle <= 0
-         Throw( ErrorNew( "Stream", 0, 1004, ProcName(), "Create Error: " + Str( FError() ), HB_aParams() ) )
+         Throw( xhb_ErrorNew( "Stream", 0, 1004, ProcName(), "Create Error: " + Str( FError() ), HB_aParams() ) )
      ENDIF

      ::nPosition := 0
@@ -255,7 +255,7 @@ METHOD Write( sBuffer, nOffset, nCount ) CLASS TStreamFileWriter
   ::nPosition += nWritten

   IF nWritten != nCount
-      Throw( ErrorNew( "Stream", 0, 1003, ProcName(), "Write failed - written:" + Str( nWritten ) + " bytes", HB_aParams() ) )
+      Throw( xhb_ErrorNew( "Stream", 0, 1003, ProcName(), "Write failed - written:" + Str( nWritten ) + " bytes", HB_aParams() ) )
   ENDIF

   RETURN nWritten
@@ -267,7 +267,7 @@ METHOD PROCEDURE WriteByte( cByte ) CLASS TStreamFileWriter
   ::nPosition += nWritten

   IF nWritten != 1
-      Throw( ErrorNew( "Stream", 0, 1006, ProcName(), "Write failed", HB_aParams() ) )
+      Throw( xhb_ErrorNew( "Stream", 0, 1006, ProcName(), "Write failed", HB_aParams() ) )
   ENDIF

   RETURN
--- a/harbour/contrib/xhb/xcstr.prg
+++ b/harbour/contrib/xhb/xcstr.prg
@@ -67,7 +67,7 @@
 FUNCTION CStrToVal( cExp, cType )

   IF ! ISCHAR( cExp )
-      Throw( ErrorNew( "CSTR", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
+      Throw( xhb_ErrorNew( "CSTR", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
   ENDIF

   SWITCH cType
@@ -95,17 +95,17 @@ FUNCTION CStrToVal( cExp, cType )

      /*
      CASE 'A'
-         Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
+         Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )

      CASE 'B'
-         Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
+         Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )

      CASE 'O'
-         Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
+         Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
      */

      OTHERWISE
-         Throw( ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
+         Throw( xhb_ErrorNew( "CSTRTOVAL", 0, 3101, ProcName(), "Argument error", { cExp, cType } ) )
   ENDSWITCH

 RETURN NIL
@@ -243,7 +243,7 @@ FUNCTION ValToPrg( xVal, cName, nPad, aObjs )
         IF xVal == NIL
            cRet := "NIL"
         ELSE
-            Throw( ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
+            Throw( xhb_ErrorNew( "VALTOPRG", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
         ENDIF
   ENDSWITCH

@@ -315,7 +315,7 @@ FUNCTION ValToDate( xVal )
         RETURN 0d19000101 + xVal

      OTHERWISE
-         Throw( ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
+         Throw( xhb_ErrorNew( "VALTODATE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
   ENDSWITCH

 RETURN hb_SToD()
@@ -361,7 +361,7 @@ FUNCTION ValToLogical( xVal )
         RETURN .F.

      OTHERWISE
-         Throw( ErrorNew( "VALTOLOGICAL", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
+         Throw( xhb_ErrorNew( "VALTOLOGICAL", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
   ENDSWITCH

 RETURN .F.
@@ -399,7 +399,7 @@ FUNCTION ValToNumber( xVal )
         RETURN 0

      OTHERWISE
-         Throw( ErrorNew( "VALTONUMBER", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
+         Throw( xhb_ErrorNew( "VALTONUMBER", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
   ENDSWITCH

 RETURN 0
@@ -448,7 +448,7 @@ FUNCTION ValToObject( xVal )
         EXIT

      OTHERWISE
-         Throw( ErrorNew( "VALTOOBJECT", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
+         Throw( xhb_ErrorNew( "VALTOOBJECT", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
   ENDSWITCH

 RETURN 0
@@ -488,7 +488,7 @@ FUNCTION ValToType( xVal, cType )
         RETURN NIL

      OTHERWISE
-         Throw( ErrorNew( "VALTOTYPE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
+         Throw( xhb_ErrorNew( "VALTOTYPE", 0, 3103, ProcName(), "Unsupported type", { xVal } ) )
   ENDSWITCH

 RETURN NIL
--- a/harbour/contrib/xhb/xhb.hbx
+++ b/harbour/contrib/xhb/xhb.hbx
@@ -414,6 +414,7 @@ DYNAMIC XHB_DEC
 DYNAMIC XHB_DIV
 DYNAMIC XHB_EEQUAL
 DYNAMIC XHB_EQUAL
+DYNAMIC XHB_ERRORNEW
 DYNAMIC XHB_ERRORSYS
 DYNAMIC XHB_GREATER
 DYNAMIC XHB_GREATEREQ
--- a/harbour/contrib/xhb/xhberr.prg
+++ b/harbour/contrib/xhb/xhberr.prg
@@ -4,8 +4,13 @@

 /*
 * Harbour Project source code:
- * The default error handler
+ * xHarbour default error handler and error functions:
+ *    xhb_ErrorSys(), __BreakBlock(), __ErrorBlock(),
+ *    __MinimalErrorHandler(), xhb_ErrorNew()
 *
+ * Copyright 2010 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
+ * Copyright 2009 Viktor Szakats (harbour.01 syenar.hu)
+ * Copyright 2004 Ron Pinkas <ron @ xHarbour.com>
 * Copyright 1999 Antonio Linares <alinares@fivetech.com>
 * www - http://harbour-project.org
 *
@@ -74,6 +79,18 @@ PROCEDURE xhb_ErrorSys()
   ErrorBlock( { | oError | xhb_DefError( oError ) } )
   RETURN

+STATIC FUNCTION err_ModuleName( oError, n )
+   RETURN IIF( __objHasMsg( oError, "MODULENAME" ), oError:ModuleName, ;
+               IIF( n != NIL, ProcFile( n ), NIL ) )
+
+STATIC FUNCTION err_ProcName( oError, n )
+   RETURN IIF( __objHasMsg( oError, "PROCNAME" ), oError:ProcName, ;
+               IIF( n != NIL, ProcName( n ), NIL ) )
+
+STATIC FUNCTION err_ProcLine( oError, n )
+   RETURN IIF( __objHasMsg( oError, "PROCLINE" ), oError:ProcLine, ;
+               IIF( n != NIL, ProcLine( n ), NIL ) )
+
 STATIC FUNCTION xhb_DefError( oError )
   LOCAL cMessage
   LOCAL cDOSError
@@ -86,8 +103,9 @@ STATIC FUNCTION xhb_DefError( oError )
   n := 0
   WHILE ! Empty( ProcName( ++n ) )
      IF ProcName( n ) == ProcName()
-         TraceLog( "Error system failure!", oError:ProcName, oError:ProcLine(), oError:ModuleName, oError:description )
-         Alert( "Error system failure!;Please correct error handler:;" + oError:ProcName + "(" + LTrim( Str( oError:ProcLine() ) ) +  ") in module: " + oError:ModuleName )
+         n := 3
+         TraceLog( "Error system failure!", err_ProcName( oError, n ), err_ProcLine( oError, n ), err_ModuleName( oError, n ), oError:description )
+         Alert( "Error system failure!;Please correct error handler:;" + err_ProcName( oError, n ) + "(" + LTrim( Str( err_ProcLine( oError, n ) ) ) +  ") in module: " + err_ModuleName( oError, n ) )
         ErrorLevel( 1 )
         QUIT
      ENDIF
@@ -177,9 +195,9 @@ STATIC FUNCTION xhb_DefError( oError )
      ENDIF
   ELSE
      IF Empty( oError:osCode )
-         Alert( cMessage + ";" + oError:ProcName + "(" + LTrim( Str( oError:ProcLine() ) ) +  ") in module: " + oError:ModuleName )
+         Alert( cMessage + ";" + err_ProcName( oError, 3 ) + "(" + LTrim( Str( err_ProcLine( oError, 3 ) ) ) +  ") in module: " + err_ModuleName( oError, 3 ) )
      ELSE
-         Alert( cMessage + ";" + cDOSError + ";" + oError:ProcName + "(" + LTrim( Str( oError:ProcLine() ) ) +  ") in module: " + oError:ModuleName )
+         Alert( cMessage + ";" + cDOSError + ";" + err_ProcName( oError, 3 ) + "(" + LTrim( Str( err_ProcLine( oError, 3 ) ) ) +  ") in module: " + err_ModuleName( oError, 3 ) )
      ENDIF
   ENDIF

@@ -654,7 +672,14 @@ FUNCTION __ErrorBlock( )

 PROCEDURE __MinimalErrorHandler( oError )

-   LOCAL cError := "Error!" + hb_eol()
+   LOCAL cError
+   LOCAL xData
+
+   cError := "Error"
+   IF ISNUMBER( oError:SubCode )
+      cError += ": " + hb_ntos( oError:SubCode )
+   ENDIF
+   cError += "!" + hb_eol()

   IF ISCHARACTER( oError:Operation )
      cError += "Operation: " + oError:Operation + hb_eol()
@@ -662,14 +687,14 @@ PROCEDURE __MinimalErrorHandler( oError )
   IF ISCHARACTER( oError:Description )
      cError += "Description: " + oError:Description + hb_eol()
   ENDIF
-   IF ISCHARACTER( oError:ModuleName )
-      cError += "Source: " + oError:ModuleName + hb_eol()
+   IF ISCHARACTER( xData := err_ModuleName( oError ) )
+      cError += "Source: " + xData + hb_eol()
   ENDIF
-   IF ISCHARACTER( oError:ProcName )
-      cError += "Procedure: " + oError:ProcName + hb_eol()
+   IF ISCHARACTER( xData := err_ProcName( oError ) )
+      cError += "Procedure: " + xData + hb_eol()
   ENDIF
-   IF ISNUMBER( oError:ProcLine )
-      cError += "Line: " + hb_ntos( oError:ProcLine ) + hb_eol()
+   IF ISNUMBER( xData := err_ProcLine( oError ) )
+      cError += "Line: " + hb_ntos( xData ) + hb_eol()
   ENDIF

   OutStd( cError )
@@ -677,3 +702,64 @@ PROCEDURE __MinimalErrorHandler( oError )
   QUIT

   RETURN
+
+FUNCTION xhb_ErrorNew( cSubSystem, nGenCode, nSubCode, ;
+                       cOperation, cDescription, aArgs, ;
+                       cModuleName, cProcName, nProcLine )
+
+   LOCAL oError := ErrorNew()
+   LOCAL aStack, n
+
+   IF ISCHARACTER( cSubSystem )
+      oError:SubSystem := cSubSystem
+   ENDIF
+   IF ISNUMBER( nGenCode )
+      oError:GenCode := nGenCode
+   ENDIF
+   IF ISNUMBER( nSubCode )
+      oError:SubCode := nSubCode
+   ENDIF
+   IF ISCHARACTER( cOperation )
+      oError:Operation := cOperation
+   ENDIF
+   IF ISCHARACTER( cDescription )
+      oError:Description := cDescription
+   ENDIF
+   IF ISARRAY( aArgs )
+      oError:Args := aArgs
+   ENDIF
+
+   IF __objHasMsg( oError, "MODULENAME" )
+      IF ISCHARACTER( cModuleName )
+         oError:ModuleName := cModuleName
+      ELSE
+         oError:ModuleName := ProcFile( 1 )
+      ENDIF
+   ENDIF
+
+   IF __objHasMsg( oError, "PROCNAME" )
+      IF ISCHARACTER( cProcName )
+         oError:ProcName := cProcName
+      ELSE
+         oError:ProcName := ProcName( 1 )
+      ENDIF
+   ENDIF
+
+   IF __objHasMsg( oError, "PROCLINE" )
+      IF ISNUMBER( nProcLine )
+         oError:ProcLine := nProcLine
+      ELSE
+         oError:ProcLine := ProcLine( 1 )
+      ENDIF
+   ENDIF
+
+   IF __objHasMsg( oError, "AASTACK" )
+      aStack := {}
+      n := 0
+      WHILE ! Empty( ProcName( ++n ) )
+         AAdd( aStack, { ProcFile( n ), ProcName( n ), ProcLine( n ) } )
+      ENDDO
+      oError:aAStack := aStack
+   ENDIF
+
+   RETURN oError
--- a/harbour/contrib/xhb/xhbmvinf.c
+++ b/harbour/contrib/xhb/xhbmvinf.c
@@ -4,7 +4,7 @@

 /*
 * Harbour Project source code:
- * 
+ *    xHarbour compatible __MVSYMBOLINFO() function
 *
 * Copyright 2010 Przemyslaw Czerpak <druzus / at / priv.onet.pl>
 * www - http://www.harbour-project.org
--- a/harbour/contrib/xhb/xhbscr.c
+++ b/harbour/contrib/xhb/xhbscr.c
@@ -4,7 +4,7 @@

 /*
 * Harbour Project source code:
- * SCROLL() function
+ * SCROLLFIXED() function
 *
 * Copyright 1999 David G. Holm <dholm@jsd-llc.com>
 * www - http://harbour-project.org
--- a/harbour/contrib/xhb/xthrow.prg
+++ b/harbour/contrib/xhb/xthrow.prg
@@ -54,5 +54,3 @@ PROCEDURE THROW( oError )

   Eval( ErrorBlock(), oError )
   Break( oError )
-
-   RETURN