-
Notifications
You must be signed in to change notification settings - Fork 2
Expand file tree
/
Copy pathMSocketSupport.bas
More file actions
1174 lines (1141 loc) · 49 KB
/
MSocketSupport.bas
File metadata and controls
1174 lines (1141 loc) · 49 KB
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
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
Attribute VB_Name = "MSocketSupport"
'********************************************************************************
'MSocketSupport module
'Copyright 2002 by Oleg Gdalevich
'Visual Basic Internet Programming website (http://www.vbip.com)
'********************************************************************************
'This module contains API declarations and helper functions for the CSocket class
'********************************************************************************
'Version: 1.0.12 Modified: 17-OCT-2002
'********************************************************************************
'To get latest version of this code please visit the following web page:
'http://www.vbip.com/winsock-api/csocket-class/csocket-class-01.asp
'********************************************************************************
Option Explicit
'
Public Const INADDR_NONE = &HFFFF
'
Public Const SOCKET_ERROR = -1
Public Const INVALID_SOCKET = -1
Public Const INADDR_ANY = &H0
'
Public Const FD_SETSIZE = 64
'
'/*
' * Define constant based on rfc883, used by gethostbyxxxx() calls.
' */
Public Const MAXGETHOSTSTRUCT = 1024
'
'/*
' * WinSock 2 extension -- manifest constants for shutdown()
' */
Public Const SD_RECEIVE = &H0
Public Const SD_SEND = &H1
Public Const SD_BOTH = &H2
'
Public Const MSG_OOB = &H1 '/* process out-of-band data */
Public Const MSG_PEEK = &H2 '/* peek at incoming message */
Public Const MSG_DONTROUTE = &H4 '/* send without using routing tables */
Public Const MSG_PARTIAL = &H8000 '/* partial send or recv for message xport */
'
Public Const FD_READ = &H1&
Public Const FD_WRITE = &H2&
Public Const FD_OOB = &H4&
Public Const FD_ACCEPT = &H8&
Public Const FD_CONNECT = &H10&
Public Const FD_CLOSE = &H20&
'
Public Const SOL_SOCKET = 65535
'
' option flags per socket
Public Const SO_DEBUG = &H1& ' Turn on debugging info recording
Public Const SO_ACCEPTCONN = &H2& ' Socket has had listen() - READ-ONLY.
Public Const SO_REUSEADDR = &H4& ' Allow local address reuse.
Public Const SO_KEEPALIVE = &H8& ' Keep connections alive.
Public Const SO_DONTROUTE = &H10& ' Just use interface addresses.
Public Const SO_BROADCAST = &H20& ' Permit sending of broadcast msgs.
Public Const SO_USELOOPBACK = &H40& ' Bypass hardware when possible.
Public Const SO_LINGER = &H80& ' Linger on close if data present.
Public Const SO_OOBINLINE = &H100& ' Leave received OOB data in line.
Public Const SO_DONTLINGER = Not SO_LINGER
Public Const SO_EXCLUSIVEADDRUSE = Not SO_REUSEADDR ' Disallow local address reuse.
' Additional options.
Public Const SO_SNDBUF = &H1001& ' Send buffer size.
Public Const SO_RCVBUF = &H1002& ' Receive buffer size.
Public Const SO_ERROR = &H1007& ' Get error status and clear.
Public Const SO_TYPE = &H1008& ' Get socket type - READ-ONLY.
'
Public Const WSADESCRIPTION_LEN = 257
Public Const WSASYS_STATUS_LEN = 129
'
Public Type WSAData
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSADESCRIPTION_LEN
szSystemStatus As String * WSASYS_STATUS_LEN
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
'
Public Type sockaddr_in
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero(1 To 8) As Byte
End Type
Public Type fd_set
fd_count As Long '// how many are SET?
fd_array(1 To FD_SETSIZE) As Long '// an array of SOCKETs
End Type
'
'/*
' * All Windows Sockets error constants are biased by WSABASEERR from
' * the "normal"
' */
Public Const WSABASEERR = 10000
'/*
' * Windows Sockets definitions of regular Microsoft C error constants
' */
Public Const WSAEINTR = (WSABASEERR + 4)
Public Const WSAEBADF = (WSABASEERR + 9)
Public Const WSAEACCES = (WSABASEERR + 13)
Public Const WSAEFAULT = (WSABASEERR + 14)
Public Const WSAEINVAL = (WSABASEERR + 22)
Public Const WSAEMFILE = (WSABASEERR + 24)
'/*
' * Windows Sockets definitions of regular Berkeley error constants
' */
Public Const WSAEWOULDBLOCK = (WSABASEERR + 35)
Public Const WSAEINPROGRESS = (WSABASEERR + 36)
Public Const WSAEALREADY = (WSABASEERR + 37)
Public Const WSAENOTSOCK = (WSABASEERR + 38)
Public Const WSAEDESTADDRREQ = (WSABASEERR + 39)
Public Const WSAEMSGSIZE = (WSABASEERR + 40)
Public Const WSAEPROTOTYPE = (WSABASEERR + 41)
Public Const WSAENOPROTOOPT = (WSABASEERR + 42)
Public Const WSAEPROTONOSUPPORT = (WSABASEERR + 43)
Public Const WSAESOCKTNOSUPPORT = (WSABASEERR + 44)
Public Const WSAEOPNOTSUPP = (WSABASEERR + 45)
Public Const WSAEPFNOSUPPORT = (WSABASEERR + 46)
Public Const WSAEAFNOSUPPORT = (WSABASEERR + 47)
Public Const WSAEADDRINUSE = (WSABASEERR + 48)
Public Const WSAEADDRNOTAVAIL = (WSABASEERR + 49)
Public Const WSAENETDOWN = (WSABASEERR + 50)
Public Const WSAENETUNREACH = (WSABASEERR + 51)
Public Const WSAENETRESET = (WSABASEERR + 52)
Public Const WSAECONNABORTED = (WSABASEERR + 53)
Public Const WSAECONNRESET = (WSABASEERR + 54)
Public Const WSAENOBUFS = (WSABASEERR + 55)
Public Const WSAEISCONN = (WSABASEERR + 56)
Public Const WSAENOTCONN = (WSABASEERR + 57)
Public Const WSAESHUTDOWN = (WSABASEERR + 58)
Public Const WSAETOOMANYREFS = (WSABASEERR + 59)
Public Const WSAETIMEDOUT = (WSABASEERR + 60)
Public Const WSAECONNREFUSED = (WSABASEERR + 61)
Public Const WSAELOOP = (WSABASEERR + 62)
Public Const WSAENAMETOOLONG = (WSABASEERR + 63)
Public Const WSAEHOSTDOWN = (WSABASEERR + 64)
Public Const WSAEHOSTUNREACH = (WSABASEERR + 65)
Public Const WSAENOTEMPTY = (WSABASEERR + 66)
Public Const WSAEPROCLIM = (WSABASEERR + 67)
Public Const WSAEUSERS = (WSABASEERR + 68)
Public Const WSAEDQUOT = (WSABASEERR + 69)
Public Const WSAESTALE = (WSABASEERR + 70)
Public Const WSAEREMOTE = (WSABASEERR + 71)
'/*
' * Extended Windows Sockets error constant definitions
' */
Public Const WSASYSNOTREADY = (WSABASEERR + 91)
Public Const WSAVERNOTSUPPORTED = (WSABASEERR + 92)
Public Const WSANOTINITIALISED = (WSABASEERR + 93)
Public Const WSAEDISCON = (WSABASEERR + 101)
Public Const WSAENOMORE = (WSABASEERR + 102)
Public Const WSAECANCELLED = (WSABASEERR + 103)
Public Const WSAEINVALIDPROCTABLE = (WSABASEERR + 104)
Public Const WSAEINVALIDPROVIDER = (WSABASEERR + 105)
Public Const WSAEPROVIDERFAILEDINIT = (WSABASEERR + 106)
Public Const WSASYSCALLFAILURE = (WSABASEERR + 107)
Public Const WSASERVICE_NOT_FOUND = (WSABASEERR + 108)
Public Const WSATYPE_NOT_FOUND = (WSABASEERR + 109)
Public Const WSA_E_NO_MORE = (WSABASEERR + 110)
Public Const WSA_E_CANCELLED = (WSABASEERR + 111)
Public Const WSAEREFUSED = (WSABASEERR + 112)
'
'/* Authoritative Answer: Host not found */
Public Const WSAHOST_NOT_FOUND = (WSABASEERR + 1001)
'/* Non-Authoritative: Host not found, or SERVERFAIL */
Public Const WSATRY_AGAIN = (WSABASEERR + 1002)
'/* Non recoverable errors, FORMERR, REFUSED, NOTIMP */
Public Const WSANO_RECOVERY = (WSABASEERR + 1003)
'/* Valid name, no data record of requested type */
Public Const WSANO_DATA = (WSABASEERR + 1004)
'
'
'Socket types
'
Public Enum SocketType
SOCK_STREAM = 1 ' /* stream socket */
SOCK_DGRAM = 2 ' /* datagram socket */
SOCK_RAW = 3 ' /* raw-protocol interface */
SOCK_RDM = 4 ' /* reliably-delivered message */
SOCK_SEQPACKET = 5 ' /* sequenced packet stream */
End Enum
'
Public Enum AddressFamily
'
AF_UNSPEC = 0 '/* unspecified */
'/*
' * Although AF_UNSPEC is defined for backwards compatibility, using
' * AF_UNSPEC for the "af" parameter when creating a socket is STRONGLY
' * DISCOURAGED. The interpretation of the "protocol" parameter
' * depends on the actual address family chosen. As environments grow
' * to include more and more address families that use overlapping
' * protocol values there is more and more chance of choosing an
' * undesired address family when AF_UNSPEC is used.
' */
AF_UNIX = 1 '/* local to host (pipes, portals) */
AF_INET = 2 '/* internetwork: UDP, TCP, etc. */
AF_IMPLINK = 3 '/* arpanet imp addresses */
AF_PUP = 4 '/* pup protocols: e.g. BSP */
AF_CHAOS = 5 '/* mit CHAOS protocols */
AF_NS = 6 '/* XEROX NS protocols */
AF_IPX = AF_NS '/* IPX protocols: IPX, SPX, etc. */
AF_ISO = 7 '/* ISO protocols */
AF_OSI = AF_ISO '/* OSI is ISO */
AF_ECMA = 8 '/* european computer manufacturers */
AF_DATAKIT = 9 '/* datakit protocols */
AF_CCITT = 10 '/* CCITT protocols, X.25 etc */
AF_SNA = 11 '/* IBM SNA */
AF_DECnet = 12 '/* DECnet */
AF_DLI = 13 '/* Direct data link interface */
AF_LAT = 14 '/* LAT */
AF_HYLINK = 15 '/* NSC Hyperchannel */
AF_APPLETALK = 16 '/* AppleTalk */
AF_NETBIOS = 17 '/* NetBios-style addresses */
AF_VOICEVIEW = 18 '/* VoiceView */
AF_FIREFOX = 19 '/* Protocols from Firefox */
AF_UNKNOWN1 = 20 '/* Somebody is using this! */
AF_BAN = 21 '/* Banyan */
AF_ATM = 22 '/* Native ATM Services */
AF_INET6 = 23 '/* Internetwork Version 6 */
AF_CLUSTER = 24 '/* Microsoft Wolfpack */
AF_12844 = 25 '/* IEEE 1284.4 WG AF */
AF_MAX = 26
'
End Enum
'
'/*
' * Protocols
' */
Public Enum SocketProtocol
IPPROTO_IP = 0 '/* dummy for IP */
IPPROTO_ICMP = 1 '/* control message protocol */
IPPROTO_IGMP = 2 '/* internet group management protocol */
IPPROTO_GGP = 3 '/* gateway^2 (deprecated) */
IPPROTO_TCP = 6 '/* tcp */
IPPROTO_PUP = 12 '/* pup */
IPPROTO_UDP = 17 '/* user datagram protocol */
IPPROTO_IDP = 22 '/* xns idp */
IPPROTO_ND = 77 '/* UNOFFICIAL net disk proto */
IPPROTO_RAW = 255 '/* raw IP packet */
IPPROTO_MAX = 256
End Enum
'
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
'
Public Declare Function gethostbyaddr Lib "ws2_32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long
Public Declare Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Public Declare Function getservbyname Lib "ws2_32.dll" (ByVal serv_name As String, ByVal proto As String) As Long
Public Declare Function getprotobynumber Lib "ws2_32.dll" (ByVal proto As Long) As Long
Public Declare Function getprotobyname Lib "ws2_32.dll" (ByVal proto_name As String) As Long
Public Declare Function getservbyport Lib "ws2_32.dll" (ByVal Port As Integer, ByVal proto As Long) As Long
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Public Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal inn As Long) As Long
Public Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Public Declare Function htonl Lib "ws2_32.dll" (ByVal hostlong As Long) As Long
Public Declare Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long
Public Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer
Public Declare Function api_socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Public Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
Public Declare Function api_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Public Declare Function getsockname Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function getpeername Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function api_bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function api_select Lib "ws2_32.dll" Alias "select" (ByVal nfds As Long, ByRef readfds As Any, ByRef writefds As Any, ByRef exceptfds As Any, ByRef TimeOut As Long) As Long
Public Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function send Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how As Long) As Long
Public Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Public Declare Function api_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr_in, ByRef addrlen As Long) As Long
Public Declare Function setsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function getsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function sendto Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef toaddr As sockaddr_in, ByVal tolen As Long) As Long
Public Declare Function recvfrom Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef from As sockaddr_in, ByRef fromlen As Long) As Long
Public Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Public Declare Function WSAAsyncGetHostByAddr Lib "ws2_32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByRef lngAddr As Long, ByVal lngLenght As Long, ByVal lngType As Long, buf As Any, ByVal lngBufLen As Long) As Long
Public Declare Function WSAAsyncGetHostByName Lib "ws2_32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSAData) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
'
Private Const GWL_WNDPROC = -4
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
'Added: 04-MAR-2002
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
'Added: 17-OCT-2002
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc&, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
'
Public Const GMEM_FIXED = &H0
Public Const GMEM_MOVEABLE = &H2
'
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'---------------------------------------------
'Modified: 23-AUG-2002
'---------------------------------------------
'The variable scope has been changed to Public to be
'visible from the CSocket class module
'Private m_lngWindowHandle As Long
Public p_lngWindowHandle As Long
'---------------------------------------------
Private m_colSockets As Collection
Private m_colResolvers As Collection
Private m_colMemoryBlocks As Collection
Private m_lngPreviousValue As Long
Private m_blnGetHostRecv As Boolean
Private m_blnWinsockInit As Boolean
Private m_lngMaxMsgSize As Long
Private Const WM_USER = &H400
'
'Private Const RESOLVE_MESSAGE = WM_USER + 1
'Private Const SOCKET_MESSAGE = WM_USER + 2
'
Private m_lngResolveMessage As Long 'Added: 04-MAR-2002
'---------------------------------------------
'Modified: 23-AUG-2002
'---------------------------------------------
'The variable scope has been changed to Public to be
'visible from the CSocket class module
'Private m_lngWinsockMessage As Long 'Added: 04-MAR-2002
Public p_lngWinsockMessage As Long
'---------------------------------------------
'
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private Const OFFSET_2 = 65536
Private Const MAXINT_2 = 32767
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'
'This the callback function of the window created to hook
'messages sent by the Winsock service. It handles only two
'types of messages - network events for the sockets the
'WSAAsyncSelect fucntion was called for, and the messages
'sent in response to the WSAAsyncGetHostByName and
'WSAAsyncGetHostByAddress Winsock API functions.
'
'Then the message is received, this function creates illegal
'reference to the instance of the CSocket class and calls
'either the PostSocketEvent or PostGetHostEvent method of the
'class to pass that message to the class.
'
Dim objSocket As CSocket 'the illegal reference to an
'instance of the CSocket class
Dim lngObjPointer As Long 'pointer to the existing instance
'of the CSocket class
Dim lngEventID As Long 'network event
Dim lngErrorCode As Long 'code of the error message
Dim lngMemoryHandle As Long 'descriptor of the allocated
'memory object
Dim lngMemoryPointer As Long 'pointer to the allocated memory
Dim lngHostAddress As Long '32-bit host address
Dim strHostName As String 'a host hame
Dim udtHost As HOSTENT 'structure of the data in the
'allocated memory block
Dim lngIpAddrPtr As Long 'pointer to the IP address string
'
On Error GoTo ERORR_HANDLER
'
If uMsg = p_lngWinsockMessage Then 'Modified: 04-MAR-2002
'
'All the pointers to the existing instances of the CSocket class
'are stored in the m_colSockets collection. Key of the collection's
'item contains a value of the socket handle, and a value of the
'collection item is the Long value that is a pointer the object,
'instance of the CSocket class. Since the wParam argument of the
'callback function contains a value of the socket handle the
'function has received the network event message for, we can use
'that value to get the object's pointer. With the pointer value
'we can create the illegal reference to the object to be able to
'call any Public or Friend subroutine of that object.
'
Set objSocket = SocketObjectFromPointer(CLng(m_colSockets("S" & wParam)))
'
'Retrieve the network event ID
lngEventID = LoWord(lParam)
'Retrieve the error code
lngErrorCode = HiWord(lParam)
'
'Forward the message to the instance of the CSocket class
objSocket.PostSocketEvent lngEventID, lngErrorCode
'
ElseIf uMsg = m_lngResolveMessage Then 'Modified: 04-MAR-2002
'
'A message has been received in response to the call of
'the WSAAsyncGetHostByName or WSAAsyncGetHostByAddress.
'
'Retrieve the error code
lngErrorCode = HiWord(lParam)
'
'The wParam parameter of the callback function contains
'the task handle returned by the original function call
'(see the ResolveHost function for more info). This value
'is used as a key of the m_colResolvers collection item.
'The item of that collection contains a pointer to the
'instance of the CSocket class. So, if we know a value
'of the task handle, we can find out the pointer to the
'object which called the ResolveHost function in this module.
'
'Get the object pointer by the task handle value
lngObjPointer = CLng(m_colResolvers("R" & wParam))
'
'A value of the pointer to the instance of the CSocket class
'is used also as a key for the m_colMemoryBlocks collection
'item that contains a handle of the allocated memory block
'object. That memory block is the buffer where the
'WSAAsyncGetHostByName and WSAAsyncGetHostByAddress functions
'store the result HOSTENT structure.
'
'Get the handle of the allocated memory block object by the
'pointer to the instance of the CSocket class.
lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
'
'Lock the memory block and get address of the buffer where
'the HOSTENT structure data is stored.
lngMemoryPointer = GlobalLock(lngMemoryHandle)
'
'Create an illegal reference to the instance of the
'CSocket class
Set objSocket = SocketObjectFromPointer(lngObjPointer)
'
'Now we can forward the message to that instance.
'
If lngErrorCode <> 0 Then
'
'If the host was not resolved, pass the error code value
objSocket.PostGetHostEvent 0, 0, "", lngErrorCode
'
Else
'
'Move data from the allocated memory block to the
'HOSTENT structure - udtHost
CopyMemory udtHost, ByVal lngMemoryPointer, Len(udtHost)
'
'Get a 32-bit host address
CopyMemory lngIpAddrPtr, ByVal udtHost.hAddrList, 4
CopyMemory lngHostAddress, ByVal lngIpAddrPtr, 4
'
'Get a host name
strHostName = StringFromPointer(udtHost.hName)
'
'Call the PostGetHostEvent friend method of the objSocket
'to forward the retrieved information.
objSocket.PostGetHostEvent wParam, lngHostAddress, strHostName
'
End If
'
'The task to resolve the host name is completed, thus we don't
'need the allocated memory block anymore and corresponding items
'in the m_colMemoryBlocks and m_colResolvers collections as well.
'
'Unlock the memory block
Call GlobalUnlock(lngMemoryHandle)
'Free that memory
Call GlobalFree(lngMemoryHandle)
'
'Rremove the items from the collections
m_colMemoryBlocks.Remove "S" & lngObjPointer
m_colResolvers.Remove "R" & wParam
'
'If there are no more resolving tasks in progress,
'destroy the collection objects to free resources.
If m_colResolvers.Count = 0 Then
Set m_colMemoryBlocks = Nothing
Set m_colResolvers = Nothing
End If
'
'---------------------------------------------------------------------
'Added: 17-OCT-2002
Else
'Pass other messages to the original window procedure
WindowProc = CallWindowProc(m_lngPreviousValue, hwnd, uMsg, wParam, lParam)
'---------------------------------------------------------------------
End If
'
EXIT_LABEL:
'
Exit Function
'
ERORR_HANDLER:
'
'Err.Raise Err.Number, "CSocket.WindowProc", Err.Description
'
'GoTo EXIT_LABEL
'
End Function
Public Function RegisterSocket(ByVal lngSocketHandle As Long, ByVal lngObjectPointer As Long) As Boolean
'********************************************************************************
'Author :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose :Adds the socket to the m_colSockets collection, and
' registers that socket with WSAAsyncSelect Winsock API
' function to receive network events for the socket.
' If this socket is the first one to be registered, the
' window and collection will be created in this function as well.
'Arguments :lngSocketHandle - the socket handle
' lngObjectPointer - pointer to an object, instance of the CSocket class
'Returns :If the argument is valid and no error occurred - True.
'********************************************************************************
'
On Error GoTo ERROR_HANDLER 'Added: 04-JUNE-2002
'
Dim lngEvents As Long
Dim lngRetValue As Long
'
If p_lngWindowHandle = 0 Then
'
'We have no window to catch the network events.
'Create a new one.
p_lngWindowHandle = CreateWinsockMessageWindow
'
If p_lngWindowHandle = 0 Then
'
'Cannot create a new window.
'---------------------------------------------------
'Added: 04-JUNE-2002
'---------------------------------------------------
'Set the error info to pass to the caller subroutine
Err.Number = sckOpCanceled
Err.Description = "The operation was canceled."
Err.Source = "MSocketSupport.RegisterSocket"
'---------------------------------------------------
'Just exit to return False
Exit Function
'
End If
'
End If
'
'The m_colSockets collection holds information
'about all the sockets. If the current socket is
'the first one, create the collection object.
If m_colSockets Is Nothing Then
Set m_colSockets = New Collection
'Debug.Print "The m_colSockets is created"
End If
'
'Add a new item to the m_colSockets collection.
'The item key contains the socket handle, and the item's data
'is the pointer to the instance of the CSocket class.
m_colSockets.Add lngObjectPointer, "S" & lngSocketHandle
'
'The lngEvents variable contains a bitmask of events we are
'going to catch with the window callback function.
lngEvents = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
'
'Force the Winsock service to send the network event notifications
'to the window which handle is p_lngWindowHandle.
lngRetValue = WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, p_lngWinsockMessage, lngEvents) 'Modified:04-MAR-2002
'
'------------------------------------------------------------------
'Added: 04-JUNE-2002
'------------------------------------------------------------------
If lngRetValue = SOCKET_ERROR Then
'
'If the WSAAsyncSelect call failed this function must
'return False. In this case, the caller subroutine will
'raise an error. Let's pass the error info with the Err object.
'
RegisterSocket = False
'
Err.Number = Err.LastDllError
Err.Description = GetErrorDescription(Err.LastDllError)
Err.Source = "MSocketSupport.RegisterSocket"
'
Else
'
RegisterSocket = True
'
End If
'-------------------------------------------------------------------
'Debug.Print lngSocketHandle & ": registered"
'
Exit Function 'Added: 04-JUNE-2002
'
ERROR_HANDLER: 'Added: 04-JUNE-2002
'
RegisterSocket = False 'Added: 04-JUNE-2002
'
End Function
Public Function UnregisterSocket(ByVal lngSocketHandle As Long) As Boolean
'********************************************************************************
'Author :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose :Removes the socket from the m_colSockets collection
' If it is the last socket in that collection, the window
' and colection will be destroyed as well.
'Returns :If the argument is valid and no error occurred - True.
'********************************************************************************
'
If (lngSocketHandle = INVALID_SOCKET) Or (m_colSockets Is Nothing) Then
'
'Something wrong with the caller of this function :)
'Return False
Exit Function
'
End If
'
Call WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, 0&, 0&)
'
'Remove the socket from the collection
m_colSockets.Remove "S" & lngSocketHandle
'
UnregisterSocket = True
'
'Debug.Print lngSocketHandle & ": unregistered"
'
If m_colSockets.Count = 0 Then
'
'If there are no more sockets in the collection
'destroy the collection object and the window
'
Set m_colSockets = Nothing
'
'Debug.Print "m_colSockets destroyed"
'
UnregisterSocket = DestroyWinsockMessageWindow
'
End If
'
End Function
Public Function ResolveHost(strHostAddress As String, ByVal lngObjectPointer As Long) As Long
'********************************************************************************
'Author :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose :Receives requests to resolve a host address from the CSocket class.
'Returns :If no errors occurred - ID of the request. Otherwise - 0.
'********************************************************************************
'
'Since this module is supposed to serve several instances of the
'CSocket class, this function can be called to start several
'resolving tasks that could be executed simultaneously. To
'distinguish the resolving tasks the m_colResolvers collection
'is used. The key of the collection's item contains a pointer to
'the instance of the CSocket class and the item's data is the
'Request ID, the value returned by the WSAAsyncGetHostByXXXX
'Winsock API function. So in order to get the pointer to the
'instance of the CSocket class by the task ID value the following
'line of code can be used:
'
'lngObjPointer = CLng(m_colResolvers("R" & lngTaskID))
'
'The WSAAsyncGetHostByXXXX function needs the buffer (the buf argument)
'where the data received from DNS server will be stored. We cannot use
'a local byte array for this purpose as this buffer must be available
'from another subroutine in this module - WindowProc, also we cannot
'use a module level array as several tasks can be executed simultaneously
'At least, we need a dynamic module level array of arrays - too complicated.
'I decided to use Windows API functions for allocation some memory for
'each resolving task: GlobalAlloc, GlobalLock, GlobalUnlock, and GlobalFree.
'
'To distinguish those memory blocks, the m_colMemoryBlocks collection is
'used. The key of the collection's item contains value of the object
'pointer, and the item's value is a handle of the allocated memory
'block object, value returned by the GlobalAlloc function. So in order to
'get value of the handle of the allocated memory block object by the
'pointer to the instance of CSocket class we can use the following code:
'
'lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
'
'Why do we need all this stuff?
'
'The problem is that the callback function give us only the resolving task
'ID value, but we need information about:
' - where the data returned from the DNS server is stored
' - which instance of the CSocket class we need to post the info to
'
'So, if we know the task ID value, we can find out the object pointer:
' lngObjPointer = CLng(m_colResolvers("R" & lngTaskID))
'
'If we know the object pointer value we can find out where the data is strored:
' lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer))
'
'That's it. :))
'
Dim lngAddress As Long '32-bit host address
Dim lngRequestID As Long 'value returned by WSAAsyncGetHostByXXX
Dim lngMemoryHandle As Long 'handle of the allocated memory block object
Dim lngMemoryPointer As Long 'address of the memory block
'
'Allocate some memory
lngMemoryHandle = GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
'
If lngMemoryHandle > 0 Then
'
'Lock the memory block just to get the address
'of that memory into the lngMemoryPointer variable
lngMemoryPointer = GlobalLock(lngMemoryHandle)
'
If lngMemoryPointer = 0 Then
'
'Memory allocation error
Call GlobalFree(lngMemoryHandle)
Exit Function
'
Else
'Unlock the memory block
GlobalUnlock (lngMemoryHandle)
'
End If
'
Else
'
'Memory allocation error
Exit Function
'
End If
'
'If this request is the first one, create the collections
If m_colResolvers Is Nothing Then
Set m_colMemoryBlocks = New Collection
Set m_colResolvers = New Collection
End If
'
'------------------------------------------------------------------
'Added: 09-JULY-2002
'------------------------------------------------------------------
Dim strKey As String
'
strKey = "S" & CStr(lngObjectPointer)
'
Call RemoveIfExists(strKey)
'------------------------------------------------------------------
'Remember the memory block location
m_colMemoryBlocks.Add lngMemoryHandle, strKey
'
'------------------------------------------------------------------
'Modified: 08-JULY-2002
'------------------------------------------------------------------
'Here is a major change. Since version 1.0.6 (08-JULY-2002) the
'SCocket class doesn't try to resolve the IP address into a
'domain name while connecting.
'------------------------------------------------------------------
'
'Try to get 32-bit address
'lngAddress = inet_addr(strHostAddress)
'
'If lngAddress = INADDR_NONE Then
'
'If strHostAddress is not an IP address, try to resolve by name
lngRequestID = WSAAsyncGetHostByName(p_lngWindowHandle, m_lngResolveMessage, strHostAddress, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT) 'Modified: 04-MAR-2002
'
'Else
'
'strHostAddress contains an IP address, resolve by address to get a host name
' lngRequestID = WSAAsyncGetHostByAddr(p_lngWindowHandle, m_lngResolveMessage, lngAddress, 4&, AF_INET, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT) 'Modified: 04-MAR-2002
'
'End If
'
'------------------------------------------------------------------
'
If lngRequestID <> 0 Then
'
'If the call of the WSAAsyncGetHostByXXXX is successful, the
'lngRequestID variable contains the task ID value.
'Remember it.
m_colResolvers.Add lngObjectPointer, "R" & CStr(lngRequestID)
'
'Return value
ResolveHost = lngRequestID
'
Else
'
'If the call of the WSAAsyncGetHostByXXXX is not successful,
'remove the item from the m_colMemoryBlocks collection.
m_colMemoryBlocks.Remove ("S" & CStr(lngObjectPointer))
'
'Free allocated memory block
Call GlobalFree(lngMemoryHandle)
'
'If there are no more resolving tasks in progress,
'destroy the collection objects.
If m_colResolvers.Count = 0 Then
Set m_colResolvers = Nothing
Set m_colMemoryBlocks = Nothing
End If
'
'Set the error info.
Err.Number = Err.LastDllError
Err.Description = GetErrorDescription(Err.LastDllError)
Err.Source = "MSocketSupport.ResolveHost"
'
End If
'
End Function
Private Function CreateWinsockMessageWindow() As Long
'********************************************************************************
'Author :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose :Creates a window to hook the winsock messages
'Returns :The window handle
'********************************************************************************
'
'Create a window. It will be used for hooking messages for registered
'sockets, and we'll not see this window as the ShowWindow is never called.
p_lngWindowHandle = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
'
If p_lngWindowHandle = 0 Then
'
'I really don't know - is this possible? Probably - yes,
'due the lack of the system resources, for example.
'
'In this case the function returns 0.
'
Else
'
'Register a callback function for the window created a moment ago in this function
'm_lngPreviousValue - stores the returned value that is the pointer to the previous
'callback window function. We'll need this value to destroy the window.
m_lngPreviousValue = SetWindowLong(p_lngWindowHandle, GWL_WNDPROC, AddressOf WindowProc)
'
'Just to let the caller know that the function was executed successfully
CreateWinsockMessageWindow = p_lngWindowHandle
'
'Debug.Print "The window is created: " & p_lngWindowHandle
'
End If
'
End Function
Private Function DestroyWinsockMessageWindow() As Boolean
'********************************************************************************
'Author :Oleg Gdalevich
'Date/Time :17-12-2001
'Purpose :Destroyes the window
'Returns :If the window was destroyed successfully - True.
'********************************************************************************
'
On Error GoTo ERR_HANDLER
'
'Return the previous window procedure
SetWindowLong p_lngWindowHandle, GWL_WNDPROC, m_lngPreviousValue
'Destroy the window
DestroyWindow p_lngWindowHandle
'
'Debug.Print "The window " & p_lngWindowHandle & " is destroyed"
'
'Reset the window handle variable
p_lngWindowHandle = 0
'If no errors occurred, the function returns True
DestroyWinsockMessageWindow = True
'
ERR_HANDLER:
End Function
Private Function SocketObjectFromPointer(ByVal lngPointer As Long) As CSocket
'
Dim objSocket As CSocket
'
CopyMemory objSocket, lngPointer, 4&
Set SocketObjectFromPointer = objSocket
CopyMemory objSocket, 0&, 4&
'
End Function
Private Function LoWord(lngValue As Long) As Long
LoWord = (lngValue And &HFFFF&)
End Function
Private Function HiWord(lngValue As Long) As Long
'
If (lngValue And &H80000000) = &H80000000 Then
HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
Else
HiWord = (lngValue And &HFFFF0000) \ &H10000
End If
'
End Function
Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
'
Dim strDesc As String
'
Select Case lngErrorCode
'
Case WSAEACCES
strDesc = "Permission denied."
Case WSAEADDRINUSE
strDesc = "Address already in use."
Case WSAEADDRNOTAVAIL
strDesc = "Cannot assign requested address."
Case WSAEAFNOSUPPORT
strDesc = "Address family not supported by protocol family."
Case WSAEALREADY
strDesc = "Operation already in progress."
Case WSAECONNABORTED
strDesc = "Software caused connection abort."
Case WSAECONNREFUSED
strDesc = "Connection refused."
Case WSAECONNRESET
strDesc = "Connection reset by peer."
Case WSAEDESTADDRREQ
strDesc = "Destination address required."
Case WSAEFAULT
strDesc = "Bad address."
Case WSAEHOSTDOWN
strDesc = "Host is down."
Case WSAEHOSTUNREACH
strDesc = "No route to host."
Case WSAEINPROGRESS
strDesc = "Operation now in progress."
Case WSAEINTR
strDesc = "Interrupted function call."
Case WSAEINVAL
strDesc = "Invalid argument."
Case WSAEISCONN
strDesc = "Socket is already connected."
Case WSAEMFILE
strDesc = "Too many open files."
Case WSAEMSGSIZE
strDesc = "Message too long."
Case WSAENETDOWN
strDesc = "Network is down."
Case WSAENETRESET
strDesc = "Network dropped connection on reset."
Case WSAENETUNREACH
strDesc = "Network is unreachable."
Case WSAENOBUFS
strDesc = "No buffer space available."
Case WSAENOPROTOOPT
strDesc = "Bad protocol option."
Case WSAENOTCONN
strDesc = "Socket is not connected."
Case WSAENOTSOCK
strDesc = "Socket operation on nonsocket."
Case WSAEOPNOTSUPP
strDesc = "Operation not supported."
Case WSAEPFNOSUPPORT
strDesc = "Protocol family not supported."
Case WSAEPROCLIM
strDesc = "Too many processes."
Case WSAEPROTONOSUPPORT
strDesc = "Protocol not supported."
Case WSAEPROTOTYPE
strDesc = "Protocol wrong type for socket."
Case WSAESHUTDOWN
strDesc = "Cannot send after socket shutdown."
Case WSAESOCKTNOSUPPORT
strDesc = "Socket type not supported."
Case WSAETIMEDOUT
strDesc = "Connection timed out."
Case WSATYPE_NOT_FOUND
strDesc = "Class type not found."
Case WSAEWOULDBLOCK
strDesc = "Resource temporarily unavailable."
Case WSAHOST_NOT_FOUND
strDesc = "Host not found."
Case WSANOTINITIALISED
strDesc = "Successful WSAStartup not yet performed."
Case WSANO_DATA
strDesc = "Valid name, no data record of requested type."
Case WSANO_RECOVERY
strDesc = "This is a nonrecoverable error."
Case WSASYSCALLFAILURE
strDesc = "System call failure."
Case WSASYSNOTREADY
strDesc = "Network subsystem is unavailable."
Case WSATRY_AGAIN
strDesc = "Nonauthoritative host not found."
Case WSAVERNOTSUPPORTED
strDesc = "Winsock.dll version out of range."
Case WSAEDISCON
strDesc = "Graceful shutdown in progress."
Case Else
strDesc = "Unknown error."
End Select
'
GetErrorDescription = strDesc