ab75: #i110417# initial ( untested ) implementation

10 files changed, 270 insertions, 5 deletions

diff --git a/basic/inc/basic/sberrors.hxx b/basic/inc/basic/sberrors.hxx
index c21b3b0237b8..c34176e0bde7 100644
--- a/basic/inc/basic/sberrors.hxx
+++ b/basic/inc/basic/sberrors.hxx
@@ -287,6 +287,8 @@ typedef ULONG SbError;
 #define ERRCODE_BASIC_LOOP_NOT_INIT         ((LAST_SBX_ERROR_ID+109UL) | ERRCODE_AREA_SBX | \
                                             ERRCODE_CLASS_COMPILER)             // For loop not initialized
 
+#define ERRCODE_BASIC_COMPAT                ((LAST_SBX_ERROR_ID+103UL)| ERRCODE_AREA_SBX | ERRCODE_CLASS_RUNTIME)
+
 // Map old codes to new codes
 #define SbERR_SYNTAX                        ERRCODE_BASIC_SYNTAX
 #define SbERR_NO_GOSUB                      ERRCODE_BASIC_NO_GOSUB
@@ -410,6 +412,7 @@ typedef ULONG SbError;
 #define SbERR_PROG_TOO_LARGE                ERRCODE_BASIC_PROG_TOO_LARGE
 #define SbERR_NO_STRINGS_ARRAYS             ERRCODE_BASIC_NO_STRINGS_ARRAYS
 #define SbERR_BASIC_EXCEPTION               ERRCODE_BASIC_EXCEPTION
+#define SbERR_BASIC_COMPAT                  ERRCODE_BASIC_COMPAT
 #define SbERR_BASIC_ARRAY_FIX               ERRCODE_BASIC_ARRAY_FIX
 #define SbERR_BASIC_STRING_OVERFLOW         ERRCODE_BASIC_STRING_OVERFLOW
 #define SbERR_BASIC_EXPR_TOO_COMPLEX        ERRCODE_BASIC_EXPR_TOO_COMPLEX
