Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Рейтинг: 4.00. Голосов: 1.

Хеш - таблица VB6

Запись от The trick размещена 08.11.2014 в 03:43
Обновил(-а) The trick 10.10.2015 в 01:33

Как-то я уже делал реализацию простой хеш-таблицы для демонстрации использования IEnumVariant интерфейса для перечисления в цикле For Each. Представляю автономный класс реализующий хеш-таблицу, который во многих случаях может стать заменой словаря (Dictionary) из Scripting runtime. Реализованы все те же методы что и у словаря, а также добавлены новые.
Включена поддержка перечисления через For Each, также можно задавать режим перечисления ключи/значения, также по сравнению с предыдущей версией исправлены баги вылета из среды при остановки в теле циклов For Each, а также нет никаких ограничений на вложенные циклы. Работает достаточно быстро, на моей машине приблизительно также (даже чуть быстрее) как словарь при двоичном сравнении, при текстовом сравнении работает почти в 2-раза быстрее словаря. В качестве ключей допускаются Variant переменные с типам от vbEmpty до vbDecimal включительно. Числовые ключи должны быть уникальны, т.е. -1, True, -1e0 - один и тот же ключ как и в словаре.
Новый метод EnumMode - определяет текущий режим перечисления. Допустимые значения ENUM_BY_KEY, ENUM_BY_VALUE. При входе в цикл For Each начинает перечисляться тот параметр, который задан этим свойством. Например можно перечислять в главном цикле ключи, во вложенном значения, или сначала ключи потом значения. Также задавая это свойство в окнах Locals или Watch можно переключать отображение с ключей на значения и обратно.
Нажмите на изображение для увеличения
Название: Безымянный_1.png
Просмотров: 498
Размер:	34.1 Кб
ID:	2825
Сама реализация представляет собой массив двусвязных списков, где индексы массива - хеш-значения соответствующих ключей. Для поддержки перечисления используется объект-перечислитель. Реализация интерфейса IEnumVariant и IUnknown для перечислителя написана на ассемблере:
Assembler
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
[BITS 32]
 
QueryInterface:
    mov eax,[esp+4]         ; ObjPtr
    inc dword [eax+4]       ; Counter++
    mov ecx, [esp+0xc]
    mov [ecx],eax           ; ppvObject = ObjPtr
    xor eax,eax             ; Success
    ret 0xc
 
AddRef:
    mov eax,[esp+4]         ; ObjPtr
    inc dword [eax+4]       ; Counter++
    mov eax, [eax+4]        ; Counter return
    ret 0x4
 
Release:
    mov eax,[esp+4]         ; ObjPtr
    dec dword [eax+4]       ; Counter--
    jz  RemoveObject        ; if (Counter == 0)
    mov eax, [eax+4]        ; Counter return
    ret 0x4
RemoveObject:
    push    eax             ; lpMem
    push    0x00000001      ; HEAP_NO_SERIALIZE
    call    0x12345678      ; GetProcessHeap
    push    eax             ; hHeap
    call    0x12345678      ; HeapFree
    xor eax,eax             ; Counter = 0
    ret 0x4
 
IEnumVariant_Next:
    push ebx
    push edi
    push esi
 
    mov esi, [esp+0x10]     ; ObjPtr
    mov ebx, [esp+0x14]     ; ebx = celt
    mov edi, [esp+0x18]     ; rgVar
 
NextItem:
 
        movsx   eax, word [esi+0x8] ; Pointer.Hash
        inc eax
        jz  ExitCycle           ; if (Pointer.Hash == -1)
        dec eax
        mov ecx, [esi+0xc]      ; DataPtr
        mov ecx, [ecx+eax*8+4]  ; ecx = tItem.tElement
        movzx   eax, word [esi+0xA] ; Pointer.Index
        imul    ax, ax, 0x28        ;
        movzx   eax, ax         ; eax = Pointer.Index * sizeof(tElement)
        mov ecx, [ecx+0xc]      ; ecx = *tElement(0)
        lea ecx, [ecx+eax]      ; *tElement(Pointer.Index)
        mov eax, [ecx+0x20]
        add ecx, [esi+0x14]     ; ecx += OffsetVarinat
        mov [esi+0x8], eax      ; Pointer = tElement(Pointer.Index).Next
        push    ecx             ; pvargSrc
        push    edi             ; pvargDest == rgVar
        call    0x12345678      ; VariantCopy
 
        add edi, 0x10
        dec ebx
        jne NextItem
        
