[Runtime] OleAutoObject:NoMethod now also takes into account difference between Vulcan and VO

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

USING System.Diagnostics
USING System.Reflection
USING System.Runtime.Remoting
USING System.Runtime.InteropServices
USING System.Runtime.CompilerServices

/// VO Compatible OLE Automation class
[DebuggerDisplay( "Type= {__ComObject}", Type := "OleAutoObject" )];
CLASS XSharp.OleAutoObject
	PROTECTED oComObject AS OBJECT
	PROTECTED lOk        AS LOGIC
	PROTECTED _liFuncs   AS LONG
	PROTECTED _liVars    AS LONG
	PROTECTED oType      AS System.Type
	PROTECTED lDateTimeAsDate   AS LOGIC

	#region Constructors
	INTERNAL CONSTRUCTOR
		_liFuncs                := _liVars := -1
		lOk                     := FALSE
		oComObject              := NULL
		oType                   := NULL
		SELF:lDateTimeAsDate    := OleDateTimeAsDate()
		RETURN

   /// Construct an OleAutoObject
	CONSTRUCTOR(cProgId AS STRING)
		SELF()
		oComObject        := OleCreateObject(cProgId)
		lOk := oComObject != NULL
		IF lOk
			oType := oComObject:GetType()
		ENDIF

		RETURN

   /// Construct an OleAutoObject
	CONSTRUCTOR(cProgId AS STRING, fRotCheck AS LOGIC)
		SELF()
		IF fRotCheck
			oComObject := OleGetObject(cProgId)
		ENDIF
		IF oComObject == NULL
			oComObject := OleCreateObject(cProgId)
		ENDIF
		lOk := oComObject != NULL
		IF lOk
			oType := oComObject:GetType()
		ENDIF
		RETURN

	// Builds an OleAutoObject on Any OBJECT (including another AutoObject)
   /// Construct an OleAutoObject
	CONSTRUCTOR(oObject AS OBJECT)
		SELF()
		oComObject :=  OleUnWrapObject(oObject)
		lOk := oComObject != NULL
		IF lOk
			oType := oComObject:GetType()
		ENDIF

		RETURN

		// Builds an OleAutoObject on Any OBJECT (including another AutoObject). Type already known
   /// Construct an OleAutoObject
	CONSTRUCTOR(oObject AS OBJECT, _type AS System.Type)
		SELF()
		oComObject	:=  OleUnWrapObject(oObject)
		oType		:= _Type
		lOk			:= oComObject != NULL
		RETURN

	#endregion

	#region No..() EntryPoints

	// ? oObject:Property
	    /// <exclude />
    METHOD NoIVarGet(cName ) AS USUAL CLIPPER
		LOCAL oRet AS OBJECT
		oRet := OleAutoObject.__OleIvarGet(oComObject,oType, cName, NULL)
		RETURN OleAutoObject.OleWrapObject(oRet, lDateTimeAsDate)

		// oObject:Property := Value
	    /// <exclude />
	METHOD NoIvarPut(cName, uValue) AS VOID CLIPPER
		OleAutoObject.__OleIVarPut(oComObject, oType, cName , uValue, NULL)
		RETURN

	    /// <exclude />
	METHOD NoMethod( ) AS USUAL CLIPPER
		LOCAL cName AS STRING
		LOCAL args  AS USUAL[]
		LOCAL nArg, nArgs  AS INT
		LOCAL oRet  AS OBJECT
		nArgs := PCOUNT()
        IF RuntimeState.Dialect == XSharpDialect.Vulcan
		    cName := NoMethod()
		    args  := USUAL[]{nArgs-1}
		    FOR nArg := 2 TO nArgs
			    args[nArg-1] :=  _GetMParam(nArg)
            NEXT
        ELSE
		    cName := NoMethod()
		    args  := USUAL[]{nArgs}
		    FOR nArg := 1 TO nArgs
			    args[nArg] :=  _GetMParam(nArg)
            NEXT
        ENDIF
		oRet := OleAutoObject.OleSend(oComObject, oType, cName, args)

		RETURN OleAutoObject.OleWrapObject(oRet, lDateTimeAsDate)

	// ? oObject:Property[dims]
	// The compiler needs to be changed to look for this method
	    /// <exclude />
	METHOD NoIVarGetCollection(cName AS STRING, dims AS USUAL[]) AS USUAL
		LOCAL oRet AS OBJECT
		oRet := OleAutoObject.OleIvarGet(oComObject, cName, dims)
		RETURN OleAutoObject.OleWrapObject(oRet, lDateTimeAsDate)

	// ? oObject:Property[dims] := Value
	// The compiler needs to be changed to look for this method
	    /// <exclude />
	METHOD NoIVarPutCollection(cName AS STRING, uValue AS USUAL, dims AS USUAL[]) AS VOID
		OleAutoObject.OleIVarPut(oComObject, cName, uValue , dims )
		RETURN
	#endregion

	#region VO Compatibility Accesses
	    /// <exclude />

	ACCESS dwFuncs  AS LONG
		IF (lOk)
			LOCAL t AS System.Type
			IF (_liFuncs < 0)
				t := oComObject:GetType()
				_liFuncs := t:GetMethods():Length
			ENDIF
			RETURN _liFuncs
		ENDIF
		RETURN 0

	ASSIGN dwFuncs(dwNew AS LONG)
		SELF:_liFuncs := dwNew
		RETURN

	    /// <exclude />
	ACCESS dwVars   AS LONG
		IF (lOk)
			LOCAL t AS System.Type
			IF (_liVars < 0)
				t := oComObject:GetType()
				_liVars := t:GetProperties():Length
			ENDIF
			RETURN _liVars
		ENDIF
		RETURN 0

	    /// <exclude />
	ACCESS fInit    AS LOGIC
		RETURN lOk

	#endregion

	#region	INTERNAL Properties

	// Access to OBJECT inside AutoObject
    /// <exclude />

    ACCESS __ComObject AS OBJECT
		RETURN SELF:oComObject

	#endregion

	#region STATIC Methods
	    /// <exclude />
	STATIC METHOD OleCreateObject(cProgId AS STRING) AS OBJECT
		LOCAL oComObject := NULL AS OBJECT
		LOCAL objecttype AS System.Type
		TRY
			objecttype        := System.Type.GetTypeFromProgID(cProgId, FALSE)
			IF objecttype != NULL
				oComObject        := System.Activator.CreateInstance (objecttype)
			ENDIF
		CATCH AS Exception
			// We catch the exception but do not process it
		END TRY
		RETURN oComObject

    /// <exclude />
	STATIC METHOD  OleGetObject(cProgId AS STRING) AS OBJECT
		LOCAL oComObject AS OBJECT
		TRY
			oComObject := Marshal.GetActiveObject(cProgId)
		CATCH AS Exception
			oComObject := NULL
		END TRY
		RETURN oComObject

	#region Wrapping Objects
    /// <exclude />
    STATIC METHOD  OleWrapObject(oObject AS OBJECT,lDateTimeAsDate AS LOGIC) AS USUAL
		LOCAL t  AS System.Type
		LOCAL tc  AS System.TypeCode
		LOCAL oDt AS OleDateTime
		LOCAL uResult := NIL AS USUAL
		IF (oObject != NULL)
			t := oObject:GetType()
			tc := Type.GetTypeCode(t)
			IF tc == TypeCode.DateTime
				IF (lDateTimeAsDate)
					LOCAL oD AS System.DateTime
					oD := (System.DateTime)oObject
					uResult := XSharp.__Date{oD}
				ELSE
					oDt := (DateTime) oObject
					uResult := oDT
				ENDIF
			ELSE
				IF t:IsCOMObject
					uResult := OleAutoObject{oObject,t}
				ELSE
					uResult := oObject
				ENDIF
			ENDIF
		ENDIF
		RETURN uResult

    /// <exclude />
	STATIC METHOD  OleUnWrapObject(oObject AS OBJECT) AS OBJECT
		LOCAL oAuto AS OleAutoObject
		IF oObject != NULL
			IF oObject IS OleAutoObject
				oAuto := (OleAutoObject) oObject
				oObject := oAuto:__ComObject
			ENDIF
		ENDIF
		RETURN oObject

	#endregion

	#region OBJECT Properties

    /// <exclude />
	STATIC METHOD  OleIvarGet(oObject AS OBJECT,strName AS STRING) AS OBJECT
		RETURN OleAutoObject.__OleIvarGet(oObject, oObject:GetType(), strName, NULL)

    /// <exclude />
	STATIC METHOD  OleIvarGet(oObject AS OBJECT, symName AS STRING, dims  AS USUAL[]) AS OBJECT
		RETURN OleAutoObject.__OleIvarGet(oObject, oObject:GetType(), symName, dims)

    /// <exclude />
	STATIC METHOD  OleIvarGet(oObject AS OBJECT, symName AS STRING, index  AS USUAL) AS OBJECT
		LOCAL dims AS USUAL[]
		dims := USUAL[]{1}
		dims[1] := index
		RETURN OleAutoObject.__OleIvarGet(oObject, oObject:GetType(), symName, dims)

    /// <exclude />
	STATIC METHOD  OleIVarPut(oObject AS OBJECT, symName AS STRING, uValue AS USUAL) AS VOID
		OleAutoObject.__OleIVarPut(oObject, oObject:GetType(), symName, uValue, NULL)
		RETURN

    /// <exclude />
	STATIC METHOD  OleIVarPut(oObject AS OBJECT, symName AS STRING, uValue AS USUAL, dims AS USUAL[]) AS VOID
		OleAutoObject.__OleIVarPut(oObject, oObject:GetType(), symName, uValue, dims)
		RETURN

    /// <exclude />
	STATIC METHOD  OleIVarPut(oObject AS OBJECT, symName AS STRING, uValue AS USUAL, index AS USUAL) AS VOID
		LOCAL dims AS USUAL[]
		dims := USUAL[]{1}
		dims[1] := index
		OleAutoObject.__OleIVarPut(oObject, oObject:GetType(), symName, uValue, dims)
		RETURN

	#endregion

	#region Worker Functions

    /// <exclude />
	STATIC METHOD  __OleIvarGet(oComObject AS OBJECT, oType AS System.Type, cName AS STRING, dims AS USUAL[]) AS OBJECT
		LOCAL fi       AS FieldInfo
		LOCAL oRet     AS OBJECT
		LOCAL t        AS System.Type
		LOCAL lIndexed AS LOGIC
		LOCAL cMethod  AS STRING
		LOCAL bf AS BindingFlags

		cMethod := __ENTITY__
		IF oComObject == NULL
			THROW Error.NullArgumentError( cMethod, "oComObject", 1 )
		ENDIF
		lIndexed := (dims != NULL)
		t  := oType
		oComObject := OleUnWrapObject( oComObject )
		bf := BindingFlags.FlattenHierarchy | BindingFlags.GetField | ;
		BindingFlags.IgnoreCase | BindingFlags.GetProperty |  BindingFlags.Instance | BindingFlags.Public ;

		fi :=t:GetField( cName, bf )

		IF fi != NULL
			IF ! fi:IsPublic
				THROW Error.VOError( EG_NOVARMETHOD,  cMethod, "cMethod", 2,  <OBJECT>{cName } )
			ELSE
				oRet := fi:GetValue( oComObject )
			ENDIF
		ELSE
			IF lIndexed

				LOCAL oArgs AS OBJECT[]
				LOCAL i     AS INT
				oArgs := OBJECT[]{dims:Length }
				FOR i := 1 UPTO dims:Length
					oArgs[i] :=  OleUnWrapObject(dims[i])
				NEXT
				oRet := oType:InvokeMember(cName,bf ,NULL, oComObject,oArgs)
			ELSE
				oRet := oType:InvokeMember(cName, bf,NULL, oComObject, NULL)
			ENDIF
		ENDIF
		RETURN oRet

		#endregion