diff --git a/basic/source/classes/errobject.cxx b/basic/source/classes/errobject.cxx
new file mode 100644
index 000000000000..dc62e65b6945
--- /dev/null
+++ b/basic/source/classes/errobject.cxx
@@ -0,0 +1,181 @@
+// MARKER(update_precomp.py): autogen include statement, do not remove
+#include "precompiled_basic.hxx"
+#include "errobject.hxx"
+
+#include <cppuhelper/implbase2.hxx>
+#include <com/sun/star/script/XDefaultProperty.hpp>
+#include "sbintern.hxx"
+#include "runtime.hxx"
+
+using namespace ::com::sun::star;
+using namespace ::ooo;
+
+typedef ::cppu::WeakImplHelper2< vba::XErrObject, script::XDefaultProperty > ErrObjectImpl_BASE;
+
+class ErrObject : public ErrObjectImpl_BASE
+{
+    rtl::OUString m_sHelpFile;
+    rtl::OUString m_sSource;
+        rtl::OUString m_sDescription;
+    sal_Int32 m_nNumber;
+    sal_Int32 m_nHelpContext;
+
+public:
+    ErrObject();
+    ~ErrObject();
+    // Attributes
+    virtual ::sal_Int32 SAL_CALL getNumber() throw (uno::RuntimeException);
+    virtual void SAL_CALL setNumber( ::sal_Int32 _number ) throw (uno::RuntimeException);
+    virtual ::sal_Int32 SAL_CALL getHelpContext() throw (uno::RuntimeException);
+    virtual void SAL_CALL setHelpContext( ::sal_Int32 _helpcontext ) throw (uno::RuntimeException);
+    virtual ::rtl::OUString SAL_CALL getHelpFile() throw (uno::RuntimeException);
+    virtual void SAL_CALL setHelpFile( const ::rtl::OUString& _helpfile ) throw (uno::RuntimeException);
+    virtual ::rtl::OUString SAL_CALL getDescription() throw (uno::RuntimeException);
+    virtual void SAL_CALL setDescription( const ::rtl::OUString& _description ) throw (uno::RuntimeException);
+    virtual ::rtl::OUString SAL_CALL getSource() throw (uno::RuntimeException);
+    virtual void SAL_CALL setSource( const ::rtl::OUString& _source ) throw (uno::RuntimeException);
+
+    // Methods
+    virtual void SAL_CALL Clear(  ) throw (uno::RuntimeException);
+    virtual void SAL_CALL Raise( const uno::Any& Number, const uno::Any& Source, const uno::Any& Description, const uno::Any& HelpFile, const uno::Any& HelpContext ) throw (uno::RuntimeException);
+    // XDefaultProperty
+    virtual ::rtl::OUString SAL_CALL getDefaultPropertyName(  ) throw (uno::RuntimeException);
+};
+
+
+ErrObject::~ErrObject()
+{
+}
+
+ErrObject::ErrObject() : m_nNumber(0), m_nHelpContext(0)
+{
+}
+
+sal_Int32 SAL_CALL
+ErrObject::getNumber() throw (uno::RuntimeException)
+{
+    return m_nNumber;
+}
+
+void SAL_CALL
+ErrObject::setNumber( ::sal_Int32 _number ) throw (uno::RuntimeException)
+{
+    m_nNumber = _number;
+
+
+}
+
+::sal_Int32 SAL_CALL
+ErrObject::getHelpContext() throw (uno::RuntimeException)
+{
+    return m_nHelpContext;
+}
+void SAL_CALL
+ErrObject::setHelpContext( ::sal_Int32 _helpcontext ) throw (uno::RuntimeException)
+{
+    m_nHelpContext = _helpcontext;
+}
+
+::rtl::OUString SAL_CALL
+ErrObject::getHelpFile() throw (uno::RuntimeException)
+{
+    return m_sHelpFile;
+}
+
+void SAL_CALL
+ErrObject::setHelpFile( const ::rtl::OUString& _helpfile ) throw (uno::RuntimeException)
+{
+    m_sHelpFile = _helpfile;
+}
+
+::rtl::OUString SAL_CALL
+ErrObject::getDescription() throw (uno::RuntimeException)
+{
+    return m_sDescription;
+}
+
+void SAL_CALL
+ErrObject::setDescription( const ::rtl::OUString& _description ) throw (uno::RuntimeException)
+{
+    m_sDescription = _description;
+}
+
+::rtl::OUString SAL_CALL
+ErrObject::getSource() throw (uno::RuntimeException)
+{
+    return m_sSource;
+}
+
+void SAL_CALL
+ErrObject::setSource( const ::rtl::OUString& _source ) throw (uno::RuntimeException)
+{
+    m_sSource = _source;
+}
+
+// Methods
+void SAL_CALL
+ErrObject::Clear(  ) throw (uno::RuntimeException)
+{
+    m_sHelpFile = rtl::OUString();
+    m_sSource = m_sHelpFile;
+    m_sDescription = m_sSource;
+    m_nNumber = 0;
+    m_nHelpContext = 0;
+}
+
+void SAL_CALL
+ErrObject::Raise( const uno::Any& Number, const uno::Any& Source, const uno::Any& Description, const uno::Any& HelpFile, const uno::Any& HelpContext ) throw (uno::RuntimeException)
+{
+    if ( !Number.hasValue() )
+        throw uno::RuntimeException( rtl::OUString::createFromAscii("Missing Required Paramater"), uno::Reference< uno::XInterface >() );
+    Description >>= m_sDescription;
+    Source >>= m_sSource;
+    HelpFile >>= m_sHelpFile;
+    HelpContext >>= m_nHelpContext;
+    Number >>= m_nNumber;
+    if ( m_nNumber )
+    {
+        SbError n = StarBASIC::GetSfxFromVBError( m_nNumber );
+        if ( !n )
+            n = m_nNumber; // force orig number, probably should have a specific table of vb ( localized ) errors
+        pINST->Error( n, m_sDescription );
+    }
+}
+
+// XDefaultProperty
+::rtl::OUString SAL_CALL
+ErrObject::getDefaultPropertyName(  ) throw (uno::RuntimeException)
+{
+    static rtl::OUString sDfltPropName( RTL_CONSTASCII_USTRINGPARAM("Number") );
+    return sDfltPropName;
+}
+
+// SbxErrObject
+SbxErrObject::SbxErrObject( const String& rName, const Any& rUnoObj ): SbUnoObject( rName, rUnoObj )
+{
+    OSL_TRACE("SbxErrObject::SbxErrObject ctor");
+    rUnoObj >>= m_xErr;
+    if ( m_xErr.is() )
+        SetDfltProperty( uno::Reference< script::XDefaultProperty >( m_xErr, uno::UNO_QUERY_THROW )->getDefaultPropertyName() ) ;
+}
+
+SbxErrObject::~SbxErrObject()
+{
+    OSL_TRACE("SbxErrObject::~SbxErrObject dtor");
+}
+
+uno::Reference< vba::XErrObject >
+SbxErrObject::getUnoErrObject()
+{
+    SbxVariable* pVar = getErrObject();
+    SbxErrObject* pGlobErr = static_cast< SbxErrObject* >(  pVar );
+    return pGlobErr->m_xErr;
+}
+
+SbxVariableRef
+SbxErrObject::getErrObject()
+{
+    static SbxVariableRef pGlobErr = new SbxErrObject( String(  RTL_CONSTASCII_USTRINGPARAM("Err")), uno::makeAny( uno::Reference< vba::XErrObject >( new ErrObject() ) ) );
+    return pGlobErr;
+}
+
diff --git a/basic/source/classes/makefile.mk b/basic/source/classes/makefile.mk
index eb5486f02abf..e00ed4674cc1 100644
--- a/basic/source/classes/makefile.mk
+++ b/basic/source/classes/makefile.mk
@@ -37,18 +37,28 @@ ENABLE_EXCEPTIONS=TRUE
 
 .INCLUDE :  settings.mk
 
