<%
'------------------------------------------
' vbxobj.inc: Copyright (C) 2010 Walter Bislin
' http://walter.bislins.ch/doku/vbxobj
'
' Global object Obj of class CObject contains some basic object functions and definitions
' * type constants and names
' * type conversions
'
' Global object VBX of class CVBX extends VbScript:
' * property and member function access via property name (string)
' * Check existens and call global and object member functions
'
' Dependencies: none
'
' Exports:
' - VBX as CVBX
' - Obj as CObject

class CVBX

  public Instance
  public Value

  function HasProperty( aObject, aPropertyName )
    on error resume next
    Value = GetValue( aObject, aPropertyName )
    if Err <> 0 then
      HasProperty = false
      Err.Clear
    else
      HasProperty = true
    end if
  end function

  function GetValue( aObject, aPropertyName )
    ' Require HasProperty( aObject, aPropertyName )
    set Instance = aObject
    GetValue = Eval( "VBX.Instance." & aPropertyName )
  end function

  sub SetValue( aObject, aPropertyName, aValue )
    ' Require HasProperty( aObject, aPropertyName )
    set Instance = aObject
    Value = aValue
    ExecuteGlobal "VBX.Instance." & aPropertyName & " = VBX.Value"
  end sub

  sub SetValues( aObject, aParams )
    ' aParams as array of [ "PropertyName", Value, ... ]
    dim nParams, i
    nParams = (UBound(aParams)+1) / 2
    for i = 0 to nParams-1
      SetValue aObject, aParams(2*i), aParams(2*i+1)
    next
  end sub

  function GetObject( aObject, aPropertyName )
    ' Require HasProperty( aObject, aPropertyName )
    set Instance = aObject
    set GetObject = Eval( "VBX.Instance." & aPropertyName )
  end function

  sub SetObject( aObject, aPropertyName, aValueObj )
    ' Require HasProperty( aObject, aPropertyName )
    set Instance = aObject
    set Value = aValueObj
    ExecuteGlobal "set VBX.Instance." & aPropertyName & " = VBX.Value"
  end sub

  function ProcExists(aProcName)
    dim obj
    on error resume next
    set obj = GetRef(aProcName)
    if Err <> 0 then
      ProcExists = false
      Err.Clear
    else
      ProcExists = true
    end if
  end function

  function MemberProcExists( aObject, aProcName )
    ' calls: aObject.aProcName false, Array()
    ' Note: sub aProcName must not execute anything if first argument is false!
    on error resume next
    set Instance = aObject
    ExecuteGlobal "VBX.Instance." & aProcName & " false, Array()"
    if Err <> 0 then
      Err.Clear
      MemberProcExists = false
    else
      MemberProcExists = true
    end if
  end function

  function MemberProcExistsI( aObject, aProcName )
    ' calls: aObject.aProcName false, -1, Array()
    ' Note: sub aProcName must not execute anything if first argument is false!
    on error resume next
    set Instance = aObject
    ExecuteGlobal "VBX.Instance." & aProcName & " false, -1, Array()"
    if Err <> 0 then
      Err.Clear
      MemberProcExistsI = false
    else
      MemberProcExistsI = true
    end if
  end function

  sub Exec( aObject, aProcName, aParams )
    ' calls: aObject.aProcName true, aParams
    ' Note: sub aProcName must not execute anything if first argument is false!
    set Instance = aObject
    Value = aParams
    ExecuteGlobal "VBX.Instance." & aProcName & " true, VBX.Value"
  end sub

  sub ExecI( aObject, aProcName, aIndex, aParams )
    ' calls: aObject.aProcName true, aIndex, aParams
    ' Note: sub aProcName must not execute anything if first argument is false!
    set Instance = aObject
    Value = aParams
    ExecuteGlobal "VBX.Instance." & aProcName & " true, " & CStr(aIndex) & ", VBX.Value"
  end sub

  function Eval( aObject, aFnName, aParams )
    set Instance = aObject
    Value = aParams
    Eval = Eval( "VBX.Instance." & aFnName & "( VBX.Value )" )
  end function

  function EvalGlobal( aExpression )
    ExecuteGlobal "VBX.Value = " & aExpression
    EvalGlobal = Value
  end function

end class

dim VBX
set VBX = new CVBX