#region Putting OBJECT Properties

    /// <exclude />
STATIC METHOD  __OleIVarPut(oComObject AS OBJECT, oType AS System.Type, cName AS STRING, uValue AS USUAL, dims AS USUAL[]) AS VOID
	LOCAL t        AS System.Type
	LOCAL fi       AS FieldInfo
	LOCAL lIndexed AS LOGIC
	LOCAL cMethod  AS STRING
	cMethod := __ENTITY__

	IF oComObject == NULL
		THROW Error.NullArgumentError( cMethod, NAMEOF(oComObject), 1 )
	ENDIF

	// Get the inner OBJECT from OleAutoObjects
	// For both the Target and the value
	oComObject  := OleUnWrapObject( oComObject)
	uValue      := OleUnWrapObject( uValue )

	t := oType

	lIndexed := (dims != NULL)

	fi := t:GetField( cName, BindingFlags.Instance | BindingFlags.Public | BindingFlags.IgnoreCase  )

	IF fi != NULL
		fi:SetValue( oComObject, uValue )
	ELSE
		LOCAL bf      AS BindingFlags
		LOCAL oArgs   AS OBJECT[]
		bf := BindingFlags.FlattenHierarchy | BindingFlags.SetField | ;
		BindingFlags.IgnoreCase | BindingFlags.SetProperty
		IF lIndexed
			LOCAL i     AS INT
			oArgs := OBJECT[]{dims:Length+1 }
			FOR i := 1 UPTO dims:Length
				oArgs[i+1] := OleUnWrapObject(dims[i])
			NEXT
		ELSE
			oArgs := OBJECT[]{1 }
		ENDIF
		oArgs[1] := uValue
		TRY
			oType:InvokeMember(cName, bf,NULL, oComObject, oArgs)
			CATCH e AS Exception
			THROW e
		END TRY

	ENDIF

	RETURN

	#endregion
    /// <exclude />

STATIC METHOD  OleSend(oComObject AS OBJECT, oType AS System.Type, cName AS STRING, args AS USUAL[]) AS OBJECT
	LOCAL mi       AS MethodInfo
	LOCAL pi       AS ParameterInfo[]
	LOCAL t        AS Type
	LOCAL cMethod  AS STRING
	LOCAL x        AS INT
	LOCAL bf       AS BindingFlags

	LOCAL retval := NULL AS OBJECT
	cMethod  := __ENTITY__

	IF oComObject == NULL
		THROW Error.NullArgumentError( __ENTITY__, NAMEOF(oComObject), 1 )
	ENDIF
	t  :=oType
	oComObject := OleUnWrapObject(oComObject)
	bf :=  BindingFlags.Instance | BindingFlags.Public | BindingFlags.FlattenHierarchy| BindingFlags.InvokeMethod |  BindingFlags.IgnoreCase

	TRY
		mi := t:GetMethod( cName, bf)
		IF mi == NULL
			mi := t:GetMethod( cName)
		ENDIF

		IF mi == NULL
			// Ok we know nothing, just try to Invoke the method
			TRY

				VAR oArgs1 := OBJECT[] {args:Length} // Array of arguments for call to Invoke
				FOR x := 1 UPTO args:Length
					oArgs1[x] := OleUnWrapObject(args[x])
				NEXT
				retval := t:InvokeMember(cName, bf, NULL, oComObject, oArgs1)
			CATCH AS ArgumentException
				THROW Error.VOError(EG_ARG,  cMethod,"args", 4, <OBJECT>{args} )
			CATCH AS TargetException
				THROW Error.VOError(EG_ARG,  cMethod, "args", 4, <OBJECT>{args})
			CATCH AS MissingMethodException
				THROW Error.VOError(EG_NOMETHOD,  cMethod, "cName", 2,  <OBJECT>{cName}  )
			CATCH AS Exception
				THROW Error.VOError( EG_ARG , cMethod, "args", 4,  <OBJECT>{args}  )
			END TRY
		ELSE
			pi := mi:GetParameters()
			IF pi:Length == 1 .AND. mi:IsDefined( TYPEOF( XSharp.Internal.ClipperCallingConventionAttribute ), FALSE )
				retval := mi:Invoke(oComObject, <OBJECT>{args})
			ELSEIF pi:Length == 0
				retval := mi:Invoke(oComObject, NULL )
			ELSE
				LOCAL nArgs          AS INT   // # of arguments passed in
				LOCAL pArg           AS USUAL PTR   // This is used to derefence arguments
				LOCAL nLastUnNamed   AS INT  // Last unnamed argument passed in
				LOCAL lFound         AS LOGIC // Was the Named Arg Found

				VAR nDefArgs := pi:Length			// # of arguments defined for method
				VAR oArgs := OBJECT[]{ nDefArgs }	// Array of arguments for call to Invoke
				IF args != NULL
					nArgs := args:Length
					nArgs := Math.Min( nArgs, nDefArgs )
				ELSE
					nArgs := 0
				ENDIF
				nLastUnNamed := nArgs
				FOR x := 1 UPTO nArgs
					VAR oArg := OleUnWrapObject(args[x])

					IF IsPtr(oArg)
						// By Reference ?
						pArg     := Usual{oArg}
						oArgs[x] := pArg[1]

					ELSEIF oArg IS NamedArg
						// Named Argument ?
						nLastUnNamed:= Math.Min( x - 1, nLastUnNamed )
						VAR oNamedArg   := (NamedArg) oArg
						VAR cArgName    := oNamedArg:ArgName
						lFound      := FALSE
						FOR VAR y := 1 TO  nDefArgs
							VAR paramInfo := pi[y]
							IF String.Compare( paramInfo:Name, cArgName, StringComparison.OrdinalIgnoreCase ) == 0
								oArgs[y] := oNamedArg:Value
								lFound   := TRUE
								EXIT
							ENDIF
						NEXT
						IF ! lFound
							THROW Error.VOError(EG_ARG,  cMethod, cArgName, (DWORD) x, <OBJECT>{oNamedArg} )
						ENDIF

					ELSE
						// Normal argument
						oArgs[x] := oArg
					ENDIF
				NEXT
				// Fill in missing method parameter values
				// nLastUnNamed has # of last unnamed argument
				FOR x :=nLastUnNamed+1 TO nDefArgs
					IF oArgs[x] == NULL
						// When no value, fill in the default
						VAR paramInfo := pi[x]
						oArgs[x] := paramInfo:DefaultValue
					ENDIF
				NEXT
				LOCAL lOk AS LOGIC
				// Try MethodInfo:Invoke first.
				TRY
					retval := mi:Invoke(oComObject, oArgs)
					lOk := TRUE
					// return Out parameters
					FOR x := 1 TO nArgs
						VAR paramInfo := pi[x]
						IF paramInfo:Attributes:HasFlag( ParameterAttributes.Out)
							IF IsPtr(args[x])
								pArg := args[x]
								pArg[1] := oArgs[x]
							ENDIF
						ENDIF
					NEXT
				CATCH AS Exception
					lOk := FALSE
				END TRY
				// If that fails we try t:InvokeMember. You never know if that will work...
				IF ! lOk
					TRY
						retval := t:InvokeMember(cName, bf, NULL, oComObject, oArgs)
						lOk    := TRUE
					CATCH AS ArgumentException
						THROW Error.VOError(EG_ARG,  cMethod, cMethod, 1, <OBJECT>{args})
						lOk := FALSE
					CATCH AS TargetException
						THROW Error.VOError(EG_ARG,  cMethod, cMethod, 1, <OBJECT>{args} )
						lOk := FALSE
					CATCH AS MissingMethodException
						THROW Error.VOError(EG_NOMETHOD,  cMethod, "cName", 2, <OBJECT>{cName}  )
						lOk := FALSE
					CATCH AS Exception
						lOk := FALSE
					END TRY
				ENDIF
				IF ! lOk
					THROW Error.VOError(EG_ARG,  cMethod, cMethod, 1, <OBJECT>{args}  )
				ENDIF
			ENDIF
		ENDIF
	CATCH AS AmbiguousMatchException
		THROW Error.VOError( EG_AMBIGUOUSMETHOD,  cMethod, "cMethod", 2, <OBJECT>{cMethod} )
	END TRY
	RETURN retval
	#endregion

END CLASS

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

USING System.Diagnostics
USING System.Reflection
USING System.Runtime.Remoting
USING System.Runtime.InteropServices
USING System.Runtime.CompilerServices