+ALLTAR .SEQUENTIAL : \
+        $(MISC)$/$(TARGET).don \
+        $(MISC)$/$(TARGET).slo
+
+$(MISC)$/$(TARGET).don : $(SOLARBINDIR)$/oovbaapi.rdb
+        +$(CPPUMAKER) -O$(OUT)$/inc -BUCR $(SOLARBINDIR)$/oovbaapi.rdb -X$(SOLARBINDIR)$/types.rdb && echo > $@
+        echo $@
+
+$(MISC)$/$(TARGET).slo : $(SLOTARGET)
+        echo $@
+
 # --- Allgemein -----------------------------------------------------------
 
-COMMON_SLOFILES=	\
+SLOFILES=	\
     $(SLO)$/sb.obj       \
     $(SLO)$/sbxmod.obj	\
     $(SLO)$/image.obj	\
     $(SLO)$/sbintern.obj	\
     $(SLO)$/sbunoobj.obj	\
     $(SLO)$/propacc.obj	\
-    $(SLO)$/disas.obj
-
-SLOFILES=	$(COMMON_SLOFILES)	\
+    $(SLO)$/disas.obj \
+    $(SLO)$/errobject.obj \
     $(SLO)$/eventatt.obj
 
 OBJFILES=	\
diff --git a/basic/source/classes/sb.cxx b/basic/source/classes/sb.cxx
index c5ac53c43092..60f4de70c2be 100644
--- a/basic/source/classes/sb.cxx
+++ b/basic/source/classes/sb.cxx
@@ -215,6 +215,7 @@ const SFX_VB_ErrorItem __FAR_DATA SFX_VB_ErrorTab[] =
     { 1004, SbERR_METHOD_FAILED },
     { 1005, SbERR_SETPROP_FAILED },
     { 1006, SbERR_GETPROP_FAILED },
+    { 1007, SbERR_BASIC_COMPAT },
     { 0xFFFF, 0xFFFFFFFFL }     // End mark
 };
 
diff --git a/basic/source/classes/sb.src b/basic/source/classes/sb.src
index 926da0359d7e..41ae03d9934f 100644
--- a/basic/source/classes/sb.src
+++ b/basic/source/classes/sb.src
@@ -588,6 +588,12 @@ Resource RID_BASIC_START
     {
         Text [ en-US ] = "For loop not initialized." ;
     };