ExitCycle:
    
    test ebx, ebx
    setne   dl              ; if (ebx = 0) dl = 0 else dl = 1
    movzx   esi, dl         ; edx = dl
    
    mov edi, [esp+0x1c]     ; pCeltFetched
    test edi, edi
    je ExitFunction
    
    mov eax, [esp+0x14]     ; eax = celt
    sub eax, ebx
    mov     [edi], eax      ; pCeltFetched = count
 
ExitFunction:
    
    mov eax, esi
    pop esi
    pop edi
    pop ebx
    ret 0x10
 
IEnumVariant_Skip:
 
    mov edx, [esp+0x04]     ; ObjPtr
    mov eax, [edx+0x8]      ; Pointer.Hash
    mov edx, [edx+0xc]      ; DataPtr
 
NextItem_2:
        
        inc ax
        jz  ExitCycle_2         ; if (Pointer.Hash == -1)
        dec ax
        
        movzx   ecx, ax         ; ecx = Pointer.Hash
        mov ecx, [edx+ecx*8+4]  ; ecx = tItem.tElement
        shr eax, 0x10           ; eax = Pointer.Index
        imul    ax, ax, 0x28    ;
 
        mov ecx, [ecx+0xc]      ; ecx = *tElement(0)
        mov eax, [ecx+eax+0x20] ; eax = tElement(Pointer.Index).Next
        
        dec dword [esp+0x08]    ; celt--
        jne NextItem_2
        
        xor edx, edx
 
ExitCycle_2:
    
    test edx, edx
    setne   dl              ; if (edx = 0) dl = 0 else dl = 1
    mov eax, edx
    
    ret 0x08
 
IEnumVariant_Reset:
    mov eax, [esp+0x04]     ; ObjPtr
    mov edx, [eax+0x10]     ; First
    mov [eax+0x08], edx     ; Pointer = First
    xor eax, eax
    ret 0x4
Код создается только при создании первого объекта, и используется всеми последующими объектами. Адрес хранится в переменных окружения, также как я это делал в сабклассинге.
Вот сам код класса:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
' // clsTrickHashTable.cls  - Hash table class
' // © Krivous Anatolii Anatolevich (The trick), 2014
' // Version 1.2
' // Special thanks to Dragokas for debugging.
 
Option Explicit
 
Public Enum CompareMethod
    BinaryCompare
    TextCompare
End Enum
 
Public Enum EnumMethod
    ENUM_BY_KEY
    ENUM_BY_VALUE
End Enum
 