/// VO Compatible OLE Automation class
[DebuggerDisplay( "Type= {__ComObject}", Type := "OleAutoObject" )];
CLASS XSharp.OleAutoObject
	PROTECTED oComObject AS OBJECT
	PROTECTED lOk        AS LOGIC
	PROTECTED _liFuncs   AS LONG
	PROTECTED _liVars    AS LONG
	PROTECTED oType      AS System.Type
	PROTECTED lDateTimeAsDate   AS LOGIC

	#region Constructors
	INTERNAL CONSTRUCTOR
		_liFuncs                := _liVars := -1
		lOk                     := FALSE
		oComObject              := NULL
		oType                   := NULL
		SELF:lDateTimeAsDate    := OleDateTimeAsDate()
		RETURN

   /// Construct an OleAutoObject
	CONSTRUCTOR(cProgId AS STRING)
		SELF()
		oComObject        := OleCreateObject(cProgId)
		lOk := oComObject != NULL
		IF lOk
			oType := oComObject:GetType()
		ENDIF

		RETURN

   /// Construct an OleAutoObject
	CONSTRUCTOR(cProgId AS STRING, fRotCheck AS LOGIC)
		SELF()
		IF fRotCheck
			oComObject := OleGetObject(cProgId)
		ENDIF
		IF oComObject == NULL
			oComObject := OleCreateObject(cProgId)
		ENDIF
		lOk := oComObject != NULL
		IF lOk
			oType := oComObject:GetType()
		ENDIF
		RETURN

	// Builds an OleAutoObject on Any OBJECT (including another AutoObject)
   /// Construct an OleAutoObject
	CONSTRUCTOR(oObject AS OBJECT)
		SELF()
		oComObject :=  OleUnWrapObject(oObject)
		lOk := oComObject != NULL
		IF lOk
			oType := oComObject:GetType()
		ENDIF

		RETURN

		// Builds an OleAutoObject on Any OBJECT (including another AutoObject). Type already known
   /// Construct an OleAutoObject
	CONSTRUCTOR(oObject AS OBJECT, _type AS System.Type)
		SELF()
		oComObject	:=  OleUnWrapObject(oObject)
		oType		:= _Type
		lOk			:= oComObject != NULL
		RETURN

	#endregion

	#region No..() EntryPoints

	// ? oObject:Property
	    /// <exclude />
    METHOD NoIVarGet(cName ) AS USUAL CLIPPER
		LOCAL oRet AS OBJECT
		oRet := OleAutoObject.__OleIvarGet(oComObject,oType, cName, NULL)
		RETURN OleAutoObject.OleWrapObject(oRet, lDateTimeAsDate)

		// oObject:Property := Value
	    /// <exclude />
	METHOD NoIvarPut(cName, uValue) AS VOID CLIPPER
		OleAutoObject.__OleIVarPut(oComObject, oType, cName , uValue, NULL)
		RETURN

	    /// <exclude />
	METHOD NoMethod( ) AS USUAL CLIPPER
		LOCAL cName AS STRING
		LOCAL args  AS USUAL[]
		LOCAL nArg, nArgs  AS INT
		LOCAL oRet  AS OBJECT
		nArgs := PCOUNT()
		IF (nArgs >= 1)
			cName := _GetMParam(1)
			args  := USUAL[]{nArgs-1}
			FOR nArg := 2 TO nArgs
				args[nArg-1] :=  _GetMParam(nArg)
			NEXT
		ELSE
			// Throw Exception
			THROW Error.VOError(EG_SEND_MISSINGARG, "OleAutoObject:NoMethod","Send",0,NULL )
		ENDIF
		oRet := OleAutoObject.OleSend(oComObject, oType, cName, args)

		RETURN OleAutoObject.OleWrapObject(oRet, lDateTimeAsDate)

	// ? oObject:Property[dims]
	// The compiler needs to be changed to look for this method
	    /// <exclude />
	METHOD NoIVarGetCollection(cName AS STRING, dims AS USUAL[]) AS USUAL
		LOCAL oRet AS OBJECT
		oRet := OleAutoObject.OleIvarGet(oComObject, cName, dims)
		RETURN OleAutoObject.OleWrapObject(oRet, lDateTimeAsDate)

	// ? oObject:Property[dims] := Value
	// The compiler needs to be changed to look for this method
	    /// <exclude />
	METHOD NoIVarPutCollection(cName AS STRING, uValue AS USUAL, dims AS USUAL[]) AS VOID
		OleAutoObject.OleIVarPut(oComObject, cName, uValue , dims )
		RETURN
	#endregion

	#region VO Compatibility Accesses
	    /// <exclude />

	ACCESS dwFuncs  AS LONG
		IF (lOk)
			LOCAL t AS System.Type
			IF (_liFuncs < 0)
				t := oComObject:GetType()
				_liFuncs := t:GetMethods():Length
			ENDIF
			RETURN _liFuncs
		ENDIF
		RETURN 0

	ASSIGN dwFuncs(dwNew AS LONG)
		SELF:_liFuncs := dwNew
		RETURN

	    /// <exclude />
	ACCESS dwVars   AS LONG
		IF (lOk)
			LOCAL t AS System.Type
			IF (_liVars < 0)
				t := oComObject:GetType()
				_liVars := t:GetProperties():Length
			ENDIF
			RETURN _liVars
		ENDIF
		RETURN 0

	    /// <exclude />
	ACCESS fInit    AS LOGIC
		RETURN lOk

	#endregion

	#region	INTERNAL Properties

	// Access to OBJECT inside AutoObject
    /// <exclude />

    ACCESS __ComObject AS OBJECT
		RETURN SELF:oComObject

	#endregion

	#region STATIC Methods
	    /// <exclude />
	STATIC METHOD OleCreateObject(cProgId AS STRING) AS OBJECT
		LOCAL oComObject := NULL AS OBJECT
		LOCAL objecttype AS System.Type
		TRY
			objecttype        := System.Type.GetTypeFromProgID(cProgId, FALSE)
			IF objecttype != NULL
				oComObject        := System.Activator.CreateInstance (objecttype)
			ENDIF
		CATCH AS Exception
			// We catch the exception but do not process it
		END TRY
		RETURN oComObject

    /// <exclude />
	STATIC METHOD  OleGetObject(cProgId AS STRING) AS OBJECT
		LOCAL oComObject AS OBJECT
		TRY
			oComObject := Marshal.GetActiveObject(cProgId)
		CATCH AS Exception
			oComObject := NULL
		END TRY
		RETURN oComObject

	#region Wrapping Objects
    /// <exclude />
    STATIC METHOD  OleWrapObject(oObject AS OBJECT,lDateTimeAsDate AS LOGIC) AS USUAL
		LOCAL t  AS System.Type
		LOCAL tc  AS System.TypeCode
		LOCAL oDt AS OleDateTime
		LOCAL uResult := NIL AS USUAL
		IF (oObject != NULL)
			t := oObject:GetType()
			tc := Type.GetTypeCode(t)
			IF tc == TypeCode.DateTime
				IF (lDateTimeAsDate)
					LOCAL oD AS System.DateTime
					oD := (System.DateTime)oObject
					uResult := XSharp.__Date{oD}
				ELSE
					oDt := (DateTime) oObject
					uResult := oDT
				ENDIF
			ELSE
				IF t:IsCOMObject
					uResult := OleAutoObject{oObject,t}
				ELSE
					uResult := oObject
				ENDIF
			ENDIF
		ENDIF
		RETURN uResult

    /// <exclude />
	STATIC METHOD  OleUnWrapObject(oObject AS OBJECT) AS OBJECT
		LOCAL oAuto AS OleAutoObject
		IF oObject != NULL
			IF oObject IS OleAutoObject
				oAuto := (OleAutoObject) oObject
				oObject := oAuto:__ComObject
			ENDIF
		ENDIF
		RETURN oObject

	#endregion

	#region OBJECT Properties

    /// <exclude />
	STATIC METHOD  OleIvarGet(oObject AS OBJECT,strName AS STRING) AS OBJECT
		RETURN OleAutoObject.__OleIvarGet(oObject, oObject:GetType(), strName, NULL)

    /// <exclude />
	STATIC METHOD  OleIvarGet(oObject AS OBJECT, symName AS STRING, dims  AS USUAL[]) AS OBJECT
		RETURN OleAutoObject.__OleIvarGet(oObject, oObject:GetType(), symName, dims)

    /// <exclude />
	STATIC METHOD  OleIvarGet(oObject AS OBJECT, symName AS STRING, index  AS USUAL) AS OBJECT
		LOCAL dims AS USUAL[]
		dims := USUAL[]{1}
		dims[1] := index
		RETURN OleAutoObject.__OleIvarGet(oObject, oObject:GetType(), symName, dims)

    /// <exclude />
	STATIC METHOD  OleIVarPut(oObject AS OBJECT, symName AS STRING, uValue AS USUAL) AS VOID
		OleAutoObject.__OleIVarPut(oObject, oObject:GetType(), symName, uValue, NULL)
		RETURN

    /// <exclude />
	STATIC METHOD  OleIVarPut(oObject AS OBJECT, symName AS STRING, uValue AS USUAL, dims AS USUAL[]) AS VOID
		OleAutoObject.__OleIVarPut(oObject, oObject:GetType(), symName, uValue, dims)
		RETURN

    /// <exclude />
	STATIC METHOD  OleIVarPut(oObject AS OBJECT, symName AS STRING, uValue AS USUAL, index AS USUAL) AS VOID
		LOCAL dims AS USUAL[]
		dims := USUAL[]{1}
		dims[1] := index
		OleAutoObject.__OleIVarPut(oObject, oObject:GetType(), symName, uValue, dims)
		RETURN

	#endregion

	#region Worker Functions

    /// <exclude />
	STATIC METHOD  __OleIvarGet(oComObject AS OBJECT, oType AS System.Type, cName AS STRING, dims AS USUAL[]) AS OBJECT
		LOCAL fi       AS FieldInfo
		LOCAL oRet     AS OBJECT
		LOCAL t        AS System.Type
		LOCAL lIndexed AS LOGIC
		LOCAL cMethod  AS STRING
		LOCAL bf AS BindingFlags

		cMethod := __ENTITY__
		IF oComObject == NULL
			THROW Error.NullArgumentError( cMethod, "oComObject", 1 )
		ENDIF
		lIndexed := (dims != NULL)
		t  := oType
		oComObject := OleUnWrapObject( oComObject )
		bf := BindingFlags.FlattenHierarchy | BindingFlags.GetField | ;
		BindingFlags.IgnoreCase | BindingFlags.GetProperty |  BindingFlags.Instance | BindingFlags.Public ;

		fi :=t:GetField( cName, bf )

		IF fi != NULL
			IF ! fi:IsPublic
				THROW Error.VOError( EG_NOVARMETHOD,  cMethod, "cMethod", 2,  <OBJECT>{cName } )
			ELSE
				oRet := fi:GetValue( oComObject )
			ENDIF
		ELSE
			IF lIndexed

				LOCAL oArgs AS OBJECT[]
				LOCAL i     AS INT
				oArgs := OBJECT[]{dims:Length }
				FOR i := 1 UPTO dims:Length
					oArgs[i] :=  OleUnWrapObject(dims[i])
				NEXT
				oRet := oType:InvokeMember(cName,bf ,NULL, oComObject,oArgs)
			ELSE
				oRet := oType:InvokeMember(cName, bf,NULL, oComObject, NULL)
			ENDIF
		ENDIF
		RETURN oRet

		#endregion

