Index: trunk/Include/com/bstring.ab =================================================================== --- trunk/Include/com/bstring.ab (revision 355) +++ trunk/Include/com/bstring.ab (revision 478) @@ -1,6 +1,3 @@ ' com/bstring.ab - -'#require -'#require Namespace ActiveBasic @@ -8,5 +5,5 @@ Class BString - 'Inherits System.IDisposable, System.ICloneable + Implements System.IDisposable ', System.ICloneable Public Sub BString() @@ -19,28 +16,52 @@ Sub BString(s As BString) - BString.Copy(This.bs, s.bs) - End Sub - - Sub BString(s As LPCOLESTR) - bs = SysAllocString(s) + If Not IsNothing(s) Then + bs = copy(s.bs) + End If End Sub Sub BString(s As LPCOLESTR, len As DWord) - bs = SysAllocStringLen(s, len) - End Sub - - Sub BString(s As PCSTR) - Init(s, lstrlenA(s)) - End Sub - - Sub BString(s As PCSTR, len As DWord) - Dim lenBS = MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, 0, 0) - bs = SysAllocStringLen(0, lenBS) - MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, bs, lenBS) + If s <> 0 Then + bs = SysAllocStringLen(s, len) + End If End Sub Sub BString(s As String) - Init(s.StrPtr, s.Length As DWord) - End Sub + If Not IsNothing(s) Then + Init(s.StrPtr, s.Length As DWord) + End If + End Sub + + Static Function FromBStr(bs As BSTR) As BString + FromBStr = New BString(bs, SysStringLen(bs)) + End Function + + Static Function FromCStr(s As PCWSTR) As BString + If s <> 0 Then + FromCStr = New BString(s, lstrlenW(s)) + Else + FromCStr = New BString + End If + End Function + + Static Function FromCStr(s As PCWSTR, len As DWord) As BString + If s <> 0 Then + FromCStr = New BString(s, len) + Else + FromCStr = New BString + End If + End Function + + Static Function FromCStr(s As PCSTR) As BString + Dim dst As PCWSTR + Dim lenW = GetStr(s, dst) + FromCStr = FromCStr(s, lenW) + End Function + + Static Function FromCStr(s As PCSTR, len As DWord) As BString + Dim dst As PCWSTR + Dim lenW = GetStr(s, len, dst) + FromCStr = FromCStr(s, lenW) + End Function Sub ~BString() @@ -48,21 +69,6 @@ End Sub - Sub Assign(bstr As BString) - Clear() - BString.Copy(This.bs, bstr.bs) - End Sub - - Sub Assign(s As LPCOLESTR) - Clear() - s = SysAllocString(s) - End Sub - - Sub AssignFromBStr(bstr As BSTR) - Clear() - BString.Copy(bs, bstr) - End Sub - Const Function Copy() As BSTR - BString.Copy(Copy, bs) + Copy = copy(bs) End Function @@ -76,26 +82,17 @@ Sub Clear() - If bs <> 0 Then - SysFreeString(bs) - bs = 0 - End If + reset(0) End Sub Sub Attach(ByRef bstr As BSTR) - Clear() - BString.Move(bs, bstr) + reset(move(bstr)) End Sub Function Detach() As BSTR - BString.Move(Detach, bs) + Detach = move(bs) End Function Function BStr() As BSTR BStr = bs - End Function -/* - Static Function Assgin(bs As BSTR) As BString - Assgin = New BString - Assgin.Assgin(bs) End Function @@ -104,24 +101,20 @@ Attach.Attach(bs) End Function -*/ + Const Function Length() As DWord - Length = SysStringLen(bs) + Length = GetDWord(bs As VoidPtr - SizeOf (DWord)) 'SysStringLen(bs) End Function Const Function Operator [](i As SIZE_T) As OLECHAR -#ifdef _DEBUG If i > Length Then - 'Throw OutOfRangeException - End If -#endif + Throw New ArgumentOutOfRangeException("i") + End If Return bs[i] End Function Sub Operator []=(i As SIZE_T, c As OLECHAR) -#ifdef _DEBUG If i > Length Then - 'Throw OutOfRangeException - End If -#endif + Throw New ArgumentOutOfRangeException("i") + End If bs[i] = c End Sub @@ -135,21 +128,93 @@ End Function + Override Function Equals(o As Object) As Boolean + If Not IsNothing(o) Then + If This.GetType().Equals(o.GetType()) Then + Equals(o As BString) + End If + End If + End Function + + Const Function Equals(s As BString) As Boolean + Equals = Compare(This, s) = 0 + End Function + + Static Function Compare(l As BString, r As BString) As Long + If IsNullOrEmpty(l) Then + If IsNullOrEmpty(r) Then + Compare = 0 + Else + Compare = -1 + End If + Else + If IsNullOrEmpty(bsr) Then + Compare = 1 + Else + Compare = Strings.ChrCmp(l.bs, l.Length As SIZE_T, r.bs, r.Length As SIZE_T) + End If + End If + End Function + + Static Function IsNullOrEmpty(s As BString) + If IsNothing(s) Then + IsNullOrEmpty = True + ElseIf s.bs = 0 Then + IsNullOrEmpty = True + ElseIf s.Length = 0 Then + IsNullOrEmpty = True + Else + IsNullOrEmpty = False + End If + End Function + + Function Operator ==(s As BString) As Boolean + Return Compare(This, s) = 0 + End Function + + Function Operator <>(s As BString) As Boolean + Return Compare(This, s) <> 0 + End Function + + Function Operator <(s As BString) As Boolean + Return Compare(This, s) < 0 + End Function + + Function Operator <=(s As BString) As Boolean + Return Compare(This, s) <= 0 + End Function + + Function Operator >(s As BString) As Boolean + Return Compare(This, s) > 0 + End Function + + Function Operator >=(s As BString) As Boolean + Return Compare(This, s) >= 0 + End Function + Private bs As BSTR - Sub Init(s As PCSTR, len As DWord) - Dim lenBS = MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, 0, 0) - bs = SysAllocStringLen(0, lenBS) - MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, bs, lenBS) - End Sub - - Static Sub Copy(ByRef dst As BSTR, ByVal src As BSTR) - dst = SysAllocStringLen(src, SysStringLen(src)) - End Sub - - Static Sub Move(ByRef dst As BSTR, ByRef src As BSTR) - dst = src - src = 0 - End Sub + Sub init(s As PCSTR, len As DWord) + If <> 0 Then + Dim lenBS = MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, 0, 0) + bs = SysAllocStringLen(0, lenBS) + If bs <> 0 Then + MultiByteToWideChar(CP_THREAD_ACP, 0, s, len As Long, bs, lenBS) + End If + End If + End Sub + + Sub reset(newBS As BSTR) + Dim old = InterlockedExchangePointer(bs, newBS) + SysFreeString(old) + End Sub + + Static Function copy(src As BSTR) As BSTR + copy = SysAllocStringLen(src, SysStringLen(src)) + End Function + + Static Function move(ByRef src As BSTR) As BSTR + move = InterlockedExchangePointer(src, 0) + End Function End Class Index: trunk/Include/com/currency.ab =================================================================== --- trunk/Include/com/currency.ab (revision 355) +++ trunk/Include/com/currency.ab (revision 478) @@ -2,7 +2,4 @@ #require - -#ifndef _COM_CURRENCY_AB -#define _COM_CURRENCY_AB Namespace ActiveBasic @@ -56,5 +53,5 @@ Return ret End Function -/* + Const Function Operator /(y As Variant) As Double Dim vx = New Variant(This) @@ -69,5 +66,5 @@ Return ret.ValR8 End Function -*/ + Const Function Operator +(y As Currency) As Currency Dim ret = New Currency @@ -131,5 +128,5 @@ Return c = VARCMP_LT End Function -/* + Const Function Operator >(y As Currency) As Boolean Dim c = Compare(This, y) @@ -141,5 +138,5 @@ Return c = VARCMP_GT End Function -*/ + Const Function Operator <=(y As Currency) As Boolean Dim c = Compare(This, y) @@ -183,5 +180,5 @@ Const Function Cy() As CY - Return cy + Cy = cy End Function @@ -203,8 +200,10 @@ Override Function ToString() As String - Dim bs As BSTR - VarBstrFromCy(cy, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) - ToString = New String(bs As PCWSTR, SysStringLen(bs) As Long) - SysFreeString(bs) + /*Using*/ Dim bstr = New BString + Dim bs As BSTR + VarBstrFromCy(cy, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) + bstr.Attach(bs) + ToString = bstr.ToString + bstr.Dispose() 'End Using End Function @@ -223,4 +222,2 @@ End Namespace 'COM End Namespace 'ActiveBasic - -#endif '_COM_CURRENCY_AB Index: trunk/Include/com/decimal.ab =================================================================== --- trunk/Include/com/decimal.ab (revision 355) +++ trunk/Include/com/decimal.ab (revision 478) @@ -1,5 +1,4 @@ ' com/decimal.ab -'#require #require #require @@ -14,16 +13,14 @@ Sub Decimal(d As Decimal) -' dec = d なぜかコンパイルできない - memcpy(VarPtr(dec), VarPtr(d.dec), Len(dec)) + dec = d.dec End Sub Sub Decimal(ByRef d As DECIMAL) - memcpy(VarPtr(dec), VarPtr(d), Len(dec)) + dec = d End Sub Sub Decimal(lo As Long, mid As Long, hi As Long, isNegative As Boolean, scale As Byte) If scale > 28 Then - Debug - Throw New ArgumentOutOfRangeException + Throw New ArgumentOutOfRangeException("scale") End If Dim sign As Byte @@ -284,5 +281,5 @@ Return c = VARCMP_LT End Function -/* + Const Function Operator >(y As Decimal) As Boolean Dim c = Compare(This, y) @@ -294,5 +291,5 @@ Return c = VARCMP_GT End Function -*/ + Const Function Operator <=(y As Decimal) As Boolean Dim c = Compare(This, y) @@ -348,8 +345,10 @@ Override Function ToString() As String - Dim bs As BSTR - VarBstrFromDec(dec, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) - ToString = New String(bs As PCWSTR, SysStringLen(bs) As Long) - SysFreeString(bs) + /*Using*/ Dim bstr = New BString + Dim bs As BSTR + VarBstrFromDec(dec, LOCALE_USER_DEFAULT, LOCALE_USE_NLS, bs) + bstr.Attach(bs) + ToString = bstr.ToString + bstr.Dispose() 'End Using End Function Index: trunk/Include/com/variant.ab =================================================================== --- trunk/Include/com/variant.ab (revision 355) +++ trunk/Include/com/variant.ab (revision 478) @@ -1,9 +1,4 @@ ' com/variant.ab -#ifndef _COM_VARIANT_AB -#define _COM_VARIANT_AB - -'#require -'#require '#require @@ -79,17 +74,17 @@ Sub Variant(bs As BString) v.vt = VT_BSTR - SetPointer(VarPtr(v.val), SysAllocStringLen(bs.BStr, bs.Length)) - End Sub - - Sub Variant(p As *IUnknown) - p->AddRef() + SetPointer(VarPtr(v.val), bs.Copy)) + End Sub + + Sub Variant(unk As IUnknown) + If Not IsNothing(unk) Then unk.AddRef() v.vt = VT_UNKNOWN - SetPointer(VarPtr(v.val), p) - End Sub - - Sub Variant(p As *IDispatch) - p->AddRef() + SetPointer(VarPtr(v.val), ObjPtr(unk)) + End Sub + + Sub Variant(disp As IDispatch) + If Not IsNothing(disp) Then disp.AddRef() v.vt = VT_DISPATCH - SetPointer(VarPtr(v.val), p) + SetPointer(VarPtr(v.val), ObjPtr(disp)) End Sub /* @@ -284,5 +279,5 @@ Static Function Compare(x As Variant, y As Variant, lcid As LCID, flags As DWord) As HRESULT - Return VarCmp(x.v, y.v, lcid, flags) + Return VarCmp(removeNull(x).v, removeNull(y).v, lcid, flags) End Function @@ -290,64 +285,38 @@ Return VarCmp(x.v, y.v, LOCALE_USER_DEFAULT, 0) 'VARCMP_NULL = 3を返す場合があるので注意 End Function -/* + Const Function Operator ==(y As Variant) As Boolean Dim c = Compare(This, y) - If c = VARCMP_EQ Then - Return True - Else - Return False - End If + Return c = VARCMP_EQ End Function Const Function Operator <>(y As Variant) As Boolean Dim c = Compare(This, y) - If c <> VARCMP_EQ Then - Return True - Else - Return False - End If + Return c <> VARCMP_EQ End Function Const Function Operator <(y As Variant) As Boolean Dim c = Compare(This, y) - If c = VARCMP_LT Then - Return True - Else - Return False - End If - End Function -/* + Return c = VARCMP_LT + End Function + Const Function Operator >(y As Variant) As Boolean Dim c = Compare(This, y) - If c = VARCMP_GT Then - Return True - Else - Return False - End If - End Function -*/ -/* + Return c = VARCMP_GT + End Function + Const Function Operator <=(y As Variant) As Boolean Dim c = Compare(This, y) - If c = VARCMP_LT Or c = VARCMP_EQ Then - Return True - Else - Return False - End If + Return c = VARCMP_LT Or c = VARCMP_EQ End Function Const Function Operator >=(y As Variant) As Boolean Dim c = Compare(This, y) - If c = VARCMP_GT Or c = VARCMP_EQ Then - Return True - Else - Return False - End If - End Function -*/ + Return c = VARCMP_GT Or c = VARCMP_EQ + End Function + Const Function ChangeType(vt As VARTYPE, flags As Word) As Variant - Dim ret = New Variant - ChangeType(ret, flags, vt) - Return ret + ChangeType = New Variant + ChangeType(ChangeType, flags, vt) End Function @@ -369,7 +338,7 @@ Override Function ToString() As String - Dim tmp = ChangeType(VT_BSTR, VARIANT_ALPHABOOL) - Dim bs = ((tmp.v.val As ULONG_PTR) As BSTR) - Return New String(bs As PCWSTR, SysStringLen(bs) As Long) + /*Using*/ Dim bs = ValStr + ToString = bs.ToString + bstr.Dispose() 'End Using End Function @@ -526,9 +495,8 @@ Const Function ValStr() As BString + ValStr = New BString Dim r As VARIANT ChangeType(r, VARIANT_ALPHABOOL, VT_BSTR) - Dim bs = New BString - bs.Attach(GetPointer(VarPtr(r.val)) As BSTR) - Return bs + ValStr.Attach(GetPointer(VarPtr(r.val)) As BSTR) End Function @@ -536,17 +504,23 @@ Clear() v.vt = VT_BSTR - SetPointer(VarPtr(v.val), x.Copy()) - End Sub - - Const Function ValUnknown() As *IUnknown + If IsNothing(x) Then + SetPointer(VarPtr(v.val), SysAllocStringLen(0)) + Else + SetPointer(VarPtr(v.val), x.Copy()) + End If + End Sub + + Const Function ValUnknown() As IUnknown Dim r As VARIANT ChangeType(r, 0, VT_UNKNOWN) - Return GetPointer(VarPtr(r.val)) As *IUnknown - End Function - - Sub ValUnknown(x As *IUnknown) - Clear() - SetPointer(VarPtr(v.val), x) - x->AddRef() + Return _System_PtrUnknown(r.val As ULONG_PTR As VoidPtr) + End Function + + Sub ValUnknown(x As IUnknown) + Clear() + SetPointer(VarPtr(v.val), ObjPtr(x)) + If Not IsNothing(x) Then + x.AddRef() + End If v.vt = VT_UNKNOWN End Sub @@ -587,10 +561,20 @@ Static Function OptionalParam() As Variant -' If _System_VariantOptionalParam = Nothing Then -' 'ToDo マルチスレッド対応 - VariantOptionalParam = New Variant - VariantOptionalParam.ValError = DISP_E_PARAMNOTFOUND -' End If - Return VariantOptionalParam + If IsNothing(optionalParam) Then + Dim t = New Variant + t.ValError = DISP_E_PARAMNOTFOUND + InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0) + End If + Return optionalParam + End Function + + Static Function Null() As Variant + If IsNothing(optionalParam) Then + Dim t = New Variant + Dim p = t.PtrToVariant + p->vt = VT_NULL + InterlockedCompareExchangePointer(ByVal VarPtr(optionalParam), ObjPtr(t), 0) + End If + Return optionalParam End Function Private @@ -605,7 +589,16 @@ ' src.vt = VT_EMPTY End Sub + + Static Function removeNull(v As Variant) As Varinat + If IsNothing(v) Then + removeNull = Null + Else + removeNull = v + End If + End Function + + Static optionalParam = Nothing As Variant + Static null = Nothing As Variant End Class - -Dim VariantOptionalParam = Nothing As Variant /* @@ -629,4 +622,2 @@ End Namespace 'COM End Namespace 'ActiveBasic - -#endif '_COM_VARIANT_AB