Private Declare Function SetEnvironmentVariable Lib "kernel32" _
                         Alias "SetEnvironmentVariableW" ( _
                         ByVal lpName As Long, _
                         ByVal lpValue As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" _
                         Alias "GetEnvironmentVariableW" ( _
                         ByVal lpName As Long, _
                         ByVal lpBuffer As Long, _
                         ByVal nSize As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" ( _
                         ByRef lpAddress As Any, _
                         ByVal dwSize As Long, _
                         ByVal flAllocationType As Long, _
                         ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" ( _
                         ByRef lpAddress As Any, _
                         ByVal dwSize As Long, _
                         ByVal dwFreeType As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" ( _
                         ByVal hHeap As Long, _
                         ByVal dwFlags As Long, _
                         ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function GetMem8 Lib "msvbvm60" ( _
                         ByRef Src As Any, _
                         ByRef Dst As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                         ByRef Src As Any, _
                         ByRef Dst As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" ( _
                         ByRef Src As Any, _
                         ByRef Dst As Any) As Long
Private Declare Function GetMem1 Lib "msvbvm60" ( _
                         ByRef Src As Any, _
                         ByRef Dst As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                         Alias "GetModuleHandleW" ( _
                         ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
                         ByVal hModule As Long, _
                         ByVal lpProcName As String) As Long
Private Declare Function memcpy Lib "kernel32" _
                         Alias "RtlMoveMemory" ( _
                         ByRef Destination As Any, _
                         ByRef Source As Any, _
                         ByVal length As Long) As Long
Private Declare Function VarCmp Lib "oleaut32" ( _
                         ByRef pvarLeft As Any, _
                         ByRef pvarRight As Any, _
                         ByVal lcid As Long, _
                         ByVal dwFlags As Long) As Long
Private Declare Function VariantCopy Lib "oleaut32" ( _
                         ByRef pvargDest As Any, _
                         ByRef pvargSrc As Any) As Long
Private Declare Function VariantCopyInd Lib "oleaut32" ( _
                         ByRef pvarDest As Any, _
                         ByRef pvargSrc As Any) As Long
Private Declare Function LCMapString Lib "kernel32" _
                         Alias "LCMapStringW" ( _
                         ByVal Locale As Long, _
                         ByVal dwMapFlags As Long, _
                         ByRef lpSrcStr As Any, _
                         ByVal cchSrc As Long, _
                         ByRef lpDestStr As Any, _
                         ByVal cchDest As Long) As Long
Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Private Declare Function VarR4FromUI1 Lib "oleaut32" ( _
                         ByRef value As Any, _
                         ByRef R4 As Any) As Long
Private Declare Function VarR4FromI2 Lib "oleaut32" ( _
                         ByRef value As Any, _
                         ByRef R4 As Any) As Long
Private Declare Function VarR4FromI4 Lib "oleaut32" ( _
                         ByRef value As Any, _
                         ByRef R4 As Any) As Long
 
Private Const LCMAP_LOWERCASE           As Long = &H100
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE               As Long = &H2000&
Private Const MEM_RELEASE               As Long = &H8000&
Private Const HEAP_NO_SERIALIZE         As Long = &H1
Private Const GRANULARITY               As Long = &H20
Private Const HASH_SIZE                 As Long = 2999
 
Private Type tPointer                                                           ' // Index into the object table
    hash            As Integer                                                  ' // Hash value
    Index           As Integer                                                  ' // Index
End Type
Private Type tElement                                                           ' // Column of the hash table
    Key             As Variant                                                  ' // Key
    value           As Variant                                                  ' // Value
    Next            As tPointer                                                 ' // Index of the next item
    Prev            As tPointer                                                 ' // Index of the previous item
End Type
Private Type tItem                                                              ' // Row of the hash table
    ElementsCount   As Long                                                     ' // Number of the collisions +1
    Elements()      As tElement                                                 ' // List of items
End Type
Private Type enumObject                                                         ' // COM-enumeration object
    vTablePtr       As Long                                                     ' // Pointer to the IEnumVariant interface
    Counter         As Long                                                     ' // Counter of the references
    Pointer         As tPointer                                                 ' // Current item index
    DataPtr         As Long                                                     ' // Pointer to List
    First           As tPointer                                                 ' // Pointer to first item
    OffsetVariant   As Long                                                     ' // Offset of enumeration variable (key/value)
End Type
 
Private List()          As tItem                                                ' // Table
Private mEnumMode       As EnumMethod                                           ' // Current enumeration mode
Private mCount          As Long                                                 ' // Number of the items
Private mCompareMode    As VbCompareMethod                                      ' // Current compare mode
Private First           As tPointer                                             ' // Index of first item
Private Last            As tPointer                                             ' // Index of last item
Private locbuf()        As Integer                                              ' // String buffer
Private lpAsm           As Long
Private lcid            As Long
Private decMin          As Variant
Private decMax          As Variant
 
' // Obtain the enumerator
Public Property Get NewEnum() As IUnknown
    Dim enumObject  As Long
    
    enumObject = CreateEnumObject()
    If enumObject = 0 Then Exit Function
    GetMem4 enumObject, ByVal NewEnum
    
End Property
 
' // Set/Get the enumeration mode
Public Property Get EnumMode() As EnumMethod
    EnumMode = mEnumMode
End Property
Public Property Let EnumMode(ByVal value As EnumMethod)
    mEnumMode = value
End Property
 
' // Set/Get the compare mode
Public Property Get CompareMode() As CompareMethod
    CompareMode = mCompareMode
End Property
Public Property Let CompareMode(ByVal value As CompareMethod)
    If mCount Then Err.Raise 5: Exit Property    ' Только когда элементов нет
    mCompareMode = value
End Property
 
' // Add the new item
Public Sub Add(Key As Variant, value As Variant)
    Dim pt As tPointer
    
    If Not GetFromKey(Key, pt) Then
        Err.Raise 5
        Exit Sub
    End If
    
    If pt.Index <> -1 Then
        Err.Raise 457
        Exit Sub
    End If
    
    pt.Index = List(pt.hash).ElementsCount
    
    Add_ pt, Key, value
    
End Sub
 
' // Retrieve the value by specified key
Public Property Get Item(Key As Variant) As Variant
    Dim pt As tPointer
 
    If Not GetFromKey(Key, pt) Then
        Err.Raise 5
        Exit Property
    End If
    
    If pt.Index = -1 Then Err.Raise 5: Exit Property
    VariantCopy Item, List(pt.hash).Elements(pt.Index).value
    
End Property
 
' // Set the value of the specified item
Public Property Let Item(Key As Variant, value As Variant)
    Dim pt As tPointer
    
    If Not GetFromKey(Key, pt) Then
        Err.Raise 5
        Exit Property
    End If
    
    If pt.Index = -1 Then Err.Raise 5: Exit Property
    List(pt.hash).Elements(pt.Index).value = value
    
End Property
 
' // Set the objected-value of the specified item
Public Property Set Item(Key As Variant, value As Variant)
    Dim pt As tPointer
    
    If Not GetFromKey(Key, pt) Then
        Err.Raise 5
        Exit Property
    End If
    
    If pt.Index = -1 Then Err.Raise 5: Exit Property
    Set List(pt.hash).Elements(pt.Index).value = value
    
End Property
 
' // Update the key
Public Property Let Key(Key As Variant, NewKey As Variant)
    Key_ Key, NewKey
End Property
 
' // Update the object key
Public Property Set Key(Key As Variant, NewKey As Variant)
    Key_ Key, NewKey
End Property
 
' // Retrieve the number of the items
Public Property Get Count() As Long
    Count = mCount
End Property
 
' // Determine whether exists the element with the specified key
Public Function Exists(Key As Variant) As Boolean
    Dim pt As tPointer
    
    If Not GetFromKey(Key, pt) Then
        Err.Raise 5
        Exit Function
    End If
    
    Exists = pt.Index <> -1
End Function
 
' // Remove the item, having the specified key
Public Sub Remove(Key As Variant)
    Dim pt  As tPointer
    Dim ln  As tPointer
    Dim lp  As tPointer
    Dim p   As tPointer
    Dim l   As Long
    
    If Not GetFromKey(Key, pt) Then
        Err.Raise 5
        Exit Sub
    End If
    
    If pt.Index = -1 Then
        Err.Raise 5
        Exit Sub
    End If
    
    Remove_ pt
    
End Sub
 
' // Remove the all items
Public Sub RemoveAll()
    Call Class_Initialize
End Sub
 
' // Retrieve the list of the values
Public Function Items() As Variant
    Dim pt      As tPointer
    Dim i       As Long
    Dim ret()   As Variant
    
    If mCount = 0 Then Items = Array(): Exit Function
    pt = First
    ReDim ret(mCount - 1)
    
    Do
    
        VariantCopy ret(i), List(pt.hash).Elements(pt.Index).value
        pt = List(pt.hash).Elements(pt.Index).Next
        i = i + 1
        
    Loop While i < mCount
    
    Items = ret
    
End Function
 
' // Retrieve the list of the keys
Public Function Keys() As Variant
    Dim pt As tPointer, i As Long, ret() As Variant
    
    If mCount = 0 Then Keys = Array(): Exit Function
    
    pt = First
    ReDim ret(mCount - 1)
    
    Do
    
        VariantCopy ret(i), List(pt.hash).Elements(pt.Index).Key
        pt = List(pt.hash).Elements(pt.Index).Next
        i = i + 1
        
    Loop While i < mCount
    
    Keys = ret
End Function
 
' // Calculate the hash value
Public Function HashValue(value As Variant) As Long
    Dim hash    As Long
    
    hash = CalcHash(value)
    
    If hash < 0 Then
        Err.Raise 5
        Exit Function
    End If
    
    HashValue = hash
    
End Function
 
' //
Private Sub Add_(pt As tPointer, Key As Variant, value As Variant)
 
    If pt.Index Then
        If pt.Index > UBound(List(pt.hash).Elements) Then
            ReDim Preserve List(pt.hash).Elements(UBound(List(pt.hash).Elements) + GRANULARITY)
        End If
    Else
        ReDim Preserve List(pt.hash).Elements(GRANULARITY - 1)
    End If
    
    List(pt.hash).ElementsCount = pt.Index + 1
    
    VariantCopyInd List(pt.hash).Elements(pt.Index).value, value
    VariantCopyInd List(pt.hash).Elements(pt.Index).Key, Key
    
    If Last.hash >= 0 Then
        List(Last.hash).Elements(Last.Index).Next = pt
        List(pt.hash).Elements(pt.Index).Prev = Last
    Else
        List(pt.hash).Elements(pt.Index).Prev.hash = -1
        List(pt.hash).Elements(pt.Index).Prev.Index = -1
        First = pt
    End If
    
    List(pt.hash).Elements(pt.Index).Next.hash = -1
    List(pt.hash).Elements(pt.Index).Next.Index = -1
    
    Last = pt
    mCount = mCount + 1
    
End Sub
 
Private Sub Remove_(pt As tPointer)
    Dim ln  As tPointer
    Dim lp  As tPointer
    Dim p   As tPointer
    Dim l   As Long
 
    lp = List(pt.hash).Elements(pt.Index).Prev
    ln = List(pt.hash).Elements(pt.Index).Next
    
    For l = pt.Index To List(pt.hash).ElementsCount - 2
    
        List(pt.hash).Elements(l) = List(pt.hash).Elements(l + 1)
        
        ' // Update the references to the item
        p = List(pt.hash).Elements(l).Prev
        
        If p.Index >= 0 Then List(p.hash).Elements(p.Index).Next.Index = List(p.hash).Elements(p.Index).Next.Index - 1
            
        p = List(pt.hash).Elements(l).Next
        
        If p.Index >= 0 Then List(p.hash).Elements(p.Index).Prev.Index = List(p.hash).Elements(p.Index).Prev.Index - 1
        
    Next
    
    l = List(pt.hash).ElementsCount - 1: List(pt.hash).ElementsCount = l
    
    If l Then
        If (l Mod GRANULARITY) = 0 Then ReDim Preserve List(pt.hash).Elements(l - 1)
    Else
        Erase List(pt.hash).Elements()
    End If
    
    If lp.Index >= 0 Then List(lp.hash).Elements(lp.Index).Next = ln
    If ln.Index >= 0 Then List(ln.hash).Elements(ln.Index).Prev = lp
    If lp.Index = -1 Then First = ln
    If ln.Index = -1 Then Last = lp
    
    mCount = mCount - 1
    
End Sub
 
Private Sub Key_(Key As Variant, NewKey As Variant)
    Dim pt1     As tPointer
    Dim pt2     As tPointer
    Dim value   As Variant
    
    If Not GetFromKey(Key, pt1) Then
        Err.Raise 5
        Exit Sub
    End If
    
    If pt1.Index = -1 Then Err.Raise 5: Exit Sub
    
    If Not GetFromKey(NewKey, pt2) Then
        Err.Raise 5
        Exit Sub
    End If
    
    If pt2.Index <> -1 Then Err.Raise 457: Exit Sub
 
    VariantCopy value, List(pt1.hash).Elements(pt1.Index).value
    Remove_ pt1
    pt2.Index = List(pt2.hash).ElementsCount
    Add_ pt2, NewKey, value
    
End Sub
 
Private Function GetFromKey(Key As Variant, Pointer As tPointer) As Boolean
    Dim i       As Long
    Dim hash    As Long
    Dim typ     As Integer
    Dim keyi    As Variant
    Dim lPtr    As Long
    
    hash = CalcHash(Key)
    
    If hash >= 0 Then
    
        Pointer.hash = hash
        GetFromKey = True
        
        VariantCopyInd keyi, Key
        lPtr = VarPtr(keyi)
        
        GetMem2 ByVal lPtr, typ
        
        Select Case typ
        Case vbString
        
            For i = 0 To List(hash).ElementsCount - 1
                
                If VarCmp(List(hash).Elements(i).Key, keyi, lcid, mCompareMode) = 1 Then
                    Pointer.Index = i
                    Exit Function
                End If
                
            Next
            
        Case vbObject, vbDataObject
            
            GetMem4 ByVal lPtr + 8, lPtr
            
            For i = 0 To List(hash).ElementsCount - 1
                
                GetMem2 List(hash).Elements(i).Key, typ
                
                If typ = vbObject Or typ = vbDataObject Then
                    
                    If List(hash).Elements(i).Key Is keyi Then
                    
                        Pointer.Index = i
                        Exit Function
                        
                    End If
                    
                End If
 
            Next
        
        Case vbNull
            
            For i = 0 To List(hash).ElementsCount - 1
 
                If IsNull(List(hash).Elements(i).Key) Then
                
                    Pointer.Index = i
                    Exit Function
                    
                End If
                    
            Next
            
        Case vbEmpty
            
            For i = 0 To List(hash).ElementsCount - 1
 
                If IsEmpty(List(hash).Elements(i).Key) Then
                
                    Pointer.Index = i
                    Exit Function
                    
                End If
                    
            Next
            
        Case Else
        
            For i = 0 To List(hash).ElementsCount - 1
                
                If List(hash).Elements(i).Key = keyi Then
                    Pointer.Index = i
                    Exit Function
                End If
                
            Next
            
        End Select
                
    End If
    
    Pointer.Index = -1
    
End Function
 
Private Function CalcHash(value As Variant) As Long
    Dim i       As Long
    Dim typ     As Integer
    Dim ptr     As Long
    Dim length  As Long
    Dim dbl     As Double
    Dim cur     As Currency
    Dim sgl     As Single
    
    ptr = VarPtr(value)
    GetMem2 ByVal ptr, typ
    
    Do While typ = &H400C
        
        GetMem2 ByVal ptr + 8, ptr
        GetMem2 ByVal ptr, typ
        
    Loop
    
    ptr = ptr + 8
    
    If typ And &H4000 Then
        
        GetMem4 ByVal ptr, ptr
        typ = typ And &HBFFF&
        
    End If
    
    Select Case typ
    Case vbString
        
        GetMem4 ByVal ptr, ptr
        
        If ptr = 0 Then CalcHash = 0: Exit Function
        
        GetMem4 ByVal ptr - 4, length
        length = length \ 2
        
        If length >= UBound(locbuf) Then
            ReDim locbuf(length + 1)
        End If
        
        If mCompareMode = vbTextCompare Then
        
            LCMapString lcid, LCMAP_LOWERCASE, ByVal ptr, length, locbuf(0), length
        Else
        
            memcpy locbuf(0), ByVal ptr, length * 2&
        End If
        
        For i = 0 To length - 1
            CalcHash = (CalcHash * 37& + locbuf(i) And &HFFFF&)
        Next
        
    Case vbByte
    
        GetMem1 ByVal ptr, CalcHash
        VarR4FromUI1 ByVal CalcHash, CalcHash
        
    Case vbInteger, vbBoolean
 
        GetMem2 ByVal ptr, CalcHash
        VarR4FromI2 ByVal CalcHash, CalcHash
        
    Case vbLong, vbError
        
        GetMem4 ByVal ptr, i
        If i > 9999999 Or i < -9999999 Then
            CalcHash = 0
        Else
            VarR4FromI4 ByVal CalcHash, CalcHash
        End If
        
    Case vbSingle
    
        GetMem8 ByVal ptr, sgl
        If sgl > 9999999 Or sgl < -9999999 Then
            CalcHash = 0
        Else
            GetMem4 sgl, CalcHash
        End If
        
    Case vbObject, vbDataObject
    
        GetMem4 ByVal ptr, CalcHash
        
    Case vbDouble, vbDate
        
        GetMem8 ByVal ptr, dbl
        If dbl > 9999999 Or dbl < -9999999 Then
            CalcHash = 0
        Else
            GetMem4 CSng(dbl), CalcHash
        End If
        
    Case vbCurrency
        
        GetMem8 ByVal ptr, cur
        If dbl > 9999999@ Or dbl < -9999999@ Then
            CalcHash = 0
        Else
            GetMem4 CSng(cur), CalcHash
        End If
        
    Case vbDecimal
        
        If value > decMax Or value < decMin Then
            CalcHash = 0
        Else
            GetMem4 CSng(value), CalcHash
        End If
        
    Case vbNull, vbEmpty
    
        CalcHash = 0
        
    Case Else
    
        CalcHash = -1
        Exit Function
        
    End Select
    
    CalcHash = (CalcHash And &H7FFFFFFF) Mod HASH_SIZE
    
End Function
 
Private Function CreateEnumObject() As Long
    
    If lpAsm = 0 Then
 
        lpAsm = GetEnumInterface()
        If lpAsm = 0 Then Exit Function
        
    End If
    
    Dim newObject   As enumObject
    Dim lpObject    As Long
    
    newObject.Counter = 1
    newObject.DataPtr = VarPtr(List(0))
    newObject.vTablePtr = lpAsm + &HEC
    newObject.Pointer = First
    newObject.First = First
    newObject.OffsetVariant = IIf(mEnumMode = ENUM_BY_KEY, 0, &H10)
    
    lpObject = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(newObject))
    memcpy ByVal lpObject, newObject, Len(newObject)
    
    CreateEnumObject = lpObject
    
End Function
 
Private Function GetEnumInterface() As Long
    Dim sHex    As String
    
    sHex = Space(&H8)
    
    If GetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(sHex), Len(sHex) + 1) = 0 Then
        
        GetEnumInterface = CreateAsm()
        
    Else
    
        GetEnumInterface = CLng("&H" & sHex)
        
    End If
    
End Function
 
Private Function CreateAsm() As Long
    Dim lpAddr  As Long
    Dim dat(58) As Long
    Dim hLib    As Long
    Dim lpProc  As Long
    
    dat(0) = &H424448B:     dat(1) = &H8B0440FF:    dat(2) = &H890C244C:    dat(3) = &HC2C03101:    dat(4) = &H448B000C:
    dat(5) = &H40FF0424:    dat(6) = &H4408B04:     dat(7) = &H8B0004C2:    dat(8) = &HFF042444:    dat(9) = &H6740448:
    dat(10) = &HC204408B:   dat(11) = &H6A500004:   dat(12) = &H5642E801:   dat(13) = &HE8501234:   dat(14) = &H1234563C:
    dat(15) = &H4C2C031:    dat(16) = &H56575300:   dat(17) = &H1024748B:   dat(18) = &H14245C8B:   dat(19) = &H18247C8B:
    dat(20) = &H846BF0F:    dat(21) = &H482F7440:   dat(22) = &H8B0C4E8B:   dat(23) = &HF04C14C:    dat(24) = &H660A46B7:
    dat(25) = &HF28C06B:    dat(26) = &H498BC0B7:   dat(27) = &H10C8D0C:    dat(28) = &H320418B:    dat(29) = &H4689144E:
    dat(30) = &HE8575108:   dat(31) = &H123455F8:   dat(32) = &H4B10C783:   dat(33) = &HDB85CA75:   dat(34) = &HFC2950F:
    dat(35) = &H7C8BF2B6:   dat(36) = &HFF851C24:   dat(37) = &H448B0874:   dat(38) = &HD8291424:   dat(39) = &HF0890789:
    dat(40) = &HC25B5F5E:   dat(41) = &H548B0010:   dat(42) = &H428B0424:   dat(43) = &HC528B08:    dat(44) = &H1F744066:
    dat(45) = &HB70F4866:   dat(46) = &HCA4C8BC8:   dat(47) = &H10E8C104:   dat(48) = &H28C06B66:   dat(49) = &H8B0C498B:
    dat(50) = &HFF200144:   dat(51) = &H7508244C:   dat(52) = &H85D231DF:   dat(53) = &HC2950FD2:   dat(54) = &H8C2D089:
    dat(55) = &H24448B00:   dat(56) = &H10508B04:   dat(57) = &H31085089:   dat(58) = &H4C2C0
 
    lpAddr = VirtualAlloc(ByVal 0&, &H104, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
    If lpAddr = 0 Then Exit Function
    
    memcpy ByVal lpAddr, dat(0), &HEC
    
    hLib = GetModuleHandle(StrPtr("kernel32"))
    If hLib = 0 Then GoTo Clear
    
    lpProc = GetProcAddress(hLib, "GetProcessHeap")
    If lpProc = 0 Then GoTo Clear
    
    GetMem4 lpProc - (lpAddr + &H32 + 4), ByVal lpAddr + &H32
    
    lpProc = GetProcAddress(hLib, "HeapFree")
    If lpProc = 0 Then GoTo Clear
    
    GetMem4 lpProc - (lpAddr + &H38 + 4), ByVal lpAddr + &H38
    
    hLib = GetModuleHandle(StrPtr("oleaut32"))
    If hLib = 0 Then GoTo Clear
    
    lpProc = GetProcAddress(hLib, "VariantCopy")
    If lpProc = 0 Then GoTo Clear
    
    GetMem4 lpProc - (lpAddr + &H7C + 4), ByVal lpAddr + &H7C
    
    GetMem4 lpAddr, ByVal lpAddr + &HEC         ' // IUnknown::QueryInterface
    GetMem4 lpAddr + &H12, ByVal lpAddr + &HF0  ' // IUnknown::AddRef
    GetMem4 lpAddr + &H1F, ByVal lpAddr + &HF4  ' // IUnknown::Release
    GetMem4 lpAddr + &H41, ByVal lpAddr + &HF8  ' // IEnumVariant::Next
    GetMem4 lpAddr + &HA6, ByVal lpAddr + &HFC  ' // IEnumVariant::Skip
    GetMem4 lpAddr + &HDD, ByVal lpAddr + &H100 ' // IEnumVariant::Reset
    
    If SetEnvironmentVariable(StrPtr("TrickHashEnumerationInterface"), StrPtr(Hex(lpAddr))) = 0 Then GoTo Clear
    
    CreateAsm = lpAddr
    
    Exit Function
    
Clear:
    
    VirtualFree ByVal lpAddr, &H104, MEM_RELEASE
    
End Function
 
Private Sub Class_Initialize()
 
    ReDim List(HASH_SIZE - 1)
    ReDim locbuf(255)
    
    First.hash = -1
    First.Index = -1
    Last.hash = -1
    Last.Index = -1
    mCount = 0
    lcid = GetUserDefaultLCID()
    decMin = CDec(-9999999)
    decMax = CDec(9999999)
    
End Sub
 
Private Sub Class_Terminate()
    Erase List()
End Sub
Также я написал небольшое тестовое приложение для сравнения скоростей словаря и моей хеш-таблицы. Кнопка "Add 100000" добавляет 100000 записей в словарь/таблицу и отображает время работы. Кнопка "Clear" очищает словарь/таблицу. Кнопка "Access all" перечисляет все элементы используя доступ по ключу. Кнопка "For each" перечисляет все элементы используя For Each цикл.

Нажмите на изображение для увеличения
Название: Безымянный_1-.png
Просмотров: 393
Размер:	5.6 Кб
ID:	2826

Программа слабо тестировалась, поэтому возможны баги. Буду очень рад любым замечаниям, по мере возможности буду их исправлять.

Огромная благодарность Алексу (Dragokas) за дебаггинг.

Update:
  • 10.10.2015 - Version 1.2
Вложения
Тип файла: zip TrickHashTable.zip (42.0 Кб, 181 просмотров)
Размещено в Без категории
Показов 6609 Комментарии 5
Всего комментариев 5
Комментарии
  1. Старый комментарий
    Аватар для Dragokas
    Еще раз спасибо за особое внимание моей теме, за Исследование Dictionary и полную переработку своего класса словаря с поддержкой перечисления через For each.

    Новый функционал выглядит очень практично.
    Отмечу и "упаковку" всего интерфейса в 1 класс из-за чего теперь очень удобно
    его использовать в других проектах.

    Этот словарь будет использован в благих целях взамен словаря из библиотеки scrrun.dll
    и будет введен в проект, которым уже пользуются на системах с самой разнообразной конфигурацией
    с возможными повреждениями как самой библиотеки, так и записей о ее регистрации в реестре.

    По этогам тестирования и выявлению возможных багов еще обязательно отпишусь.
    Запись от Dragokas размещена 08.11.2014 в 10:05 Dragokas вне форума
  2. Старый комментарий
    Аватар для Dragokas
    Небольшая поправка:

    Visual Basic
    1
    2
    
    ' // Получить список ключей
    Public Function Keys() As Variant()
    нужно удалить в конце пару скобок, иначе:

    Visual Basic
    1
    2
    
    hsh.Add "key1", "item1"
    Debug.Print hsh.Keys(0)
    в отличие от аналогичного кода для словаря:
    Visual Basic
    1
    2
    
    dic.Add "key1", "item1"
    Debug.Print dic.Keys(0)
    выдаст ошибку при компиляции "Wrong number of arguments..."
    Запись от Dragokas размещена 12.06.2015 в 16:16 Dragokas вне форума
  3. Старый комментарий
    Аватар для Dragokas
    Если не против, я буду писать и о других различиях в интерфейсе использования между этим классом и Scripting.Dictionary...

    2) Создаем класс без заполнения элементов и создаем итератор:
    Visual Basic
    1
    2
    3
    
        For Each key In dic.Keys
            Stop
        Next
    не войдет в цикл. Тип возвращаемых данных = Variant(0 to -1)
    Visual Basic
    1
    2
    3
    
        For Each key In hsh.Keys
            Stop
        Next
    Вызовет исключение.
    Предлагаю скорректировать:
    Visual Basic
    1
    
    If mCount = 0 Then Exit Function
    на
    Visual Basic
    1
    
    If mCount = 0 Then Keys = Array(): Exit Function
    Запись от Dragokas размещена 12.06.2015 в 16:59 Dragokas вне форума
  4. Старый комментарий
    Аватар для Dragokas
    Класс "валит" приложение на таком коде:

    Visual Basic
    1
    2
    
    hsh.Add 1, 1
    Debug.Print hsh.Exists(vbNullString)
    Можешь, пожалуйста, взглянуть, если появится свободное время?
    Какой хеш можно задать для строки нулевой длинны, чтобы не возникло коллизии?
    .... кажется, понял, нужен 0.
    Visual Basic
    1
    2
    
    GetMem4 ByVal ptr, ptr
    if ptr = 0 then CalcHash = 0: Exit Function
    Запись от Dragokas размещена 12.06.2015 в 17:12 Dragokas вне форума
    Обновил(-а) Dragokas 12.06.2015 в 17:33
  5. Старый комментарий
    Dragokas, спасибо исправил.
    Запись от The trick размещена 10.10.2015 в 01:33 The trick вне форума
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.