#region Putting OBJECT Properties

    /// <exclude />
STATIC METHOD  __OleIVarPut(oComObject AS OBJECT, oType AS System.Type, cName AS STRING, uValue AS USUAL, dims AS USUAL[]) AS VOID
	LOCAL t        AS System.Type
	LOCAL fi       AS FieldInfo
	LOCAL lIndexed AS LOGIC
	LOCAL cMethod  AS STRING
	cMethod := __ENTITY__

	IF oComObject == NULL
		THROW Error.NullArgumentError( cMethod, NAMEOF(oComObject), 1 )
	ENDIF

	// Get the inner OBJECT from OleAutoObjects
	// For both the Target and the value
	oComObject  := OleUnWrapObject( oComObject)
	uValue      := OleUnWrapObject( uValue )

	t := oType

	lIndexed := (dims != NULL)

	fi := t:GetField( cName, BindingFlags.Instance | BindingFlags.Public | BindingFlags.IgnoreCase  )

	IF fi != NULL
		fi:SetValue( oComObject, uValue )
	ELSE
		LOCAL bf      AS BindingFlags
		LOCAL oArgs   AS OBJECT[]
		bf := BindingFlags.FlattenHierarchy | BindingFlags.SetField | ;
		BindingFlags.IgnoreCase | BindingFlags.SetProperty
		IF lIndexed
			LOCAL i     AS INT
			oArgs := OBJECT[]{dims:Length+1 }
			FOR i := 1 UPTO dims:Length
				oArgs[i+1] := OleUnWrapObject(dims[i])
			NEXT
		ELSE
			oArgs := OBJECT[]{1 }
		ENDIF
		oArgs[1] := uValue
		TRY
			oType:InvokeMember(cName, bf,NULL, oComObject, oArgs)
			CATCH e AS Exception
			THROW e
		END TRY

	ENDIF

	RETURN

	#endregion
    /// <exclude />

STATIC METHOD  OleSend(oComObject AS OBJECT, oType AS System.Type, cName AS STRING, args AS USUAL[]) AS OBJECT
	LOCAL mi       AS MethodInfo
	LOCAL pi       AS ParameterInfo[]
	LOCAL t        AS Type
	LOCAL cMethod  AS STRING
	LOCAL x        AS INT
	LOCAL bf       AS BindingFlags

	LOCAL retval := NULL AS OBJECT
	cMethod  := __ENTITY__

	IF oComObject == NULL
		THROW Error.NullArgumentError( __ENTITY__, NAMEOF(oComObject), 1 )
	ENDIF
	t  :=oType
	oComObject := OleUnWrapObject(oComObject)
	bf :=  BindingFlags.Instance | BindingFlags.Public | BindingFlags.FlattenHierarchy| BindingFlags.InvokeMethod |  BindingFlags.IgnoreCase

	TRY
		mi := t:GetMethod( cName, bf)
		IF mi == NULL
			mi := t:GetMethod( cName)
		ENDIF

		IF mi == NULL
			// Ok we know nothing, just try to Invoke the method
			TRY

				VAR oArgs1 := OBJECT[] {args:Length} // Array of arguments for call to Invoke
				FOR x := 1 UPTO args:Length
					oArgs1[x] := OleUnWrapObject(args[x])
				NEXT
				retval := t:InvokeMember(cName, bf, NULL, oComObject, oArgs1)
			CATCH AS ArgumentException
				THROW Error.VOError(EG_ARG,  cMethod,"args", 4, <OBJECT>{args} )
			CATCH AS TargetException
				THROW Error.VOError(EG_ARG,  cMethod, "args", 4, <OBJECT>{args})
			CATCH AS MissingMethodException
				THROW Error.VOError(EG_NOMETHOD,  cMethod, "cName", 2,  <OBJECT>{cName}  )
			CATCH AS Exception
				THROW Error.VOError( EG_ARG , cMethod, "args", 4,  <OBJECT>{args}  )
			END TRY
		ELSE
			pi := mi:GetParameters()
			IF pi:Length == 1 .AND. mi:IsDefined( TYPEOF( XSharp.Internal.ClipperCallingConventionAttribute ), FALSE )
				retval := mi:Invoke(oComObject, <OBJECT>{args})
			ELSEIF pi:Length == 0
				retval := mi:Invoke(oComObject, NULL )
			ELSE
				LOCAL nArgs          AS INT   // # of arguments passed in
				LOCAL pArg           AS USUAL PTR   // This is used to derefence arguments
				LOCAL nLastUnNamed   AS INT  // Last unnamed argument passed in
				LOCAL lFound         AS LOGIC // Was the Named Arg Found

				VAR nDefArgs := pi:Length			// # of arguments defined for method
				VAR oArgs := OBJECT[]{ nDefArgs }	// Array of arguments for call to Invoke
				IF args != NULL
					nArgs := args:Length
					nArgs := Math.Min( nArgs, nDefArgs )
				ELSE
					nArgs := 0
				ENDIF
				nLastUnNamed := nArgs
				FOR x := 1 UPTO nArgs
					VAR oArg := OleUnWrapObject(args[x])

					IF IsPtr(oArg)
						// By Reference ?
						pArg     := Usual{oArg}
						oArgs[x] := pArg[1]

					ELSEIF oArg IS NamedArg
						// Named Argument ?
						nLastUnNamed:= Math.Min( x - 1, nLastUnNamed )
						VAR oNamedArg   := (NamedArg) oArg
						VAR cArgName    := oNamedArg:ArgName
						lFound      := FALSE
						FOR VAR y := 1 TO  nDefArgs
							VAR paramInfo := pi[y]
							IF String.Compare( paramInfo:Name, cArgName, StringComparison.OrdinalIgnoreCase ) == 0
								oArgs[y] := oNamedArg:Value
								lFound   := TRUE
								EXIT
							ENDIF
						NEXT
						IF ! lFound
							THROW Error.VOError(EG_ARG,  cMethod, cArgName, (DWORD) x, <OBJECT>{oNamedArg} )
						ENDIF

					ELSE
						// Normal argument
						oArgs[x] := oArg
					ENDIF
				NEXT
				// Fill in missing method parameter values
				// nLastUnNamed has # of last unnamed argument
				FOR x :=nLastUnNamed+1 TO nDefArgs
					IF oArgs[x] == NULL
						// When no value, fill in the default
						VAR paramInfo := pi[x]
						oArgs[x] := paramInfo:DefaultValue
					ENDIF
				NEXT
				LOCAL lOk AS LOGIC
				// Try MethodInfo:Invoke first.
				TRY
					retval := mi:Invoke(oComObject, oArgs)
					lOk := TRUE
					// return Out parameters
					FOR x := 1 TO nArgs
						VAR paramInfo := pi[x]
						IF paramInfo:Attributes:HasFlag( ParameterAttributes.Out)
							IF IsPtr(args[x])
								pArg := args[x]
								pArg[1] := oArgs[x]
							ENDIF
						ENDIF
					NEXT
				CATCH AS Exception
					lOk := FALSE
				END TRY
				// If that fails we try t:InvokeMember. You never know if that will work...
				IF ! lOk
					TRY
						retval := t:InvokeMember(cName, bf, NULL, oComObject, oArgs)
						lOk    := TRUE
					CATCH AS ArgumentException
						THROW Error.VOError(EG_ARG,  cMethod, cMethod, 1, <OBJECT>{args})
						lOk := FALSE
					CATCH AS TargetException
						THROW Error.VOError(EG_ARG,  cMethod, cMethod, 1, <OBJECT>{args} )
						lOk := FALSE
					CATCH AS MissingMethodException
						THROW Error.VOError(EG_NOMETHOD,  cMethod, "cName", 2, <OBJECT>{cName}  )
						lOk := FALSE
					CATCH AS Exception
						lOk := FALSE
					END TRY
				ENDIF
				IF ! lOk
					THROW Error.VOError(EG_ARG,  cMethod, cMethod, 1, <OBJECT>{args}  )
				ENDIF
			ENDIF
		ENDIF
	CATCH AS AmbiguousMatchException
		THROW Error.VOError( EG_AMBIGUOUSMETHOD,  cMethod, "cMethod", 2, <OBJECT>{cMethod} )
	END TRY
	RETURN retval
	#endregion

END CLASS


clean up

clean up

-- This extended example is an Omega port of Conor McBride's First Order Unification by Structural Recursion
-- From the paper "GADTs + Extensible Kinds = Dependent Programming"