+    String ERRCODE_BASIC_COMPAT & ERRCODE_RES_MASK
+    {
+        Text [ de ] = "$(ARG1)." ;
+        Text [ en-US ] = "$(ARG1)." ;
+        Text [ x-comment ] = " ";
+    };
 };
  // Hinweis: IDS_SBERR_TERMINATED = IDS_SBERR_START+2000.
 String IDS_SBERR_TERMINATED
diff --git a/basic/source/inc/errobject.hxx b/basic/source/inc/errobject.hxx
new file mode 100644
index 000000000000..51d4b6caa4f9
--- /dev/null
+++ b/basic/source/inc/errobject.hxx
@@ -0,0 +1,16 @@
+#ifndef ERROBJECT_HXX
+#define ERROBJECT_HXX
+#include "sbunoobj.hxx"
+#include <ooo/vba/XErrObject.hpp>
+
+
+class SbxErrObject : public SbUnoObject
+{
+    com::sun::star::uno::Reference< ooo::vba::XErrObject > m_xErr;
+    SbxErrObject( const String& aName_, const com::sun::star::uno::Any& aUnoObj_ );
+    ~SbxErrObject();
+public:
+    static SbxVariableRef getErrObject();
+    static com::sun::star::uno::Reference< ooo::vba::XErrObject > getUnoErrObject();
+};
+#endif
diff --git a/basic/source/runtime/runtime.cxx b/basic/source/runtime/runtime.cxx
index 52aa76e2f2df..75ff47c73486 100644
--- a/basic/source/runtime/runtime.cxx
+++ b/basic/source/runtime/runtime.cxx
@@ -43,6 +43,7 @@
 #include <comphelper/processfactory.hxx>
 #include <com/sun/star/container/XEnumerationAccess.hpp>
 #include "sbunoobj.hxx"
+#include "errobject.hxx"
 
 bool SbiRuntime::isVBAEnabled()
 {
@@ -794,7 +795,38 @@ BOOL SbiRuntime::Step()
 void SbiRuntime::Error( SbError n )
 {
     if( n )
+    {
         nError = n;
+        if ( isVBAEnabled() )
+        {
+            String aMsg = pInst->GetErrorMsg();
+            // If a message is defined use that ( in preference to
+            // the defined one for the error ) NB #TODO
+            // if there is an error defined it more than likely
+            // is not the one you want ( some are the same though )
+            // we really need a new vba compatible error list
+            if ( !aMsg.Len() )
+            {
+                StarBASIC::MakeErrorText( n, aMsg );
+                aMsg =  StarBASIC::GetErrorText();
+                if ( !aMsg.Len() ) // no message for err no.
+                    // need localized resource here
+                    aMsg = String( RTL_CONSTASCII_USTRINGPARAM("Internal Object Error:") );
+            }
+            // no num? most likely then it *is* really a vba err
+            SbxErrObject::getUnoErrObject()->setNumber( ( StarBASIC::GetVBErrorCode( n ) == 0 ) ? n : StarBASIC::GetVBErrorCode( n ) );
+            SbxErrObject::getUnoErrObject()->setDescription( aMsg );
+
+            // prepend an error number to the message.
+            String aTmp = '\'';
+                        aTmp += String::CreateFromInt32( SbxErrObject::getUnoErrObject()->getNumber() );
+                        aTmp += String( RTL_CONSTASCII_USTRINGPARAM("\'\n") );
+                        aTmp += aMsg;
+
+            pInst->aErrorMsg = aTmp;
+            nError = SbERR_BASIC_COMPAT;
+        }
+    }
 }
 
 void SbiRuntime::Error( SbError _errCode, const String& _details )
diff --git a/basic/source/runtime/stdobj.cxx b/basic/source/runtime/stdobj.cxx
index c0b4ffa3cd59..d2585501c826 100644
--- a/basic/source/runtime/stdobj.cxx
+++ b/basic/source/runtime/stdobj.cxx
@@ -33,6 +33,7 @@
 #include <basic/sbstdobj.hxx>
 #include "rtlproto.hxx"
 #include "sbintern.hxx"
+#include "errobject.hxx"
 
 // Das nArgs-Feld eines Tabelleneintrags ist wie folgt verschluesselt:
 // Zur Zeit wird davon ausgegangen, dass Properties keine Parameter
@@ -652,6 +653,11 @@ SbiStdObject::~SbiStdObject()
 
 SbxVariable* SbiStdObject::Find( const String& rName, SbxClassType t )
 {
+    // #TODO #FIXME hack for substituting ooo-basic Err with vba-ish
+    // ErrObject object
+    static String sErr( RTL_CONSTASCII_USTRINGPARAM("Err") );
+    if (  rName.EqualsIgnoreCaseAscii( sErr ) )
+        return SbxErrObject::getErrObject();
     // Bereits eingetragen?
     SbxVariable* pVar = SbxObject::Find( rName, t );
     if( !pVar )
diff --git a/basic/source/runtime/step0.cxx b/basic/source/runtime/step0.cxx
index 33df854a4499..b432d1851ed5 100644
--- a/basic/source/runtime/step0.cxx
+++ b/basic/source/runtime/step0.cxx
@@ -30,6 +30,7 @@
 #include <vcl/msgbox.hxx>
 #include <tools/fsys.hxx>
 
+#include "errobject.hxx"
 #include "runtime.hxx"
 #include "sbintern.hxx"
 #include "iosys.hxx"
@@ -1116,6 +1117,7 @@ void SbiRuntime::StepSTDERROR()
     pInst->nErr = 0L;
     pInst->nErl = 0;
     nError = 0L;
+    SbxErrObject::getUnoErrObject()->Clear();
 }
 
 void SbiRuntime::StepNOERROR()
@@ -1124,6 +1126,7 @@ void SbiRuntime::StepNOERROR()
     pInst->nErr = 0L;
     pInst->nErl = 0;
     nError = 0L;
+    SbxErrObject::getUnoErrObject()->Clear();
     bError = FALSE;
 }
 