class CObject

  ' constants
  public TypeAny
  public TypeStr
  public TypeBool
  public TypeInt
  public TypeNum
  public TypeDate

  public DecimalChar

  ' usage:
  '  typename = Obj.TypeName(Obj.TypeAny)
  '  value = Obj.Default(Obj.TypeAny)
  public TypeName  ' array(TypeAny..TypeDate) of string
  public Default   ' array(TypeAny..TypeDate) of values of corresponding type

  private sub Class_Initialize()
    TypeAny  = 0
    TypeStr  = 1
    TypeBool = 2
    TypeInt  = 3
    TypeNum  = 4
    TypeDate = 5

    TypeName = Array( "Any", "String", "Boolean", "Integer", "Numeric", "Date" )
    Default = Array( "", "", false, 0, 0.0, CDate(0) )

    ' induce language dependant decimal character
    DecimalChar = Mid(CStr(1.2),2,1)
  end sub

  '----------------------------------------
  ' Type conversions.
  ' Note: VBScript conversions are language dependent:
  '  CLng("1.2") -> 12 when lang = "de" !!!
  '  CLng("1.2") ->  1 when lang = "en"
  ' So, don't use VBScript conversions but the following functions instead!

  function LocalizeDecimalSep( aNumStr )
    ' converts the decimal char in aNumStr into the language dependent char needet for VBScript functions
    dim decSrc
    LocalizeDecimalSep = aNumStr
    if DecimalChar = "." then
      decSrc = ","
    elseif DecimalChar = "," then
      decSrc = "."
    else ' fallback
      exit function
    end if
    if InStr(aNumStr,decSrc) then
      LocalizeDecimalSep = Replace(aNumStr,decSrc,DecimalChar)
    end if
  end function

  function ValueIsNumeric( aValue )
    if VarType(aValue) = vbString then
      ValueIsNumeric = IsNumeric( LocalizeDecimalSep(aValue) )
    else
      ValueIsNumeric = IsNumeric( aValue )
    end if
  end function

  function ValueToInt( aValue )
    if VarType(aValue) = vbString then
      ValueToInt = CLng( LocalizeDecimalSep(aValue) )
    else
      ValueToInt = CLng( aValue )
    end if
  end function

  function ValueToNum( aValue )
    if VarType(aValue) = vbString then
      ValueToNum = CDbl( LocalizeDecimalSep(aValue) )
    else
      ValueToNum = CDbl( aValue )
    end if
  end function

  function ValueIsDate( aValue )
    ValueIsDate = IsDate(aValue)
  end function

  function ValueToDate( aValue )
    ValueToDate = CDate(aValue)
  end function

  function ConvertToType( aType, aValue )
    ' converts aValue to data type aType
    ' Require Obj.IsValidType(aType,aValue)
    dim val
    if VarType(aValue) = vbNull or VarType(aValue) = vbEmpty then
      aValue = ""
    end if
    select case aType
      case TypeAny
        ConvertToType = aValue
      case TypeStr
        if VarType(aValue) = vbString then
          ConvertToType = aValue
        elseif VarType(aValue) = vbBoolean then
          if aValue then
            ConvertToType = "true"
          else
            ConvertToType = "false"
          end if
        else
          ConvertToType = CStr(aValue)
        end if
      case TypeBool
        if VarType(aValue) = vbString then
          val = false
          if Len(aValue) > 0 then
            val = true
            if ValueIsNumeric(aValue) then val = (ValueToInt(aValue) <> 0)
            if StrComp(aValue,"false",1) = 0 then val = false
          end if
          ConvertToType = val
        else ' ValueIsNumeric(aValue)
          ConvertToType = (aValue <> 0)
        end if
      case TypeInt
        ConvertToType = ValueToInt(aValue)
      case TypeNum
        ConvertToType = ValueToNum(aValue)
      case TypeDate
        ConvertToType = ValueToDate(aValue)
    end select
  end function

  function GetType( aValue )
    ' returns data type of aValue as Obj.TypeAny
    GetType = TypeAny
    select case VarType(aValue)
      case vbDate
        GetType = TypeDate
      case vbSingle, vbDouble, vbCurrency
        GetType = TypeNum
      case vbInteger, vbLong
        GetType = TypeInt
      case vbBoolean
        GetType = TypeBool
      case vbString
        GetType = TypeStr
      case else
        GetType = TypeAny
    end select
  end function

  function IsValidType( aType, aValue )
    ' returns true if aValue can be converted to aType with ConvertToType()
    ' aType as Obj.TypeAny
    dim val
    on error resume next
    select case aType
      case TypeAny, TypeStr
        IsValidType = true
      case TypeBool
        IsValidType = not (ValueIsDate(aValue))
      case TypeInt
        if ValueIsNumeric(aValue) then
          IsValidType = true
          val = ValueToInt(aValue)
          if Err <> 0 then
            Err.Clear
            ' overflow
            IsValidType = false
          end if
        else
          IsValidType = false
        end if
      case TypeNum
        IsValidType = ValueIsNumeric(aValue)
      case TypeDate
        IsValidType = ValueIsDate(aValue)
      case else
        IsValidType = false
    end select
  end function

  function StringIsBitmask( aString )
    ' check wether aString is a valid bitmask representation
    ' aString = "0, 2, 3" -> Bits 0, 2 and 3 are set -> return 13
    dim bit, bits, i, val
    on error resume next
    bits = Split(aString, ",")
    StringIsBitmask = false
    for i = 0 to UBound(bits)
      bit = Trim(bits(i))
      if not IsNumeric(bit) then exit function
      val = CLng(2 ^ CLng(bit))
      if Err <> 0 then
        Err.Clear
        exit function
      end if
    next
    StringIsBitmask = true
  end function

  function StringToBitmask( aString )
    ' aString = "0, 2, 3" -> Bits 0, 2 and 3 are set -> return 13
    ' Require( StringIsBitmask(aString) )
    dim bit, bits, ret, i
    bits = Split(aString, ",")
    ret = 0
    for i = 0 to UBound(bits)
      bit = Trim(bits(i))
      ret = ret or CLng(2 ^ CLng(bit))
    next
    StringToBitmask = ret
  end function

  function BitmaskToString( aBitmask )
    ' aBitmask = 13 -> "0,2,3"
    dim s, bits, testBit, n
    s = ""
    bits = aBitmask
    testBit = 1
    n = 0
    do while bits <> 0
      if (bits And testBit) <> 0 then
        s = s & n & ","
        bits = bits And (Not testBit)
      end if
      testBit = testBit * 2
      n = n + 1
    loop
    if s <> "" then s = Left(s,Len(s)-1) ' remove last komma
    BitmaskToString = s
  end function

  function FormatNumberUnit( ByVal aNumber, ByVal aDigits, ByVal aFormat )
    ' aFormat as string: 12, 3, "# @B" -> "12 B";
    ' aFormat as string: 1024, 3, "# @B" -> "1.00 kB";
    ' aFormat as string: 12345, 3, "#.# *m" -> "12.3 km";
    ' # -> aNumber as integer
    ' #.# -> aNumber as real
    ' @ -> PreUnit (,Ki,Mi,Gi,Ti) but use 1024 as base width instead of 1000 (for binary units)
    ' * -> PreUnit (p,u,m,,k,M,G,T)
    dim u, uo, n, x, d, dg, isInt, us
    u = Array( "p", "u", "m", "", "k", "M", "G", "T" )
    uo = 3
    us = 1000
    if InStr(aFormat,"#.#") then
      isInt = false
      aFormat = Replace(aFormat,"#.#","#")
    else
      isInt = true
    end if
    if InStr(aFormat,"@") then
      u = Array( "", "Ki", "Mi", "Gi", "Ti" )
      uo = 0
      aFormat = Replace(aFormat,"@","*")
      us = 1024
      isInt = true
    end if
    n = abs( aNumber )
    x = 0
    if n >= 1 then
      do while n >= us and x < 4
        n = n / us
        x = x + 1
      loop
    else
      if not isInt then
        do while n < 1 and x > -3
          n = n * 1000
          x = x - 1
        loop
      end if
    end if
    if n >= 100 then
      d = 3
    elseif n >= 10 then
      d = 2
    elseif n >= 1 then
      d = 1
    else
      d = 0
    end if
    dg = aDigits - d
    if dg < 0 then dg = 0
    if isInt and x = 0 then dg = 0
    if aNumber < 0 then n = -n
    FormatNumberUnit = Replace( aFormat, "#", FormatNumber( n, dg ) )
    FormatNumberUnit = Replace( FormatNumberUnit, "*", u(x+uo) )
  end function

end class

dim Obj
set Obj = new CObject

%>