-------- MAYBE MONAD --------------------------------
return x = Just x
fail s = Nothing
bind Nothing g = Nothing
bind (Just x) g = g x
liftM :: (a -> b) -> Maybe a -> Maybe b
liftM2 :: (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
liftM f ma = do { a <- ma; return (f a) }
liftM2 f ma mb = do { a <- ma; b <- mb; return (f a b) }

------- FINITE (VARIABLE) SETS & TERMS --------------
data Fin:: Nat ~> *0 where
   Fz:: Fin (S m)
   Fs:: Fin m -> Fin (S m)

data Term n = Var(Fin n) | Leaf | Fork(Term n)(Term n)

------- SUBSTITUTIONS -------------------------------
rename2sub :: (Fin m -> Fin n) -> Fin m -> Term n
rename2sub f i = Var (f i)
subst :: (Fin m -> Term n) -> Term m -> Term n
subst sub (Var x) = sub x
subst sub Leaf = Leaf
subst sub (Fork s t) = Fork(subst sub s)(subst sub t)
compose :: (Fin m -> Term n) -> (Fin l -> Term m) -> (Fin l -> Term n)
compose f g i = subst f (g i)

------- OCCURS CHECK --------------------------------
thick :: Nat' n -> Fin (S n) -> Fin (S n) -> Maybe (Fin n)
thick n (Fz) (Fz) = Nothing
thick n (Fz) (Fs y) = Just y
thick (S n) (Fs x) (Fz) = Just Fz
thick (S n) (Fs x) (Fs y) = liftM Fs (thick n x y)

chk :: Nat' n -> Fin (S n) -> Term (S n) -> Maybe (Term n)
chk n x (Var y) = liftM Var (thick n x y)
chk n x (Leaf) = Just Leaf
chk n x (Fork s t) = liftM2 Fork(chk n x s)(chk n x t)
for :: Nat' n -> Term n -> Fin (S n) -> Fin (S n) -> Term n
for n t' x y = case thick n x y of
               Just y' -> Var y'
               Nothing -> t'

-----------------------------------------------------
-- substitution lists
data AList:: Nat ~> Nat ~> *0 where
   Anil:: AList n n
   Asnoc:: AList m' n -> Term m' -> Fin (S m') -> AList (S m') n

sub :: Nat' m -> AList m n -> (Fin m -> Term n)
sub _ (Anil) = Var
sub (S n) (Asnoc s t x) = compose(sub n s)(for n t x)
cat :: AList m n -> AList l m -> AList l n
cat xs (Anil) = xs
cat xs (Asnoc ys t x) = Asnoc (cat xs ys) t x

data SomeSub m = ex n. SomeSub (Nat' n) (AList m n)
asnoc :: SomeSub m -> Term m -> Fin (S m) -> SomeSub (S m)
asnoc (SomeSub m s) t x = SomeSub m (Asnoc s t x)

-----------------------------------------------------
-- unification
mgu :: Nat' m -> Term m -> Term m -> Maybe (SomeSub m)
mgu m s t = amgu m s t (SomeSub m Anil)

amgu :: Nat' m -> Term m -> Term m -> SomeSub m -> Maybe (SomeSub m)
amgu m (Leaf) (Leaf) acc = Just acc
amgu m (Leaf) (Fork s t) acc = Nothing
amgu m (Fork s t) (Leaf) acc = Nothing
amgu m (Fork s1 t1) (Fork s2 t2) acc =
     do { acc <- amgu m s1 t1 acc; amgu m s2 t2 acc }
amgu m (Var x) (Var y) (SomeSub _ Anil) = Just (flexFlex m x y)
amgu m (Var x) t (SomeSub _ Anil) = flexRigid m x t
amgu m s (Var x) (SomeSub _ Anil) = flexRigid m x s
amgu (S m) s t (SomeSub n (Asnoc sub r z)) =
     do sub <- amgu m (subst (for m r z) s) (subst (for m r z) t) (SomeSub n sub)
        return (asnoc sub r z)

flexFlex :: Nat' m -> Fin m -> Fin m -> SomeSub m
flexFlex (S m) x y = case thick m x y of
                     Just y' -> SomeSub m (Asnoc Anil (Var y') x)
                     Nothing -> SomeSub (S m) Anil

flexRigid :: Nat' m -> Fin m -> Term m -> Maybe (SomeSub m)
flexRigid (S m) x t = do
                      t' <- chk m x t
                      return (SomeSub m (Asnoc Anil t' x))

-- This extended example is an Omega port of Conor McBride's First Order Unification by Structural Recursion
-- From the paper "GADTs + Extensible Kinds = Dependent Programming"

-------- MAYBE MONAD --------------------------------
return x = Just x
fail s = Nothing
bind Nothing g = Nothing
bind (Just x) g = g x
liftM :: (a -> b) -> Maybe a -> Maybe b
liftM2 :: (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
liftM f ma = do { a <- ma; return (f a) }
liftM2 f ma mb = do { a <- ma; b <- mb; return (f a b) }

------- FINITE (VARIABLE) SETS & TERMS --------------
--data Fin n = ex m. Fz where n = S m
--           | ex m. Fs (Fin m) where n = S m
data Fin:: Nat ~> *0 where
   Fz:: forall m n . Fin (S m)
   Fs:: forall m n . Fin m -> Fin (S m)

data Term n = Var(Fin n) | Leaf | Fork(Term n)(Term n)

------- SUBSTITUTIONS -------------------------------
rename2sub :: (Fin m -> Fin n) -> Fin m -> Term n
rename2sub f i = Var (f i)
subst :: (Fin m -> Term n) -> Term m -> Term n
subst sub (Var x) = sub x
subst sub Leaf = Leaf
subst sub (Fork s t) = Fork(subst sub s)(subst sub t)
compose :: (Fin m -> Term n) -> (Fin l -> Term m) -> (Fin l -> Term n)
compose f g i = subst f (g i)

------- OCCURS CHECK --------------------------------
thick :: Nat' n -> Fin (S n) -> Fin (S n) -> Maybe (Fin n)
thick n (Fz) (Fz) = Nothing
thick n (Fz) (Fs y) = Just y
thick (S n) (Fs x) (Fz) = Just Fz
thick (S n) (Fs x) (Fs y) = liftM Fs (thick n x y)

chk :: Nat' n -> Fin (S n) -> Term (S n) -> Maybe (Term n)
chk n x (Var y) = liftM Var (thick n x y)
chk n x (Leaf) = Just Leaf
chk n x (Fork s t) = liftM2 Fork(chk n x s)(chk n x t)
for :: Nat' n -> Term n -> Fin (S n) -> Fin (S n) -> Term n
for n t' x y = case thick n x y of
               Just y' -> Var y'
               Nothing -> t'

-----------------------------------------------------
-- substitution lists
--data AList m n = Anil where m=n
--               | ex m'. Asnoc(AList m' n)(Term m')(Fin (S m')) where m = S m'
data AList:: (Nat ~> (Nat ~> *0)) where
   Anil:: forall m n . AList n n
   Asnoc::
      forall m' m n .
      AList m' n -> Term m' -> Fin (S m') -> AList (S m') n

sub :: Nat' m -> AList m n -> (Fin m -> Term n)
sub _ (Anil) = Var
sub (S n) (Asnoc s t x) = compose(sub n s)(for n t x)
cat :: AList m n -> AList l m -> AList l n
cat xs (Anil) = xs
cat xs (Asnoc ys t x) = Asnoc (cat xs ys) t x

data SomeSub m = ex n. SomeSub (Nat' n) (AList m n)
asnoc :: SomeSub m -> Term m -> Fin (S m) -> SomeSub (S m)
asnoc (SomeSub m s) t x = SomeSub m (Asnoc s t x)

-----------------------------------------------------
-- unification
mgu :: Nat' m -> Term m -> Term m -> Maybe (SomeSub m)
mgu m s t = amgu m s t (SomeSub m Anil)

amgu :: Nat' m -> Term m -> Term m -> SomeSub m -> Maybe (SomeSub m)
amgu m (Leaf) (Leaf) acc = Just acc
amgu m (Leaf) (Fork s t) acc = Nothing
amgu m (Fork s t) (Leaf) acc = Nothing
amgu m (Fork s1 t1) (Fork s2 t2) acc =
     do { acc <- amgu m s1 t1 acc; amgu m s2 t2 acc }
amgu m (Var x) (Var y) (SomeSub _ Anil) = Just (flexFlex m x y)
amgu m (Var x) t (SomeSub _ Anil) = flexRigid m x t
amgu m s (Var x) (SomeSub _ Anil) = flexRigid m x s
amgu (S m) s t (SomeSub n (Asnoc sub r z)) =
     do sub <- amgu m (subst (for m r z) s) (subst (for m r z) t) (SomeSub n sub)
        return (asnoc sub r z)

flexFlex :: Nat' m -> Fin m -> Fin m -> SomeSub m
flexFlex (S m) x y = case thick m x y of
                     Just y' -> SomeSub m (Asnoc Anil (Var y') x)
                     Nothing -> SomeSub (S m) Anil