@@ -1132,6 +1135,9 @@ void SbiRuntime::StepNOERROR()
 void SbiRuntime::StepLEAVE()
 {
     bRun = FALSE;
+        // If VBA and we are leaving an ErrorHandler then clear the error ( it's been processed )
+    if ( bInError && pError )
+        SbxErrObject::getUnoErrObject()->Clear();
 }
 
 void SbiRuntime::StepCHANNEL()      // TOS = Kanalnummer
@@ -1265,6 +1271,6 @@ void SbiRuntime::StepERROR()
     SbxVariableRef refCode = PopVar();
     USHORT n = refCode->GetUShort();
     SbError error = StarBASIC::GetSfxFromVBError( n );
-    Error( error );
+    pInst->Error( error );
 }
 
diff --git a/basic/source/runtime/step1.cxx b/basic/source/runtime/step1.cxx
index 399257cf6ad3..2161f3d1dd09 100644
--- a/basic/source/runtime/step1.cxx
+++ b/basic/source/runtime/step1.cxx
@@ -35,6 +35,7 @@
 #include "iosys.hxx"
 #include "image.hxx"
 #include "sbunoobj.hxx"
+#include "errobject.hxx"
 
 bool checkUnoObjectType( SbUnoObject* refVal,
     const String& aClass );
@@ -360,6 +361,7 @@ void SbiRuntime::StepERRHDL( UINT32 nOp1 )
     pInst->nErr = 0;
     pInst->nErl = 0;
     nError = 0;
+    SbxErrObject::getUnoErrObject()->Clear();
 }
 
 // Resume nach Fehlern (+0=statement, 1=next or Label)
@@ -380,6 +382,8 @@ void SbiRuntime::StepRESUME( UINT32 nOp1 )
     }
     else
         pCode = pErrStmnt;
+    if ( pError ) // current in error handler ( and got a Resume Next statment )
+        SbxErrObject::getUnoErrObject()->Clear();
 
     if( nOp1 > 1 )
         StepJUMP( nOp1 );