flexRigid :: Nat' m -> Fin m -> Term m -> Maybe (SomeSub m)
flexRigid (S m) x t = do
                      t' <- chk m x t
                      return (SomeSub m (Asnoc Anil t' x))


Removed _DebOut(PSZ) overload. This is not needed

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

USING System.Reflection
USING System.Diagnostics

/// <summary>
/// Write information to the Debug Terminal Program
/// </summary>
/// <returns>
/// </returns>
FUNCTION	DebOut()	AS	VOID CLIPPER
	LOCAL C AS STRING
	LOCAL X AS DWORD
	C:=""
	FOR X:=1 UPTO PCount()
		IF X<>1
			C+=", "
		END
		C+=AsString(_GetFParam(X))
	NEXT
	Debout32(C)
	RETURN

/// <summary>
/// Check whether a break occurs within the BEGIN SEQUENCE...END construct.
/// </summary>
/// <returns>
/// </returns>
FUNCTION CanBreak() AS LOGIC
	RETURN XSharp.Internal.CompilerServices.CanBreak()

/// <summary>
/// Returns the version of X# you are using.
/// </summary>
/// <returns>
/// </returns>
FUNCTION Version() AS STRING
	RETURN "XSharp "+__VERSION__

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//

USING System.Reflection
USING System.Diagnostics

/// <summary>
/// Write information to the Debug Terminal Program
/// </summary>
/// <returns>
/// </returns>
FUNCTION _DebOut32( s AS PSZ) AS VOID
   System.Diagnostics.Debug.WriteLine(psz2string(s))
   RETURN

/// <summary>
/// Write information to the Debug Terminal Program
/// </summary>
/// <returns>
/// </returns>
FUNCTION	DebOut()	AS	VOID CLIPPER
	LOCAL C AS STRING
	LOCAL X AS DWORD
	C:=""
	FOR X:=1 UPTO PCount()
		IF X<>1
			C+=", "
		END
		C+=AsString(_GetFParam(X))
	NEXT
	Debout32(C)
	RETURN

/// <summary>
/// Check whether a break occurs within the BEGIN SEQUENCE...END construct.
/// </summary>
/// <returns>
/// </returns>
FUNCTION CanBreak() AS LOGIC
	RETURN XSharp.Internal.CompilerServices.CanBreak()

/// <summary>
/// Returns the version of X# you are using.
/// </summary>
/// <returns>
/// </returns>
FUNCTION Version() AS STRING
	RETURN "XSharp "+__VERSION__


[Runtime] Allow multiple ImplicitNamespace attributes

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
BEGIN NAMESPACE XSharp.Internal

	///
	/// This class is used to mark IntPtr _DLL arguments with the actual type
	///
	[AttributeUsage(AttributeTargets.Parameter)];
	SEALED CLASS ActualTypeAttribute INHERIT Attribute
		PRIVATE INITONLY _value AS System.Type
		///The actual type of the parameter.
		PROPERTY VALUE AS System.Type GET _value
		///
		CONSTRUCTOR(VALUE AS System.Type)
			_value := VALUE

	END CLASS

	///
	/// This class exposes the namespace and globalclass in an assembly
	///
	[AttributeUsage(AttributeTargets.Assembly)];
	SEALED CLASS ClassLibraryAttribute INHERIT Attribute
		PRIVATE INITONLY _globalClassName AS STRING
		PRIVATE INITONLY _defaultNameSpace AS STRING
		///Name of the class where functions, defines and globals are stored.
		PROPERTY GlobalClassName AS STRING GET _globalClassName
        ///Default namespace of the assembly.
		PROPERTY DefaultNameSpace AS STRING GET _defaultNameSpace
		///
		CONSTRUCTOR(globalClassName AS STRING, defaultNameSpace AS STRING)
			_globalClassName := globalClassName
			_defaultNameSpace := defaultNameSpace

	END CLASS

	///
	/// This class documents the parameter names for methods and functions
	/// with Clipper calling convention
	///

	[AttributeUsage(AttributeTargets.Method|AttributeTargets.Constructor)];
	SEALED CLASS ClipperCallingConventionAttribute INHERIT Attribute
		PRIVATE INITONLY _parameterNames AS STRING[]
		///List of parameter names for the method or constructor
		PROPERTY ParameterNames AS STRING[] GET _parameterNames
		///
		CONSTRUCTOR(parameterNames AS STRING[])
			_parameterNames := parameterNames

	END CLASS

	///
	/// This class records the compiler version used to build an assembly
	///
	[AttributeUsage(AttributeTargets.Assembly)];
	SEALED CLASS CompilerVersionAttribute INHERIT Attribute
		PRIVATE INITONLY _version AS STRING
	    ///The version and dialect of the compiler that created the assembly.
		PROPERTY Version AS STRING GET _version

		///
		CONSTRUCTOR(version AS STRING)
			_version := version

	END CLASS

	///
	/// this class is used to mark default parameter values in the middle of a parameter list.
    ///
    /// <remarks>
    /// It is used when compiling in VO or Vulcan mode.
    /// And only for parameters that are followed by parameters without default value (because that is not supported by the .Net framework).

    /// The X# compiler will find this attribute at compile time and will insert its value into the argument list.
    /// </remarks>
	SEALED CLASS DefaultParameterValueAttribute INHERIT Attribute
		PRIVATE INITONLY _value AS OBJECT
		PRIVATE INITONLY _flag  AS INT
		/// Value of the default parameter
		PROPERTY Value AS OBJECT GET _value
        /// Flag indicating the type of the default parameter
        /// <remarks>
	    /// 0 = Regular .Net default value
	    /// 1 = NIL
	    /// 2 = Date (value is LONG ticks, empty for NULL_DATE)
	    /// 3 = Symbol, value can be empty or a string
	    /// 4 = PSZ, null = empty, or a string
	    /// 5 = IntPtr (can be 0 for NullPtr)
	    /// </remarks>
		PROPERTY Flag  AS INT    GET _flag

		///
		CONSTRUCTOR(oValue AS OBJECT, flag AS INT)
			_value := oValue
			_flag  := flag

	END CLASS

	///
	/// This class is used to describe VOSTRUCT and UNION structures which have a different semantics
	/// AS actually means Struct PTR. IS means Struct
	/// Please note that the size assumes x86 (32 bits) OS.
	///
	[AttributeUsage(AttributeTargets.Struct)];
	SEALED CLASS VoStructAttribute INHERIT Attribute
		PRIVATE _size				AS INT
		PRIVATE _largestMemberSize  AS INT
		///Total size of the VOSTRUCT or UNION.
		PROPERTY Size				AS INT GET _size
        ///Size of the largest member.
		PROPERTY LargestMemberSize	AS INT GET _largestMemberSize

		///
		CONSTRUCTOR(size AS INT, largestMemberSize AS INT)
			_size := size
			_largestMemberSize := largestMemberSize

	END CLASS

	///
	/// This class is used to describe fields that have been declared with the INSTANCE modifier
    ///
	[AttributeUsage(AttributeTargets.Field)];
	SEALED CLASS IsInstanceAttribute INHERIT Attribute

		///
		CONSTRUCTOR()
			SUPER()
			RETURN

	END CLASS

END NAMESPACE

BEGIN NAMESPACE XSharp
	///
	/// This class is used to tell the compiler that the assembly has types in a specific namespace.
    /// When the compiler is called with the /ins command line option, then the names specified with this attribute
    /// will be automatically included in the USING list when compiling.
    ///
    /// <remarks>
	/// This type is not in the internal namespace because it is supposed to be used by 3rd party vendors as well
	/// </remarks>
	[AttributeUsage(AttributeTargets.Assembly, AllowMultiple := true)];
	SEALED CLASS ImplicitNamespaceAttribute INHERIT Attribute
		PRIVATE INITONLY _namespace AS STRING
	    ///Name of the implicit namespace.
		PROPERTY Namespace AS STRING GET _namespace

		///
		CONSTRUCTOR(namespace AS STRING)
			_namespace := namespace

	END CLASS

END NAMESPACE

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
BEGIN NAMESPACE XSharp.Internal

	///
	/// This class is used to mark IntPtr _DLL arguments with the actual type
	///
	[AttributeUsage(AttributeTargets.Parameter)];
	SEALED CLASS ActualTypeAttribute INHERIT Attribute
		PRIVATE INITONLY _value AS System.Type
		///The actual type of the parameter.
		PROPERTY VALUE AS System.Type GET _value
		///
		CONSTRUCTOR(VALUE AS System.Type)
			_value := VALUE

	END CLASS

	///
	/// This class exposes the namespace and globalclass in an assembly
	///
	[AttributeUsage(AttributeTargets.Assembly)];
	SEALED CLASS ClassLibraryAttribute INHERIT Attribute
		PRIVATE INITONLY _globalClassName AS STRING
		PRIVATE INITONLY _defaultNameSpace AS STRING
		///Name of the class where functions, defines and globals are stored.
		PROPERTY GlobalClassName AS STRING GET _globalClassName
        ///Default namespace of the assembly.
		PROPERTY DefaultNameSpace AS STRING GET _defaultNameSpace
		///
		CONSTRUCTOR(globalClassName AS STRING, defaultNameSpace AS STRING)
			_globalClassName := globalClassName
			_defaultNameSpace := defaultNameSpace

	END CLASS

	///
	/// This class documents the parameter names for methods and functions
	/// with Clipper calling convention
	///

	[AttributeUsage(AttributeTargets.Method|AttributeTargets.Constructor)];
	SEALED CLASS ClipperCallingConventionAttribute INHERIT Attribute
		PRIVATE INITONLY _parameterNames AS STRING[]
		///List of parameter names for the method or constructor
		PROPERTY ParameterNames AS STRING[] GET _parameterNames
		///
		CONSTRUCTOR(parameterNames AS STRING[])
			_parameterNames := parameterNames

	END CLASS

	///
	/// This class records the compiler version used to build an assembly
	///
	[AttributeUsage(AttributeTargets.Assembly)];
	SEALED CLASS CompilerVersionAttribute INHERIT Attribute
		PRIVATE INITONLY _version AS STRING
	    ///The version and dialect of the compiler that created the assembly.
		PROPERTY Version AS STRING GET _version

		///
		CONSTRUCTOR(version AS STRING)
			_version := version

	END CLASS

	///
	/// this class is used to mark default parameter values in the middle of a parameter list.
    ///
    /// <remarks>
    /// It is used when compiling in VO or Vulcan mode.
    /// And only for parameters that are followed by parameters without default value (because that is not supported by the .Net framework).

    /// The X# compiler will find this attribute at compile time and will insert its value into the argument list.
    /// </remarks>
	SEALED CLASS DefaultParameterValueAttribute INHERIT Attribute
		PRIVATE INITONLY _value AS OBJECT
		PRIVATE INITONLY _flag  AS INT
		/// Value of the default parameter
		PROPERTY Value AS OBJECT GET _value
        /// Flag indicating the type of the default parameter
        /// <remarks>
	    /// 0 = Regular .Net default value
	    /// 1 = NIL
	    /// 2 = Date (value is LONG ticks, empty for NULL_DATE)
	    /// 3 = Symbol, value can be empty or a string
	    /// 4 = PSZ, null = empty, or a string
	    /// 5 = IntPtr (can be 0 for NullPtr)
	    /// </remarks>
		PROPERTY Flag  AS INT    GET _flag

		///
		CONSTRUCTOR(oValue AS OBJECT, flag AS INT)
			_value := oValue
			_flag  := flag

	END CLASS

	///
	/// This class is used to describe VOSTRUCT and UNION structures which have a different semantics
	/// AS actually means Struct PTR. IS means Struct
	/// Please note that the size assumes x86 (32 bits) OS.
	///
	[AttributeUsage(AttributeTargets.Struct)];
	SEALED CLASS VoStructAttribute INHERIT Attribute
		PRIVATE _size				AS INT
		PRIVATE _largestMemberSize  AS INT
		///Total size of the VOSTRUCT or UNION.
		PROPERTY Size				AS INT GET _size
        ///Size of the largest member.
		PROPERTY LargestMemberSize	AS INT GET _largestMemberSize

		///
		CONSTRUCTOR(size AS INT, largestMemberSize AS INT)
			_size := size
			_largestMemberSize := largestMemberSize

	END CLASS

	///
	/// This class is used to describe fields that have been declared with the INSTANCE modifier
    ///
	[AttributeUsage(AttributeTargets.Field)];
	SEALED CLASS IsInstanceAttribute INHERIT Attribute

		///
		CONSTRUCTOR()
			SUPER()
			RETURN

	END CLASS

END NAMESPACE

BEGIN NAMESPACE XSharp
	///
	/// This class is used to tell the compiler that the assembly has types in a specific namespace.
    /// When the compiler is called with the /ins command line option, then the names specified with this attribute
    /// will be automatically included in the USING list when compiling.
    ///
    /// <remarks>
	/// This type is not in the internal namespace because it is supposed to be used by 3rd party vendors as well
	/// </remarks>
	[AttributeUsage(AttributeTargets.Assembly)];
	SEALED CLASS ImplicitNamespaceAttribute INHERIT Attribute
		PRIVATE INITONLY _namespace AS STRING
	    ///Name of the implicit namespace.
		PROPERTY Namespace AS STRING GET _namespace

		///
		CONSTRUCTOR(namespace AS STRING)
			_namespace := namespace

	END CLASS

END NAMESPACE


QtHelp: updated (formatting)

QtHelp: updated (formatting)

Modified:
source/QtHelp/QHelpSearchQueryClass.prg

/*

  Qt4xHb - bibliotecas de ligao entre Harbour/xHarbour e Qt Framework 4

  Copyright (C) 2012-2017 Marcos Antonio Gambeta <marcosgambeta@uol.com.br>

*/

#include "hbclass.ch"

CLASS QHelpSearchQuery

   DATA pointer
   DATA self_destruction INIT .F.

   METHOD new1
   METHOD new2
   METHOD new
   METHOD newFrom
   METHOD newFromObject
   METHOD newFromPointer
   METHOD selfDestruction
   METHOD setSelfDestruction
   DESTRUCTOR destroyObject

END CLASS

PROCEDURE destroyObject () CLASS QHelpSearchQuery
   IF ::self_destruction
      ::delete()
   ENDIF
RETURN

#pragma BEGINDUMP

#include <QHelpSearchQuery>

#include "qt4xhb_common.h"
#include "qt4xhb_macros.h"
#include "qt4xhb_utils.h"

/*
QHelpSearchQuery ()
*/
HB_FUNC_STATIC( QHELPSEARCHQUERY_NEW1 )
{
  QHelpSearchQuery * o = new QHelpSearchQuery ();
  _qt4xhb_storePointerAndFlag ( o, false );
}

/*
QHelpSearchQuery ( FieldName field, const QStringList & wordList )
*/
HB_FUNC_STATIC( QHELPSEARCHQUERY_NEW2 )
{
  QHelpSearchQuery * o = new QHelpSearchQuery ( (QHelpSearchQuery::FieldName) hb_parni(1), PQSTRINGLIST(2) );
  _qt4xhb_storePointerAndFlag ( o, false );
}

//[1]QHelpSearchQuery ()
//[2]QHelpSearchQuery ( FieldName field, const QStringList & wordList )

HB_FUNC_STATIC( QHELPSEARCHQUERY_NEW )
{
  if( ISNUMPAR(0) )
  {
    HB_FUNC_EXEC( QHELPSEARCHQUERY_NEW1 );
  }
  else if( ISNUMPAR(2) && ISNUM(1) && ISARRAY(2) )
  {
    HB_FUNC_EXEC( QHELPSEARCHQUERY_NEW2 );
  }
  else
  {
    hb_errRT_BASE( EG_ARG, 3012, NULL, HB_ERR_FUNCNAME, HB_ERR_ARGS_BASEPARAMS );
  }
}

HB_FUNC_STATIC( QHELPSEARCHQUERY_NEWFROM )
{
  PHB_ITEM self = hb_stackSelfItem();

  if( hb_pcount() == 1 && ISOBJECT(1) )
  {
    PHB_ITEM ptr = hb_itemPutPtr( NULL, (void *) hb_itemGetPtr( hb_objSendMsg( hb_param(1, HB_IT_OBJECT ), "POINTER", 0 ) ) );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
    PHB_ITEM des = hb_itemPutL( NULL, false );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }
  else if( hb_pcount() == 1 && ISPOINTER(1) )
  {
    PHB_ITEM ptr = hb_itemPutPtr( NULL, (void *) hb_itemGetPtr( hb_param(1, HB_IT_POINTER ) ) );
    hb_objSendMsg( self, "_pointer", 1, ptr );
    hb_itemRelease( ptr );
    PHB_ITEM des = hb_itemPutL( NULL, false );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }

  hb_itemReturn( self );
}

HB_FUNC_STATIC( QHELPSEARCHQUERY_NEWFROMOBJECT )
{
  HB_FUNC_EXEC( QHELPSEARCHQUERY_NEWFROM );
}

HB_FUNC_STATIC( QHELPSEARCHQUERY_NEWFROMPOINTER )
{
  HB_FUNC_EXEC( QHELPSEARCHQUERY_NEWFROM );
}

HB_FUNC_STATIC( QHELPSEARCHQUERY_SELFDESTRUCTION )
{
  hb_retl( (bool) hb_itemGetL( hb_objSendMsg( hb_stackSelfItem(), "SELF_DESTRUCTION", 0 ) ) );
}

HB_FUNC_STATIC( QHELPSEARCHQUERY_SETSELFDESTRUCTION )
{
  PHB_ITEM self = hb_stackSelfItem();

  if( hb_pcount() == 1 && ISLOG(1) )
  {
    PHB_ITEM des = hb_itemPutL( NULL, hb_parl(1) );
    hb_objSendMsg( self, "_self_destruction", 1, des );
    hb_itemRelease( des );
  }

  hb_itemReturn( self );
}

#pragma ENDDUMP


add some more hints

add some more hints

-- Note: this is a heavily simplified testcase

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

graft :: Tree d ~> Tree f ~> Tree f
{graft what ()tr} = what
--{graft []tr ()tr} = []tr -- this is rejected

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr}
{graft []tr ()tr} :: Tree Ver  = {graft []tr ()tr}

... BUT: Hor /= Ver :-(

Seems to be a narrowing bug:

prompt> :narrow Equal {graft a ()tr} a
["a"]
Success

prompt> :narrow Equal {graft []tr ()tr} []tr
[]

while checking the kind of (Equal {graft []tr ()tr} []tr)
we expected ([]tr::  Tree Ver:: *1) but
we inferred ([]tr::  Tree Hor)

We computed the Constructor []tr to have type Tree Hor
We expected it to be Tree Ver
different constants
   Hor   !=   Ver
(Hor,Ver)

Or even the non-kind-checking while narrowing

-}

-- Note: this is a heavily simplified testcase

data Dir :: *2 where
  Hor :: Dir
  Ver :: Dir

data Tree :: Dir ~> *1 where
  Unit :: Tree Ver
  Ni :: Tree Hor
  Fork :: Tree d ~> Tree Hor ~> Tree Hor
 deriving syntax (tr) List(Ni, Fork) Unit(Unit)

graft :: Tree d ~> Tree f ~> Tree f
{graft what ()tr} = what
--{graft []tr ()tr} = []tr -- this is rejected

{- NOTE: we have an Omega bug here:

prompt> :norm {graft []tr ()tr}
Normalizes to:
  []tr

prompt> :kind []tr
[]tr :: Tree Hor  = []tr

prompt> :kind {graft []tr ()tr}
{graft []tr ()tr} :: Tree Ver  = {graft []tr ()tr}

... BUT: Hor /= Ver :-(
-}


convince theta that vars are okay

convince theta that vars are okay

-- item notation

-- basic: http://www.cedar-forest.org/forest/talks/talks2001/talkPPDP2001.ps
-- extended: http://www.cedar-forest.org/forest/talks/talks2001/microsoft.ps

import "../src/LangPrelude.prg" (maybeM)
import "LabeledDeBruijn.prg"

data Itm :: Inventory Tag ~> * where
  -- applicator wagon
  IApp :: Itm inv -> Itm inv -> Itm inv
  -- abstractor wagon
  IAbs :: Label n -> Itm [inv; n]i -> Itm inv
  -- argument access
  IArg :: Itm [ups; t]i
  IUp :: Itm [ups; t]i -> Itm [ups; t, t']i
 deriving syntax (it) Nat(IArg, IUp)

iota :: Tm inv -> Itm inv
iota Arg = IArg
iota (Up m) = IUp (iota m)
iota (Lm n b) = IAbs n (iota b)
iota (App f a) = IApp (iota a) (iota f)

slide1 = iota (Lm `x (Lm `y (1tm,0tm)tm), 0tm)tm  -- assuming `z = 0tm

-- ok now, let's drift to thrists

data Wagon :: Inventory Tag ~> Inventory Tag ~> * where
  AppW :: Wagon inv inv -> Wagon inv inv
  AbsW :: Label n -> Wagon [inv; n]i inv
  ArgW :: Wagon [ups; t]i [ups; t]i
  UpW :: Wagon [ups; t]i [ups; t]i -> Wagon [ups; t, t']i [ups; t, t']i
 deriving syntax (w) Nat(ArgW, UpW) Item(AppW)

data Thrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  Nil :: Thrist k a a
  Cons :: k a b -> Thrist k b c -> Thrist k a c
 deriving List(t)

theta :: Tm inv -> exists inv' . Thrist Wagon inv inv'
theta Arg = Ex [ArgW]t
theta (Up m) = case ensureVar m' of
               Just Eq -> Ex [UpW  m']t
    where (Ex thr) = theta m
    	  [m']t = thr
          ensureVar :: Wagon i j -> Maybe (Equal i j)
          ensureVar ArgW = Just Eq
          ensureVar (UpW v) = do { Eq <- ensureVar v; return Eq }
          monad maybeM

{-
theta (Lm n b) = AbsW n (theta b)
theta (App f a) = AppW (theta a) (theta f)
-}

-- item notation

-- basic: http://www.cedar-forest.org/forest/talks/talks2001/talkPPDP2001.ps
-- extended: http://www.cedar-forest.org/forest/talks/talks2001/microsoft.ps

import "LabeledDeBruijn.prg"

data Itm :: Inventory Tag ~> * where
  -- applicator wagon
  IApp :: Itm inv -> Itm inv -> Itm inv
  -- abstractor wagon
  IAbs :: Label n -> Itm [inv; n]i -> Itm inv
  -- argument access
  IArg :: Itm [ups; t]i
  IUp :: Itm [ups; t]i -> Itm [ups; t, t']i
 deriving syntax (it) Nat(IArg, IUp)

iota :: Tm inv -> Itm inv
iota Arg = IArg
iota (Up m) = IUp (iota m)
iota (Lm n b) = IAbs n (iota b)
iota (App f a) = IApp (iota a) (iota f)

slide1 = iota (Lm `x (Lm `y (1tm,0tm)tm), 0tm)tm  -- assuming `z = 0tm

-- ok now, lets drift to thrists

data Wagon :: Inventory Tag ~> Inventory Tag ~> * where
  AppW :: Wagon inv inv -> Wagon inv inv
  AbsW :: Label n -> Wagon [inv; n]i inv
  ArgW :: Wagon [ups; t]i [ups; t]i
  UpW :: Wagon [ups; t]i [ups; t]i -> Wagon [ups; t, t']i [ups; t, t']i
 deriving syntax (w) Nat(ArgW, UpW) Item(AppW)

data Thrist :: forall (l :: *1) . (l ~> l ~> *)  ~> l ~> l ~> * where
  Nil :: Thrist k a a
  Cons :: k a b -> Thrist k b c -> Thrist k a c
 deriving List(t)

theta :: Tm inv -> exists inv' . Thrist Wagon inv inv'
theta Arg = Ex [ArgW]t
{-
theta (Up m) = Ex [UpW  m']t
    where (Ex thr) = theta m
    	  [m']t = thr
theta (Lm n b) = AbsW n (theta b)
theta (App f a) = AppW (theta a) (theta f)
-}


[Runtime] Updated VO registry functions

[Runtime] Updated VO registry functions

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
INTERNAL DEFINE VO_APPS			:= "Software\ComputerAssociates\CA-Visual Objects Applications"
INTERNAL DEFINE VO_LOCALMACHINE	:= "HKEY_LOCAL_MACHINE\"+VO_APPS
INTERNAL DEFINE VO_CURRENTUSER	:= "HKEY_CURRENT_USER\"+VO_APPS
USING Microsoft.Win32
/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/setrtregint/*" />
FUNCTION SetRTRegInt(cSubKey AS STRING,cKey AS STRING,dwKeyValue AS DWORD) AS LOGIC
	LOCAL cFullKey AS STRING
	cFullKey := VO_LOCALMACHINE
	IF ! String.IsNullOrEmpty( cSubKey )
		cFullKey += "\" + cSubKey
	ENDIF
	// try HKLM first
	TRY
		IF Registry.GetValue(cFullKey,cKey,NULL) != NULL
			Registry.SetValue(cFullKey,cKey,dwKeyValue)
		ENDIF
    CATCH
        NOP
	END TRY
	// always write to HKCU
	cFullKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cFullKey += "\" + cSubKey
	ENDIF
	TRY
		Registry.SetValue(cFullKey,cKey,dwKeyValue)
    CATCH
        NOP
	END TRY
	RETURN ! Registry.GetValue(cFullKey,cKey,NULL) == NULL

/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/setrtregstring/*" />
FUNCTION SetRTRegString(cSubKey AS STRING,cKey AS STRING,cValue AS STRING) AS LOGIC
	LOCAL cFullKey AS STRING
	cFullKey := VO_LOCALMACHINE
	IF ! String.IsNullOrEmpty( cSubKey )
		cFullKey += "\" + cSubKey
	ENDIF
	// try HKLM first
	TRY
		IF Registry.GetValue(cFullKey,cKey,NULL) != NULL
			Registry.SetValue(cFullKey,cKey,cValue)
		ENDIF
    CATCH
        NOP
	END TRY
	// always write to HKCU
	cFullKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cFullKey += "\" + cSubKey
	ENDIF
	TRY
		Registry.SetValue(cFullKey,cKey,cValue)
    CATCH
        NOP
	END TRY
	RETURN ! Registry.GetValue(cFullKey,cKey,NULL) == NULL

/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/queryrtregint/*" />
FUNCTION QueryRTRegInt(cSubKey AS STRING,cKey AS STRING) AS DWORD
	LOCAL cFullKey AS STRING
	LOCAL o AS OBJECT

	// First try to read from HKCU
	cFullKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cFullKey += "\" + cSubKey
	ENDIF
	o := Registry.GetValue(cKey,cKey,NULL)
	// If that fails then read from HKLM
	IF o == NULL
		cFullKey := VO_LOCALMACHINE
		IF ! String.IsNullOrEmpty( cSubKey )
			cFullKey += "\" + cSubKey
		ENDIF
		TRY
			o := Registry.GetValue(cFullKey,cKey,NULL)
        CATCH
            o := NULL
		END TRY
		IF o == NULL
		    o := 0
		ENDIF
	ENDIF

	RETURN Convert.ToUInt32(o)
/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/queryrtregstring/*" />
FUNCTION QueryRTRegString(cSubKey AS STRING,cKey AS STRING) AS STRING
	LOCAL cFullKey AS STRING
	LOCAL o AS OBJECT

	cFullKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cFullKey += "\" + cSubKey
	ENDIF

	o := Registry.GetValue(cFullKey,cKey,NULL)
	IF o == NULL
		cFullKey := VO_LOCALMACHINE
		IF ! String.IsNullOrEmpty( cSubKey )
			cFullKey += "\" + cSubKey
		ENDIF
		TRY
			o := Registry.GetValue(cFullKey,cKey,NULL)
        CATCH
            o := NULL
		END TRY
		IF o == NULL
			o := ""
		ENDIF
	ENDIF

	RETURN Convert.ToString(o)

/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/deletertregkey/*" />
FUNCTION DeleteRTRegKey(cSubKey AS STRING) AS LOGIC
    LOCAL oKey := NULL AS RegistryKey
    lOCAL succeeded := FALSE AS LOGIC
	TRY
	    oKey := Registry.LocalMachine:OpenSubKey(VO_APPS, TRUE)
	    IF oKey != NULL
	        oKey:DeleteSubKey(cSubKey)
            succeeded := TRUE
        ENDIF
    CATCH
        NOP
    END TRY
	TRY
	    oKey := Registry.CurrentUser:OpenSubKey(VO_APPS, TRUE)
	    IF oKey != NULL
	        oKey:DeleteSubKey(cSubKey)
            succeeded := TRUE
        ENDIF
    CATCH
        NOP
    END TRY
RETURN succeeded

//
// Copyright (c) XSharp B.V.  All Rights Reserved.
// Licensed under the Apache License, Version 2.0.
// See License.txt in the project root for license information.
//
INTERNAL DEFINE VO_APPS			:= "Software\ComputerAssociates\CA-Visual Objects Applications"
INTERNAL DEFINE VO_LOCALMACHINE	:= "HKEY_LOCAL_MACHINE\"+VO_APPS
INTERNAL DEFINE VO_CURRENTUSER	:= "HKEY_CURRENT_USER\"+VO_APPS
USING Microsoft.Win32
/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/setrtregint/*" />
FUNCTION SetRTRegInt(cSubKey AS STRING,cKey AS STRING,dwKeyValue AS DWORD) AS LOGIC
	LOCAL cKey AS STRING
	cKey := VO_LOCALMACHINE
	IF ! String.IsNullOrEmpty( cSubKey )
		cKey += "\" + cSubKey
	ENDIF
	// try HKLM first
	TRY
		IF Registry.GetValue(cKey,cKey,NULL) != NULL
			Registry.SetValue(cKey,cKey,dwKeyValue)
		ENDIF
	END TRY
	// always write to HKCU
	cKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cKey += "\" + cSubKey
	ENDIF
	TRY
		Registry.SetValue(cKey,cKey,dwKeyValue)
	END TRY
	RETURN ! Registry.GetValue(cKey,cKey,NULL) == NULL

/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/setrtregstring/*" />
FUNCTION SetRTRegString(cSubKey AS STRING,cKey AS STRING,cValue AS STRING) AS LOGIC
	LOCAL cKey AS STRING
	cKey := VO_LOCALMACHINE
	IF ! String.IsNullOrEmpty( cSubKey )
		cKey += "\" + cSubKey
	ENDIF
	// try HKLM first
	TRY
		IF Registry.GetValue(cKey,cKey,NULL) != NULL
			Registry.SetValue(cKey,cKey,cValue)
		ENDIF
	END TRY
	// always write to HKCU
	cKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cKey += "\" + cSubKey
	ENDIF
	TRY
		Registry.SetValue(cKey,cKey,cValue)
	END TRY
	RETURN ! Registry.GetValue(cKey,cKey,NULL) == NULL

/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/queryrtregint/*" />
FUNCTION QueryRTRegInt(cSubKey AS STRING,cKey AS STRING) AS DWORD
	LOCAL cParentKey AS STRING
	LOCAL o AS OBJECT

	// First try to read from HKCU
	cParentKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cParentKey += "\" + cSubKey
	ENDIF
	o := Registry.GetValue(cKey,cKey,NULL)
	// If that fails then read from HKLM
	IF o == NULL
		cParentKey := VO_LOCALMACHINE
		IF ! String.IsNullOrEmpty( cSubKey )
			cParentKey += "\" + cSubKey
		ENDIF
		TRY
			o := Registry.GetValue(cParentKey,cKey,NULL)
		END TRY
		IF o == NULL
			o := 0
		ENDIF
	ENDIF

	RETURN Convert.ToUInt32(o)
/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/queryrtregstring/*" />
FUNCTION QueryRTRegString(cSubKey AS STRING,cKey AS STRING) AS STRING
	LOCAL cParentKey AS STRING
	LOCAL o AS OBJECT

	cParentKey := VO_CURRENTUSER
	IF ! String.IsNullOrEmpty( cSubKey )
		cParentKey += "\" + cSubKey
	ENDIF

	o := Registry.GetValue(cParentKey,cKey,NULL)
	IF o == NULL
		cParentKey := VO_LOCALMACHINE
		IF ! String.IsNullOrEmpty( cSubKey )
			cParentKey += "\" + cSubKey
		ENDIF
		TRY
			o := Registry.GetValue(cParentKey,cKey,NULL)
		END TRY
		IF o == NULL
			o := ""
		ENDIF
	ENDIF

	RETURN Convert.ToString(o)

/// <include file="VoFunctionDocs.xml" path="Runtimefunctions/deletertregkey/*" />
FUNCTION DeleteRTRegKey(cSubKey AS STRING) AS LOGIC
LOCAL oKey := NULL AS RegistryKey
	TRY
	oKey := Registry.LocalMachine:OpenSubKey(VO_APPS, TRUE)
		IF (oKey != NULL)
	oKey:DeleteSubKey(cSubKey)
ENDIF
END TRY
	TRY
	oKey := Registry.CurrentUser:OpenSubKey(VO_APPS, TRUE)
		IF (oKey != NULL)
	oKey:DeleteSubKey(cSubKey)
ENDIF
END TRY
RETURN oKey != NULL_OBJECT