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:
1001:
1002:
1003:
1004:
1005:
1006:
1007:
1008:
1009:
1010:
1011:
1012:
1013:
1014:
1015:
1016:
1017:
1018:
1019:
1020:
1021:
1022:
1023:
1024:
1025:
1026:
1027:
1028:
1029:
1030:
1031:
1032:
1033:
1034:
1035:
1036:
1037:
1038:
1039:
1040:
1041:
1042:
1043:
1044:
1045:
1046:
1047:
1048:
1049:
1050:
1051:
1052:
1053:
1054:
1055:
1056:
1057:
1058:
1059:
1060:
1061:
1062:
1063:
1064:
1065:
1066:
1067:
1068:
1069:
1070:
1071:
1072:
1073:
1074:
1075:
1076:
1077:
1078:
1079:
1080:
1081:
1082:
1083:
1084:
1085:
1086:
1087:
1088:
1089:
1090:
1091:
1092:
1093:
1094:
1095:
1096:
1097:
1098:
1099:
1100:
1101:
1102:
1103:
1104:
1105:
1106:
1107:
1108:
1109:
1110:
1111:
1112:
1113:
1114:
1115:
1116:
1117:
1118:
1119:
1120:
1121:
1122:
1123:
1124:
1125:
1126:
1127:
1128:
1129:
1130:
1131:
1132:
1133:
1134:
1135:
1136:
1137:
1138:
1139:
1140:
1141:
1142:
1143:
1144:
1145:
1146:
1147:
1148:
1149:
1150:
1151:
1152:
1153:
1154:
1155:
1156:
1157:
1158:
1159:
1160:
1161:
1162:
1163:
1164:
1165:
1166:
1167:
1168:
1169:
1170:
1171:
1172:
1173:
1174:
1175:
1176:
1177:
1178:
1179:
1180:
1181:
1182:
1183:
1184:
1185:
1186:
1187:
1188:
1189:
1190:
1191:
1192:
1193:
1194:
1195:
1196:
1197:
1198:
1199:
1200:
1201:
1202:
1203:
1204:
1205:
1206:
1207:
1208:
1209:
1210:
1211:
1212:
1213:
1214:
1215:
1216:
1217:
1218:
1219:
1220:
1221:
1222:
1223:
1224:
1225:
1226:
1227:
1228:
1229:
1230:
1231:
1232:
1233:
1234:
1235:
1236:
1237:
1238:
1239:
1240:
1241:
1242:
1243:
1244:
1245:
1246:
1247:
1248:
1249:
1250:
1251:
1252:
1253:
1254:
1255:
1256:
1257:
1258:
1259:
1260:
1261:
1262:
1263:
1264:
1265:
1266:
1267:
1268:
1269:
1270:
1271:
1272:
1273:
1274:
1275:
1276:
1277:
1278:
1279:
1280:
1281:
1282:
1283:
1284:
1285:
1286:
1287:
1288:
1289:
1290:
1291:
1292:
1293:
1294:
1295:
1296:
1297:
1298:
1299:
1300:
1301:
1302:
1303:
1304:
1305:
1306:
1307:
1308:
1309:
1310:
1311:
1312:
1313:
1314:
1315:
1316:
1317:
1318:
1319:
1320:
1321:
1322:
1323:
1324:
1325:
1326:
1327:
1328:
1329:
1330:
1331:
1332:
1333:
1334:
1335:
1336:
1337:
1338:
1339:
1340:
1341:
1342:
1343:
1344:
1345:
1346:
1347:
1348:
1349:
1350:
1351:
1352:
1353:
1354:
1355:
1356:
1357:
1358:
1359:
1360:
1361:
1362:
1363:
1364:
1365:
1366:
1367:
1368:
1369:
1370:
1371:
1372:
1373:
1374:
1375:
1376:
1377:
1378:
1379:
1380:
1381:
1382:
1383:
1384:
1385:
1386:
1387:
1388:
1389:
1390:
1391:
1392:
1393:
1394:
1395:
1396:
1397:
1398:
1399:
1400:
1401:
1402:
1403:
1404:
1405:
1406:
1407:
1408:
1409:
1410:
1411:
1412:
1413:

Unit MutexIPC;

Interface

{.$DEFINE USECRCCHECKS}

Uses
  Windows,
  Classes,
  SysUtils,
  Messages,
  Contnrs,
  Forms;

Const
  IPCBlockSize = 1024;

Type
  TMIPCDataBuffer = Array[0..IPCBlockSize - 1] Of Byte;

Type
  TMutexIPCVersion = Packed Record
    Major: Byte;
    Minor: Byte;
    Release: Word;
        Build: DWORD;
    End;

    TMutexIPCHeader = Packed Record
        Signature: DWORD;
        SendID: DWORD;                                                          //Sender
        RecvID: DWORD;                                                          //Receipend
        CRC32: DWORD;                                                           //Block CRC
    End;

    TMutexIPCBlock = Packed Record
        Offset: DWORD;
        Size: DWORD;
    End;

    TMutexIPCState = Packed Record
        Header: TMutexIPCHeader;                                                //Header to identify the MIPC
        MIPCVersion: TMutexIPCVersion;                                          //Version of the MIPC
        LockOwnerID: DWORD;                                                     //ID of the client that locked the MMF
        LockReason: DWORD;                                                      //Reason for the current Lock Operation
        MMFSize: DWORD;                                                         //Size of the allocated MMF
    End;

    TMutexIPCData = Packed Record
        Header: TMutexIPCHeader;
        Command: DWORD;                                                         //IPC Command
        Sequence: DWORD;                                                        //Sequence Number
        Block: TMutexIPCBlock;                                                  //Block Information
        Data: TMIPCDataBuffer;
    End;

    TMutexIPCSequenceInfo = Packed Record
        SequenceID: DWORD;
        SendID: DWORD;                                                          //Sender
        RecvID: DWORD;                                                          //Receipend
        CRC32: DWORD;                                                           //CRC of finished data sequence
        Size: DWORD;                                                            //Size of this Sequence
        Buffer: Array Of Byte;                                                  //Recieved Data
        Missing: Array Of TMutexIPCBlock;                                       //Information of missing Blocks
    End;

Type
    TMutexIPCDataArray = Array[0..0] Of TMutexIPCData;                          //Array of TMutexIPCData Structures
    PMutexIPCDataArray = ^TMutexIPCDataArray;                                   //Pointer to such an array

Type
    TMutexIPCMutexCreationEvent = TNotifyEvent;
    TMutexIPCMutexDestructionEvent = TNotifyEvent;
    TMutexIPCLogonEvent = Procedure(Sender: TObject; LocalID, RemoteID: DWORD) Of Object;
    TMutexIPCSequenceControlEvent = Procedure(Sender: TObject; SendID, RecvID: DWORD; SequenceID: DWORD) Of Object;
    TMutexIPCSequenceDataEvent = Procedure(Sender: TObject; SendID, RecvID: DWORD; SequenceID: DWORD; Block: TMutexIPCBlock) Of Object;
    TMutexIPCCommandEvent = Procedure(Sender: TObject; Var Command: TMutexIPCData) Of Object;
    TMutexIPCDefragmentionEvent = TNotifyEvent;
    TMutexIPCUserException = Procedure(Sender: TObject; Const E: Exception) Of Object;

Const
    IPCDefaultMutexSize = 2048 * SizeOf(TMutexIPCData);

Type
    EMIPCException = Class(Exception);
    EMIPCCRCError = Class(EMIPCException);
    EMIPCInitialization = Class(EMIPCException);
    EMIPCInvalidName = Class(EMIPCException);
    EMIPCTimeout = Class(EMIPCException);
    EMIPCWindowMessage = Class(EMIPCException);

Type
    TMutexIPCStreamInfo = Class;

    TMutexIPC = Class(TComponent)
    Private
        FMutexName: String;
        FMutexSize: Integer;
        FMutexTimeout: Integer;

        FMutexHandle: THandle;

        FClientID: DWORD;
        FClientList: TStringList;

        FMutexLockCount: THandle;
        FMutexLockHandle: THandle;

        FMMFHandle: THandle;
        PMMFData: Pointer;
        FLastWriteIdx: Integer;

        FWndHandle: THandle;

        Message_LogonEvent: Word;
        Message_StreamEvent: Word;
        Message_CreateID: Word;

        FStreamInfo: TObjectList;
        FCurrentSending: TMutexIPCStreamInfo;

        FOnMutexClientLogin: TMutexIPCLogonEvent;
        FOnMutexClientLogoff: TMutexIPCLogonEvent;
        FOnMutexDestroy: TMutexIPCMutexCreationEvent;
        FOnMutexCreate: TMutexIPCMutexCreationEvent;
        FOnMutexSequenceComplete: TMutexIPCSequenceControlEvent;
        FOnMutexSequenceStart: TMutexIPCSequenceControlEvent;
        FOnMutexDataSent: TMutexIPCSequenceDataEvent;
        FOnMutexDataRecv: TMutexIPCSequenceDataEvent;
        FOnMutexCommand: TMutexIPCCommandEvent;
        FOnMutexDefragmention: TMutexIPCDefragmentionEvent;
        FOnMutexUserException: TMutexIPCUserException;

        Procedure AddClient(AClientID: DWORD);
        Procedure DelClient(AClientID: DWORD);

        Procedure OpenIPC;
        Procedure ReadIPC;
        Procedure DefragIPC;
        Procedure WriteIPC(AData: TMutexIPCData);
        Procedure CloseIPC;

        Function Lock: Boolean;
        Procedure Unlock;
        Function SetMMFState(Reason: DWORD): Boolean;

        Procedure SetMutexName(Const Value: String);
        Procedure SetMutexSize(Const Value: Integer);

        Procedure WndProc(Var Message: TMessage);
        Function ClientToHWnd(ClientID: DWORD): THandle;
        Function CreateStreamID(RecvID: DWORD): DWORD;

        Procedure AnnounceMyself;
        Function GetMMFState_Reason: DWORD;
        Function GetMMFState_User: DWORD;

        Function GetClientCount: Integer;
        Function GetClients(Index: Integer): DWORD;

        Function GetSequenceInfo(SequenceID: DWORD): TMutexIPCStreamInfo;
        Procedure DoWriteStream(ARecvID: DWORD; AName: String; AStream: TStream);
    Public
        Constructor Create(AOwner: TComponent); Override;
        Destructor Destroy; Override;
        Procedure BeforeDestruction; Override;
        Procedure Loaded; Override;

        Function GetSequenceData(SequenceID: DWORD): TMemoryStream;
        Function GetSequenceName(SequenceID: DWORD): String;

        Procedure SendInteger(ARecvID: DWORD; AName: String; AValue: Integer);
        Procedure SendInt64(ARecvID: DWORD; AName: String; AValue: Int64);
        Procedure SendChar(ARecvID: DWORD; AName: String; AValue: Char);        //For those who really wanna waste performance.
        Procedure SendString(ARecvID: DWORD; AName: String; AValue: String);
        Procedure SendBuffer(ARecvID: DWORD; AName: String; Const ABuffer; ASize: Integer);
        Procedure SendStream(ARecvID: DWORD; AName: String; AStream: TStream);

        Property ClientID: DWORD Read FClientID;

        Property ClientCount: Integer Read GetClientCount;
        Property Clients[Index: Integer]: DWORD Read GetClients;

        Property MMFLockedBy: DWORD Read GetMMFState_User;
        Property MMFLockReason: DWORD Read GetMMFState_Reason;
    Published
        Property MutexName: String Read FMutexName Write SetMutexName;
        Property MutexSize: Integer Read FMutexSize Write SetMutexSize Default IPCDefaultMutexSize;
        Property MutexTimeout: Integer Read FMutexTimeout Write FMutexTimeout Default 5000;

        Property OnMutexCreate: TMutexIPCMutexCreationEvent Read FOnMutexCreate Write FOnMutexCreate;
        Property OnMutexDestroy: TMutexIPCMutexCreationEvent Read FOnMutexDestroy Write FOnMutexDestroy;
        Property OnMutexClientLogin: TMutexIPCLogonEvent Read FOnMutexClientLogin Write FOnMutexClientLogin;
        Property OnMutexClientLogoff: TMutexIPCLogonEvent Read FOnMutexClientLogoff Write FOnMutexClientLogoff;
        Property OnMutexCommand: TMutexIPCCommandEvent Read FOnMutexCommand Write FOnMutexCommand;
        Property OnMutexSequenceStart: TMutexIPCSequenceControlEvent Read FOnMutexSequenceStart Write FOnMutexSequenceStart;
        Property OnMutexSequenceComplete: TMutexIPCSequenceControlEvent Read FOnMutexSequenceComplete Write FOnMutexSequenceComplete;
        Property OnMutexDataSent: TMutexIPCSequenceDataEvent Read FOnMutexDataSent Write FOnMutexDataSent;
        Property OnMutexDataRecv: TMutexIPCSequenceDataEvent Read FOnMutexDataRecv Write FOnMutexDataRecv;
        Property OnMutexUserException: TMutexIPCUserException Read FOnMutexUserException Write FOnMutexUserException;
    End;

    TMutexIPCStreamInfo = Class(TObject)
    Private
        FMutexIPC: TMutexIPC;
        FStreamData: TMutexIPCSequenceInfo;
        FStreamName: String;
        Function AddData(AD: TMutexIPCBlock): Boolean;
        Procedure Init(ID: DWORD; Size: DWORD; CRC: DWORD; RecvID, SendID: DWORD);
        Procedure Verify(Data: TMutexIPCData);
    Public
        Constructor Create; Reintroduce;
        Destructor Destroy; Override;
    End;

Const
    MutexIPCVersion: TMutexIPCVersion =
    (Major: 1; Minor: 0; Release: 0; Build: 0);

Const
    IPCStateSignature: DWORD = $4350494D;                                       //'MIPC'
    IPCDataSignature: DWORD = $44435049;                                        //'IPCD'

Const
    MIPC_USER_BROADCAST: DWORD = DWORD(-1);
    MIPC_USER_UNDEFINED: DWORD = DWORD(0);

Const
    MIPC_LOCK_REASON_UNDEFINED: DWORD = 0;                                      //Unknown reason
    MIPC_LOCK_REASON_INIT: DWORD = 1;                                           //MIPC is to be initialized
    MIPC_LOCK_REASON_READ: DWORD = 2;                                           //Data is to be read
    MIPC_LOCK_REASON_WRITE: DWORD = 3;                                          //Data is to be written
    MIPC_LOCK_REASON_HANDLE: DWORD = 4;                                         //Data has to be handled
    MIPC_LOCK_REASON_DEFRAG: DWORD = 1024;                                      //The MIPC File Mapping is being defragmented

Const
    MIPC_CLIENT_LOGIN = 0;                                                      //Login a new MIPC Client
    MIPC_CLIENT_LOGOFF = 1;                                                     //Logoff an existing MIPC Client
    MIPC_CLIENT_GETHANDLE = 2;                                                  //Get the Window Handle from the Client ID

Const
    MIPC_SEQUENCE_START = 0;                                                    //New Data Transmission started
    MIPC_SEQUENCE_COMPLETED = 1;                                                //Data Transmission completed
    MIPC_SEQUENCE_BUFFERFULL = 2;                                               //Buffer is full, free up memory

Const
    MIPC_COMMAND_INVALID = 0;                                                   //Invalid Command
    MIPC_COMMAND_SEQUENCE_DATA = 1;                                             //New data for a transmission
    MIPC_COMMAND_SEQUENCE_START = 2;                                            //Start a new transmission sequence
    MIPC_COMMAND_SEQUENCE_COMPLETE = 3;                                         //A transmission is finished

Procedure Register;

Implementation

{$IFDEF USECRCCHECKS}
Uses
    Hash,
    DECUtil;

Function GetBlockCRC(Data: TMutexIPCData): DWORD;
Begin
    Data.Header.CRC32 := 0;
    Result := StrToInt64Def('$' + THash_CRC32.CalcBuffer(Data, SizeOf(Data), Nil, fmtHex), 0);
End;

Function GetStreamCRC(AStream: TStream; Offset, Size: Integer): DWORD;
Begin
    If Size = 0 Then
    Begin
        Size := -1;
        Offset := 0;
    End;
    AStream.Position := Offset;
    Result := StrToInt64Def('$' + THash_CRC32.CalcStream(AStream, Size, Nil, fmtHex), 0);
End;

{$ELSE}

Function GetBlockCRC(Data: TMutexIPCData): DWORD;
Begin
    Result := 0;
End;

Function GetStreamCRC(AStream: TStream; Offset, Size: Integer): DWORD;
Begin
    Result := 0;
End;

{$ENDIF}

Type
    TClientToHWndData = Packed Record
        Obj: TMutexIPC;
        Result: DWORD;
    End;

Procedure LoginBroadcastHandler(Wnd: HWND; uMsg, dwData: DWORD; MsgResult: LRESULT); Stdcall;
Begin
    If TMutexIPC(dwData) <> Nil Then
        With TMutexIPC(dwData) Do
            If uMsg = Message_LogonEvent Then
                AddClient(MsgResult);
End;

Procedure ClientToWindowHandler(Wnd: HWND; uMsg, dwData: DWORD; MsgResult: LRESULT); Stdcall;
Var
    Tmp: ^TClientToHWndData;
Begin
    Tmp := Pointer(dwData);
    If Assigned(Tmp) Then
        If Assigned(Tmp^.Obj) Then
            If Tmp^.Obj Is TMutexIPC Then
                If uMsg = Tmp^.Obj.Message_LogonEvent Then
                    If Tmp^.Result = 0 Then
                        Tmp^.Result := MsgResult;
End;

Procedure Register;
Begin
    RegisterComponents('Biber', [TMutexIPC]);
End;

{ TMutexIPC }

Procedure TMutexIPC.AddClient(AClientID: DWORD);
Var
    Tmp: Integer;
Begin
    If (AClientID = MIPC_USER_UNDEFINED) Or (AClientID = MIPC_USER_BROADCAST) Then
        Exit;

    Tmp := FClientList.IndexOf(IntToHex(AClientID, 8));
    If Tmp = -1 Then
    Begin
        FClientList.Add(IntToHex(AClientID, 8));
        Try
            If Assigned(FOnMutexClientLogin) Then
                FOnMutexClientLogin(Self, FClientID, AClientID);
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;
        AnnounceMyself;
    End;
End;

Procedure TMutexIPC.AnnounceMyself;
Begin
    AddClient(FClientID);
    SendMessageCallback(
        HWND_BROADCAST,
        Message_LogonEvent,
        MIPC_CLIENT_LOGIN,
        FClientID,
        @LoginBroadcastHandler,
        DWORD(Self));
End;

Procedure TMutexIPC.BeforeDestruction;
Begin
    CloseIPC;
    Inherited;
End;

Function TMutexIPC.ClientToHWnd(ClientID: DWORD): THandle;
Var
    Data: TClientToHWndData;
Begin
    Data.Obj := Self;
    Data.Result := 0;

    SendMessageCallback(
        HWND_BROADCAST,
        Message_LogonEvent,
        MIPC_CLIENT_GETHANDLE,
        FClientID,
        @ClientToWindowHandler,
        DWORD(@Data));

    Result := Data.Result;
End;

Procedure TMutexIPC.CloseIPC;
Begin
    If FClientID <> MIPC_USER_UNDEFINED Then
    Begin
        PostMessage(HWND_BROADCAST, Message_LogonEvent, MIPC_CLIENT_LOGOFF, FClientID);
        FClientID := MIPC_USER_UNDEFINED;
    End;

    //Clear all available Clients
    FClientList.Clear;

    //Clear all open Streams, cancel transactions
    FStreamInfo.Clear;

    If PMMFData <> Nil Then
    Begin
        UnMapViewOfFile(PMMFData);
        PMMFData := Nil;
    End;
    FLastWriteIdx := 1;

    If FMMFHandle <> INVALID_HANDLE_VALUE Then
    Begin
        CloseHandle(FMMFHandle);
        FMMFHandle := INVALID_HANDLE_VALUE;
    End;

    While FMutexLockHandle <> INVALID_HANDLE_VALUE Do
        Unlock;

    If Assigned(FOnMutexDestroy) Then
        FOnMutexDestroy(Self);
End;

Constructor TMutexIPC.Create(AOwner: TComponent);
Begin
    Inherited;
    FMutexName := '';                                                           //Format('MutexIPC_%.4x.%.4x', [Random(65536), Random(65536)]);
    FMutexHandle := INVALID_HANDLE_VALUE;

    FMutexLockCount := 0;
    FMutexLockHandle := INVALID_HANDLE_VALUE;

    FMutexSize := IPCDefaultMutexSize;
    FMutexTimeout := 5000;

    FMMFHandle := INVALID_HANDLE_VALUE;
    PMMFData := Nil;
    FLastWriteIdx := 1;

    FClientID := MIPC_USER_UNDEFINED;

    FClientList := TStringList.Create;
    FClientList.Sorted := True;
    FClientList.Duplicates := dupIgnore;

    FStreamInfo := TObjectList.Create(True);

    FWndHandle := AllocateHWnd(WndProc);
End;

Function TMutexIPC.CreateStreamID(RecvID: DWORD): DWORD;
Var
    RecvWnd: THandle;

    SID: DWORD;
    SIDValid: Boolean;

    X: Integer;
Begin
    RecvWnd := ClientToHWnd(RecvID);
    If RecvWnd = 0 Then
        Raise EMIPCWindowMessage.Create('Error obtaining the Window Handle for the specified Client ID.');

    SID := 0;
    SIDValid := False;
    While Not SIDValid Do
    Begin
        Repeat
            SID := Random(65536) * 65536 + Random(65536);
        Until (SID <> 0) And (SID <> DWORD(-1));

        SIDValid := True;

        For X := 0 To FStreamInfo.Count - 1 Do
        Begin
            If TMutexIPCStreamInfo(FStreamInfo[X]).FStreamData.SequenceID = SID Then
            Begin
                SIDValid := False;
                Break;
            End;
        End;

        If Not SIDValid Then
            Continue;

        If SendMessage(RecvWnd, Message_CreateID, 0, Integer(SID)) <> 0 Then
            SIDValid := False;
    End;

    Result := SID;
End;

Procedure TMutexIPC.DefragIPC;
Var
    BlockCount: Integer;
    X: Integer;
    DefragIdx: Integer;
    MIPCData: PMutexIPCDataArray;
Begin
    Try
        If Assigned(FOnMutexDefragmention) Then
            FOnMutexDefragmention(Self);
    Except
        On E: Exception Do
            If Assigned(FOnMutexUserException) Then
                FOnMutexUserException(Self, E);
    End;

    ReadIPC;                                                                    //Read the own information first

    MIPCData := PMMFData;
    DefragIdx := 1;
    BlockCount := FMutexSize Div SizeOf(TMutexIPCData) - 1;

    If Not Lock Then
        Raise EMIPCTimeout.Create('An timeout occured while the MutexIPC was waiting for an object.');
    Try
        SetMMFState(MIPC_LOCK_REASON_DEFRAG);
        Try
            For X := 1 To BlockCount Do
            Begin
                If MIPCData^[X].Header.Signature = IPCDataSignature Then
                Begin
                    //The block contains unhandled data, copy it!
                    If X <> DefragIdx Then
                    Begin
                        MIPCData^[DefragIdx] := MIPCData^[X];
                        FillChar(MIPCData^[X], SizeOf(TMutexIPCData), 0);
                    End;

                    Inc(DefragIdx);
                End
                Else
                    FillChar(MIPCData^[X], SizeOf(TMutexIPCData), 0);
            End;
        Finally
            SetMMFState(MIPC_LOCK_REASON_UNDEFINED);
        End;
    Finally
        Unlock;
    End;

    If DefragIdx = BlockCount Then
        PostMessage(HWND_BROADCAST, Message_StreamEvent, MIPC_SEQUENCE_BUFFERFULL, 0);
End;

Procedure TMutexIPC.DelClient(AClientID: DWORD);
Var
    Tmp: Integer;
Begin
    Tmp := FClientList.IndexOf(IntToHex(AClientID, 8));
    If Tmp <> -1 Then
    Begin
        Try
            If Assigned(FOnMutexClientLogoff) Then
                FOnMutexClientLogoff(Self, FClientID, AClientID);
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;
        FClientList.Delete(Tmp);
    End;
End;

Destructor TMutexIPC.Destroy;
Begin
    DeallocateHWnd(FWndHandle);

    If Assigned(FStreamInfo) Then
        FStreamInfo.Free;

    If Assigned(FClientList) Then
        FClientList.Free;

    Inherited;
End;

Procedure TMutexIPC.DoWriteStream(ARecvID: DWORD; AName: String; AStream: TStream);
Var
    SID: DWORD;
    Data: TMutexIPCData;
Begin
    If Assigned(FCurrentSending) Then
        Raise EMIPCInitialization.Create('Stream Transmission already in progress!');

    SID := CreateStreamID(ARecvID);

    FCurrentSending := TMutexIPCStreamInfo.Create;
    Try
        Data.Header.RecvID := ARecvID;
        Data.Sequence := SID;
        Data.Command := MIPC_COMMAND_SEQUENCE_START;
        Data.Block.Offset := 0;
        Data.Block.Size := AStream.Size;

        FillChar(Data.Data[0], IPCBlockSize, 0);

        PDWORD(@Data.Data[24])^ := GetStreamCRC(AStream, 0, 0);
        AStream.Position := 0;

        PDWORD(@Data.Data[28])^ := Length(AName);
        If Length(AName) <> 0 Then
            Move(AName[1], Data.Data[32], Length(AName));

        FCurrentSending.Init(
            Data.Sequence,
            Data.Block.Size,
            PDWORD(@Data.Data[24])^,
            Data.Header.RecvID,
            Data.Header.SendID);
        FCurrentSending.FMutexIPC := Self;
        FCurrentSending.FStreamName := AName;

        WriteIPC(Data);
        Try
            If Assigned(FOnMutexSequenceStart) Then
                FOnMutexSequenceStart(Self, Data.Header.SendID, Data.Header.RecvID, Data.Sequence);
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;

        { TODO 5 -oBenBE -cWriteIPC : Senden der eigentlichen Daten über daas MutexIPC }

        While (AStream.Position < AStream.Size) And (Data.Block.Size > 0) Do
        Begin
            Try
                FillChar(Data.Data[0], IPCBlockSize, 0);
                Data.Block.Offset := AStream.Position;
                Data.Block.Size := AStream.Read(Data.Data[0], IPCBlockSize);
                Data.Command := MIPC_COMMAND_SEQUENCE_DATA;

                WriteIPC(Data);

                If Assigned(FOnMutexDataSent) Then
                    FOnMutexDataSent(Self, Data.Header.SendID, Data.Header.RecvID, Data.Sequence, Data.Block);
            Except
                On E: Exception Do
                    If Assigned(FOnMutexUserException) Then
                        FOnMutexUserException(Self, E);
            End;
        End;

        Data.Block.Offset := 0;
        Data.Block.Size := AStream.Size;
        Data.Command := MIPC_COMMAND_SEQUENCE_COMPLETE;
        FillChar(Data.Data[0], IPCBlockSize, 0);
        PDWORD(@Data.Data[0])^ := FCurrentSending.FStreamData.CRC32;
        WriteIPC(Data);

        PostMessage(HWND_BROADCAST, Message_StreamEvent, MIPC_SEQUENCE_COMPLETED, 0);

        Try
            If Assigned(FOnMutexSequenceComplete) Then
                FOnMutexSequenceComplete(Self, Data.Header.SendID, Data.Header.RecvID, Data.Sequence);
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;
    Finally
        FCurrentSending.Free;
        FCurrentSending := Nil;
    End;
End;

Function TMutexIPC.GetClientCount: Integer;
Begin
    Result := FClientList.Count;
End;

Function TMutexIPC.GetClients(Index: Integer): DWORD;
Begin
    Result := StrToInt('$' + FClientList[Index]);
End;

Function TMutexIPC.GetMMFState_Reason: DWORD;
Var
    FMutexStateHandle: THandle;
Begin
    Result := MIPC_LOCK_REASON_UNDEFINED;

    FMutexStateHandle := CreateMutex(Nil, False, PChar('MIPC_' + MutexName + '_STATE'));
    Try
        If FMutexStateHandle = 0 Then
            Exit;

        If WaitForSingleObject(FMutexStateHandle, FMutexTimeout) = WAIT_FAILED Then
            Exit;
        Try
            Result := TMutexIPCState(PMMFData^).LockReason;
        Finally
            ReleaseMutex(FMutexStateHandle);
        End;
    Finally
        CloseHandle(FMutexStateHandle);
    End;
End;

Function TMutexIPC.GetMMFState_User: DWORD;
Var
    FMutexStateHandle: THandle;
Begin
    Result := MIPC_USER_UNDEFINED;

    FMutexStateHandle := CreateMutex(Nil, False, PChar('MIPC_' + MutexName + '_STATE'));
    Try
        If FMutexStateHandle = 0 Then
            Exit;

        If WaitForSingleObject(FMutexStateHandle, FMutexTimeout) = WAIT_FAILED Then
            Exit;
        Try
            Result := TMutexIPCState(PMMFData^).LockOwnerID;
        Finally
            ReleaseMutex(FMutexStateHandle);
        End;
    Finally
        CloseHandle(FMutexStateHandle);
    End;
End;

Function TMutexIPC.GetSequenceData(SequenceID: DWORD): TMemoryStream;
Var
    SI: TMutexIPCStreamInfo;
Begin
    SI := GetSequenceInfo(SequenceID);

    Result := TMemoryStream.Create;
    Try
        Result.WriteBuffer(SI.FStreamData.Buffer[0], SI.FStreamData.Size);
        Result.Position := 0;
    Except
        Result.Clear;
    End;
End;

Function TMutexIPC.GetSequenceInfo(SequenceID: DWORD): TMutexIPCStreamInfo;
Var
    X: Integer;
Begin
    Result := Nil;

    If Assigned(FCurrentSending) Then
    Begin
        If FCurrentSending.FStreamData.SequenceID = SequenceID Then
            Result := FCurrentSending;
    End;

    For X := 0 To FStreamInfo.Count - 1 Do
        If TMutexIPCStreamInfo(FStreamInfo[X]).FStreamData.SequenceID = SequenceID Then
        Begin
            Result := TMutexIPCStreamInfo(FStreamInfo[X]);
            Break;
        End;

    If Not Assigned(Result) Then
        Raise EMIPCInvalidName.Create('The specified Sequence ID was not found.');
End;

Function TMutexIPC.GetSequenceName(SequenceID: DWORD): String;
Begin
    Result := GetSequenceInfo(SequenceID).FStreamName;
End;

Procedure TMutexIPC.Loaded;
Begin
    Inherited;

    If MutexName <> '' Then
        OpenIPC;
End;

Function TMutexIPC.Lock: Boolean;
Var
    WFSOResult: DWORD;
Begin
    Result := True;

    Inc(FMutexLockCount);
    If FMutexLockCount <> 1 Then
        Exit;

    FMutexLockHandle := CreateMutex(Nil, False, PChar('MIPC_' + MutexName + '_LOCK'));
    If FMutexLockHandle = 0 Then
        Result := False;

    WFSOResult := WaitForSingleObject(FMutexLockHandle, FMutexTimeout);
    If (WFSOResult = WAIT_TIMEOUT) Or (WFSOResult = WAIT_FAILED) Then
        Result := False;
End;

Procedure TMutexIPC.OpenIPC;

    Function GenClientID: DWORD;
    Begin
        Repeat
            Result := Random(65536) * 65536 + Random(65536);
        Until (Result <> MIPC_USER_UNDEFINED) And (Result <> MIPC_USER_BROADCAST);
    End;

Var
    Precreated: Boolean;
Begin
    If csDesigning In ComponentState Then
        Exit;
    If csLoading In ComponentState Then
        Exit;

    Message_LogonEvent := RegisterWindowMessage(PChar('MIPC_' + MutexName + '_LOGON'));
    If Message_LogonEvent = 0 Then
        Raise EMIPCWindowMessage.Create('Error registering the Login Event Window Message Identifier.');
    Message_StreamEvent := RegisterWindowMessage(PChar('MIPC_' + MutexName + '_STREAM'));
    If Message_StreamEvent = 0 Then
        Raise EMIPCWindowMessage.Create('Error registering the Stream Event Window Message Identifier.');
    Message_CreateID := RegisterWindowMessage(PChar('MIPC_' + MutexName + '_CREATEID'));
    If Message_StreamEvent = 0 Then
        Raise EMIPCWindowMessage.Create('Error registering the Stream Event Window Message Identifier.');

    If Message_LogonEvent = Message_StreamEvent Then
        Raise EMIPCWindowMessage.Create('Duplicate Window Message Identifier for Login and Sequence events.');
    If Message_LogonEvent = Message_CreateID Then
        Raise EMIPCWindowMessage.Create('Duplicate Window Message Identifier for Login and ID Creation events.');
    If Message_CreateID = Message_StreamEvent Then
        Raise EMIPCWindowMessage.Create('Duplicate Window Message Identifier for ID Creation and Sequence events.');

    { DONE 5 -oBenBE -cOpenIPC : Anlegen des Mutex und ermitteln der Client-ID }
    Try
        If (FMutexHandle = INVALID_HANDLE_VALUE) Or (FClientID = MIPC_USER_UNDEFINED) Or (FClientID = MIPC_USER_BROADCAST) Then
        Begin
            CloseIPC;
            SetLastError(ERROR_ALREADY_EXISTS);
            If (FClientID = MIPC_USER_UNDEFINED) Or (FClientID = MIPC_USER_BROADCAST) Then
                FClientID := GenClientID;
            While GetLastError = ERROR_ALREADY_EXISTS Do
            Begin
                FMutexHandle := CreateMutex(Nil, True, PChar(Format('MIPC_%s_CLIENT%.8x', [MutexName, ClientID])));
                If GetLastError = ERROR_ALREADY_EXISTS Then
                Begin
                    CloseHandle(FMutexHandle);
                    FClientID := GenClientID;
                End;
            End;

            If FMutexHandle = 0 Then
                Raise EMIPCInitialization.Create('Error obtaining individual mutex handle.');
        End;

        { DONE 5 -oBenBE -cOpenIPC : Öffnen der MMF }
        If FMMFHandle = INVALID_HANDLE_VALUE Then
        Begin
            FMMFHandle := CreateFileMapping($FFFFFFFF, Nil, PAGE_READWRITE, 0, MutexSize, PChar('MIPC_' + MutexName + '_MMF'));
            If FMMFHandle = 0 Then
                Raise EMIPCInitialization.Create('Error creating file mapping object.');
            Precreated := GetLastError = ERROR_ALREADY_EXISTS;
        End
        Else
            Precreated := True;

        If PMMFData = Nil Then
            PMMFData := MapViewOfFile(FMMFHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0);
        If PMMFData = Nil Then
            Raise EMIPCInitialization.Create('Error creating view for the file mapping object.');

        { DONE 5 -oBenBE -cOpenIPC : Verifizieren der Strukturen }
        If Not Lock Then
            Raise EMIPCTimeout.Create('Timeout while trying to initiate the MIPC MMF.');
        Try
            SetMMFState(MIPC_LOCK_REASON_INIT);
            Try
                If Precreated Then
                Begin
                    If TMutexIPCState(PMMFData^).Header.Signature <> IPCStateSignature Then
                        Precreated := False;
                    If TMutexIPCState(PMMFData^).Header.SendID <> MIPC_USER_BROADCAST Then
                        Precreated := False;
                    If TMutexIPCState(PMMFData^).Header.RecvID <> MIPC_USER_BROADCAST Then
                        Precreated := False;
                    If TMutexIPCState(PMMFData^).Header.CRC32 <> 0 Then
                        Precreated := False;
                    If Not CompareMem(@TMutexIPCState(PMMFData^).MIPCVersion, @MutexIPCVersion, SizeOf(MutexIPCVersion)) Then
                        Precreated := False;
                    If TMutexIPCState(PMMFData^).MMFSize < 2 * SizeOf(TMutexIPCData) Then
                        Precreated := False
                    Else
                        FMutexSize := TMutexIPCState(PMMFData^).MMFSize;
                End;

                If Not Precreated Then
                Begin
                    FillChar(PMMFData^, FMutexSize, 0);
                    SetMMFState(MIPC_LOCK_REASON_INIT);
                    With TMutexIPCState(PMMFData^) Do
                    Begin
                        With Header Do
                        Begin
                            Signature := IPCStateSignature;
                            SendID := MIPC_USER_BROADCAST;
                            RecvID := MIPC_USER_BROADCAST;
                            CRC32 := 0;
                        End;
                        MIPCVersion := MutexIPCVersion;
                        MMFSize := FMutexSize;
                    End;
                End;
            Finally
                SetMMFState(MIPC_LOCK_REASON_UNDEFINED);
            End;
        Finally
            Unlock;
        End;
    Except
        CloseIPC;
        Raise;
    End;

    AnnounceMyself;

    Try
        If Assigned(FOnMutexCreate) Then
            FOnMutexCreate(Self);
    Except
        On E: Exception Do
            If Assigned(FOnMutexUserException) Then
                FOnMutexUserException(Self, E);
    End;
End;

Procedure TMutexIPC.ReadIPC;
Var
    BlockCount: Integer;
    X: Integer;
    MIPCData: ^TMutexIPCData;

    Procedure HandleIPCData(Data: TMutexIPCData);
    Var
        SI: TMutexIPCStreamInfo;
        SIIdx: Integer;
    Begin
        { DONE 5 -oBenBE -cReadIPC : Behandeln von MIPC-Kommandos. }
        Try
            If Assigned(FOnMutexCommand) Then
                FOnMutexCommand(Self, Data);
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;

        Case Data.Command Of
            MIPC_COMMAND_INVALID:
                Begin
                    //Nothing to do: Ignore it!
                End;
            MIPC_COMMAND_SEQUENCE_START:
                Begin
                    //Start a new Transmission
                    { DONE 5 -oBenBE -cReadIPC : Neue Transaktion starten }
                    SI := TMutexIPCStreamInfo.Create;
                    SI.Init(
                        Data.Sequence,
                        Data.Block.Size,
                        PDWORD(@Data.Data[24])^,
                        Data.Header.RecvID,
                        Data.Header.SendID);
                    SI.FMutexIPC := Self;
                    SI.FStreamName := Copy(StrPas(PChar(@Data.Data[32])), 1, PDWORD(@Data.Data[28])^);
                    FStreamInfo.Add(SI);
                End;
            MIPC_COMMAND_SEQUENCE_DATA:
                Begin
                    //Recieve a new data block
                    { DONE 5 -oBenBE -cReadIPC : Neuen Datenblock empfangen }
                    SI := GetSequenceInfo(Data.Sequence);

                    If SI.AddData(Data.Block) Then
                        Move(Data.Data[0], SI.FStreamData.Buffer[Data.Block.Offset], Data.Block.Size);
                End;
            MIPC_COMMAND_SEQUENCE_COMPLETE:
                Begin
                    //Complete a transmission and verify the result
                    { DONE 5 -oBenBE -cReadIPC : Transaktion abschließen und Daten prüfen }

                    SI := GetSequenceInfo(Data.Sequence);
                    SI.Verify(Data);

                    If Assigned(FOnMutexSequenceComplete) Then
                        FOnMutexSequenceComplete(Self, SI.FStreamData.SendID, SI.FStreamData.RecvID, SI.FStreamData.SequenceID);

                    SIIdx := FStreamInfo.IndexOf(SI);
                    If SIIdx <> -1 Then
                        FStreamInfo.Delete(SIIdx);
                End;
        Else
            //Unknown Command ID: Ignore it!
        End;
    End;

Begin
    If Not Lock Then
        Raise EMIPCTimeout.Create('An timeout occured while the MutexIPC was waiting for an object.');
    Try
        SetMMFState(MIPC_LOCK_REASON_READ);
        Try
            MIPCData := PMMFData;
            Inc(MIPCData);

            BlockCount := FMutexSize Div SizeOf(TMutexIPCData) - 1;
            For X := 1 To BlockCount Do
            Begin
                Try
                    If MIPCData^.Header.Signature = IPCDataSignature Then
                    Begin
                        If MIPCData^.Header.RecvID = ClientID Then              //Check if something is to recieve
                        Begin
                            SetMMFState(MIPC_LOCK_REASON_HANDLE);
                            Try
                                If MIPCData^.Header.CRC32 = GetBlockCRC(MIPCData^) Then
                                    HandleIPCData(MIPCData^)
                                Else
                                    Raise EMIPCCRCError.Create('Error when CRC checking!');
                            Finally
                                FillChar(MIPCData^, SizeOf(TMutexIPCData), 0);
                                SetMMFState(MIPC_LOCK_REASON_READ);
                            End;
                        End;
                    End
                    Else If MIPCData^.Header.Signature = 0 Then
                    Begin
                        //Empty Data Block: Ignore it!
                    End
                    Else
                    Begin
                        //Invalid Data Block: Delete it!
                        SetMMFState(MIPC_LOCK_REASON_DEFRAG);
                        Try
                            FillChar(MIPCData^, SizeOf(TMutexIPCData), 0);
                        Finally
                            SetMMFState(MIPC_LOCK_REASON_READ);
                        End;
                    End;
                Except
                    On E: Exception Do
                        If Assigned(FOnMutexUserException) Then
                            FOnMutexUserException(Self, E);
                End;
                Inc(MIPCData);
            End;
        Finally
            SetMMFState(MIPC_LOCK_REASON_UNDEFINED);
        End;
    Finally
        Unlock;
    End;
End;

Procedure TMutexIPC.SendBuffer(ARecvID: DWORD; AName: String; Const ABuffer; ASize: Integer);
Var
    Tmp: TMemoryStream;
Begin
    Tmp := TMemoryStream.Create;
    Try
        Tmp.WriteBuffer(ABuffer, ASize);
        SendStream(ARecvID, AName, Tmp);
    Finally
        Tmp.Free;
    End;
End;

Procedure TMutexIPC.SendChar(ARecvID: DWORD; AName: String; AValue: Char);
Begin
    SendBuffer(ARecvID, AName, AValue, SizeOf(Char));
End;

Procedure TMutexIPC.SendInt64(ARecvID: DWORD; AName: String; AValue: Int64);
Begin
    SendBuffer(ARecvID, AName, AValue, SizeOf(Int64));
End;

Procedure TMutexIPC.SendInteger(ARecvID: DWORD; AName: String; AValue: Integer);
Begin
    SendBuffer(ARecvID, AName, AValue, SizeOf(Integer));
End;

Procedure TMutexIPC.SendStream(ARecvID: DWORD; AName: String; AStream: TStream);
Begin
    If Length(AName) > IPCBlockSize - 32 Then
        Raise EMIPCInvalidName.Create('The specified name is too long. Use a shorter one!');

    DoWriteStream(ARecvID, AName, AStream);
End;

Procedure TMutexIPC.SendString(ARecvID: DWORD; AName, AValue: String);
Var
    Tmp: TMemoryStream;
    ALength: Integer;
Begin
    Tmp := TMemoryStream.Create;
    Try
        ALength := Length(AValue);
        Tmp.WriteBuffer(ALength, SizeOf(Integer));
        If ALength <> 0 Then
            Tmp.WriteBuffer(AValue[1], ALength);
        SendStream(ARecvID, AName, Tmp);
    Finally
        Tmp.Free;
    End;
End;

Function TMutexIPC.SetMMFState(Reason: DWORD): Boolean;
Var
    FMutexStateHandle: THandle;
Begin
    Result := True;
    FMutexStateHandle := CreateMutex(Nil, False, PChar('MIPC_' + MutexName + '_STATE'));
    If FMutexStateHandle = 0 Then
        Result := False
    Else If WaitForSingleObject(FMutexStateHandle, FMutexTimeout) = WAIT_FAILED Then
        Result := False;
    Try
        If Reason = MIPC_LOCK_REASON_UNDEFINED Then
            TMutexIPCState(PMMFData^).LockOwnerID := MIPC_USER_UNDEFINED
        Else
            TMutexIPCState(PMMFData^).LockOwnerID := ClientID;
        TMutexIPCState(PMMFData^).LockReason := Reason;
    Finally
        ReleaseMutex(FMutexStateHandle);
        CloseHandle(FMutexStateHandle);
    End;
End;

Procedure TMutexIPC.SetMutexName(Const Value: String);
Begin
    If FMutexName <> Value Then
    Begin
        If Value = '' Then
            Raise EMIPCInvalidName.Create('''' + Value + ''' is not a valid name for a IPC Mutex object.');

        CloseIPC;
        FMutexName := UpperCase(Value);
        OpenIPC;
    End;
End;

Procedure TMutexIPC.SetMutexSize(Const Value: Integer);
Begin
    If FMutexSize <> Value Then
    Begin
        CloseIPC;
        FMutexSize := Value;
        OpenIPC;
    End;
End;

Procedure TMutexIPC.Unlock;
Begin
    If FMutexLockHandle <> INVALID_HANDLE_VALUE Then
    Begin
        Dec(FMutexLockCount);

        If FMutexLockCount < 1 Then
            FMutexLockCount := 0;

        If FMutexLockCount = 0 Then
        Begin
            ReleaseMutex(FMutexLockHandle);
            CloseHandle(FMutexLockHandle);
            FMutexLockHandle := INVALID_HANDLE_VALUE;
        End;
    End;
End;

Procedure TMutexIPC.WndProc(Var Message: TMessage);
Var
    SendID: DWORD;
    Event: DWORD;
    X: Integer;
Begin
    If Message.Msg = Message_LogonEvent Then
    Begin
        Try
            SendID := Message.lParam;
            Event := Message.wParam;

            Case Event Of
                MIPC_CLIENT_LOGIN:
                    Begin
                        AddClient(SendID);
                        Message.Result := ClientID;
                    End;
                MIPC_CLIENT_LOGOFF:
                    Begin
                        DelClient(SendID);
                        Message.Result := 0;
                    End;
                MIPC_CLIENT_GETHANDLE:
                    Begin
                        If SendID = FClientID Then
                            Message.Result := FWndHandle
                        Else
                            Message.Result := 0;
                    End;
            Else
                Message.Result := 0;
            End;
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;
    End
    Else If Message.Msg = Message_StreamEvent Then
    Begin
        Try
            //  SendID := Message.lParam;
            Event := Message.wParam;

            Case Event Of

                MIPC_SEQUENCE_START:
                    Begin
                        Message.Result := 0;
                    End;
                MIPC_SEQUENCE_COMPLETED:
                    Begin
                        ReadIPC;
                        Message.Result := 0;
                    End;
                MIPC_SEQUENCE_BUFFERFULL:
                    Begin
                        DefragIPC;
                        Message.Result := 0;
                    End;
            Else
                Message.Result := 0;
            End;
        Except
            On E: Exception Do
                If Assigned(FOnMutexUserException) Then
                    FOnMutexUserException(Self, E);
        End;
    End
    Else If Message.Msg = Message_CreateID Then
    Begin
        SendID := Message.lParam;
        For X := 0 To FStreamInfo.Count - 1 Do
            If TMutexIPCStreamInfo(FStreamInfo[X]).FStreamData.SequenceID = SendID Then
            Begin
                Message.Result := 1;
                Break;
            End;
    End
    Else
    Begin
        DefaultHandler(Message);
    End;
End;

Procedure TMutexIPC.WriteIPC(AData: TMutexIPCData);
Var
    X: Integer;
    BlockCount: Integer;
    DataSent: Boolean;
    MIPCData: PMutexIPCDataArray;
Begin
    DataSent := False;
    While Not DataSent Do
    Begin
        If Not Lock Then
            Raise EMIPCTimeout.Create('An timeout occured while the MutexIPC was waiting for an object.');
        Try
            SetMMFState(MIPC_LOCK_REASON_WRITE);
            Try
                MIPCData := PMMFData;

                BlockCount := FMutexSize Div SizeOf(TMutexIPCData) - 1;

                X := FLastWriteIdx;
                Repeat
                    If MIPCData^[X].Header.Signature <> IPCDataSignature Then
                    Begin
                        AData.Header.Signature := IPCDataSignature;
                        AData.Header.SendID := FClientID;
                        AData.Header.CRC32 := GetBlockCRC(AData);

                        MIPCData^[X] := AData;
                        DataSent := True;
                        FLastWriteIdx := X;
                        Break;
                    End;

                    Inc(X);
                    If X >= BlockCount Then
                        X := 1;
                Until X = FLastWriteIdx;
            Finally
                SetMMFState(MIPC_LOCK_REASON_UNDEFINED);
            End;
        Finally
            Unlock;
        End;

        If Not DataSent Then
            DefragIPC;
    End;
End;

{ TMutexIPCStreamInfo }

Function TMutexIPCStreamInfo.AddData(AD: TMutexIPCBlock): Boolean;
Var
    X: Integer;
    Idx: Integer;
    MD: TMutexIPCBlock;
Begin
    Result := False;
    With FStreamData Do
    Begin
        For X := 0 To High(Missing) Do
        Begin
            MD := Missing[X];
            If MD.Offset < AD.Offset Then                                       //Begin of the missing block before the current location?
            Begin
                If MD.Offset + MD.Size > AD.Offset + AD.Size Then               //End of the block after the end of the current block?
                Begin
                    SetLength(Missing, Length(Missing) + 1);
                    Idx := High(Missing);
                    Missing[Idx].Offset := AD.Offset + AD.Size;
                    Missing[Idx].Size := MD.Offset + MD.Size - Missing[Idx].Offset;
                    MD.Size := AD.Offset - MD.Offset;
                    Result := True;
                End
                Else If MD.Offset + MD.Size = AD.Offset + AD.Size Then          //End of the block at the end of the current block?
                Begin
                    MD.Size := AD.Offset - MD.Offset;
                    Result := True;
                End;
            End
            Else If MD.Offset = AD.Offset Then                                  //Begin of the missing block at the current location?
            Begin
                If MD.Size > AD.Size Then                                       //End of the block after the end of the current block?
                Begin
                    MD.Offset := MD.Offset + AD.Size;
                    Result := True;
                End
                Else If MD.Size = AD.Size Then                                  //End of the block at the end of the current block?
                Begin
                    MD.Offset := 0;
                    MD.Size := 0;
                    Result := True;
                End;
            End;
            Missing[X] := MD;
        End;

        Idx := 0;
        For X := 0 To High(Missing) Do
        Begin
            Missing[Idx] := Missing[X];
            If (Missing[Idx].Offset <> 0) And (Missing[Idx].Size <> 0) Then
                Inc(Idx);
        End;
        SetLength(Missing, Idx);
    End;
End;

Constructor TMutexIPCStreamInfo.Create;
Begin
    Inherited;
    SetLength(FStreamData.Buffer, 0);
    SetLength(FStreamData.Missing, 0);
    FMutexIPC := Nil;
End;

Destructor TMutexIPCStreamInfo.Destroy;
Begin
    FMutexIPC := Nil;
    SetLength(FStreamData.Buffer, 0);
    SetLength(FStreamData.Missing, 0);
    Inherited;
End;

Procedure TMutexIPCStreamInfo.Init(ID, Size, CRC, RecvID, SendID: DWORD);
Begin
    FStreamData.SequenceID := ID;
    FStreamData.Size := Size;
    FStreamData.CRC32 := CRC;
    FStreamData.RecvID := RecvID;
    FStreamData.SendID := SendID;
    SetLength(FStreamData.Buffer, FStreamData.Size);
    FillChar(FStreamData.Buffer[0], FStreamData.Size, 0);
    SetLength(FStreamData.Missing, 1);
    FStreamData.Missing[0].Offset := 0;
    FStreamData.Missing[0].Size := FStreamData.Size;
End;

Procedure TMutexIPCStreamInfo.Verify(Data: TMutexIPCData);
Var
    MS: TMemoryStream;
Begin
    { TODO 5 -oBenBE -cStreamInfo : Verifizieren der Stream-Daten, Überprüfung auf fehlende Teile. }
    MS := FMutexIPC.GetSequenceData(Data.Sequence);
    Try
        If PDWORD(@Data.Data[0])^ <> GetStreamCRC(MS, 0, 0) Then
            Raise EMIPCCRCError.Create('Error when CRC checking!');
    Finally
        MS.Free;
    End;
End;

Initialization
    //Ensures that nothing of the state header is overwritten
    If SizeOf(TMutexIPCData) < SizeOf(TMutexIPCState) Then
        Halt;
    Randomize;
End.					

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:

unit MutexMIC;

interface

uses
  Windows, Messages, SysUtils, Classes, Forms, Dialogs;

type
  TReceiveEvent = procedure(SourceID : Byte;var X;Size : Word) of object;
  TConnectEvent = procedure(SourceID : Byte) of object;
  TOnMessage = procedure(var msg: tagMsg; var Handled: Boolean) of object;

  TMutexMIC = class(TComponent)
  private
    MMFSize, MMFBlock : Cardinal;
    InstanceNumber : Byte;
    InstanceRunning : array[0..254] of Boolean;
    MainMutex : THandle;
    HMMF : THandle;
    LockMutex : THandle;
    PMMF : Pointer;
    MIC_SEND : UINT;
    MIC_ONOFF : UINT;
    FOnReceive : TReceiveEvent;
    FOnConnect : TConnectEvent;
    OldOnMessage : TOnMessage;
    FName : string;
    function MMFLock : Boolean;
    procedure MMFUnlock;
    procedure MICReceiver(var msg: tagMsg; var Handled: Boolean);
  protected
  public
    constructor Create(AOwner : TComponent;Name : string;MMFBlockCount, MMFBlockSize : Cardinal);reintroduce;
    procedure AfterConstruction;override;
    procedure BeforeDestruction;override;
  published
    property ID : Byte read InstanceNumber;
    property Name : string read FName;
    function IsRunning(ID : Byte) : Boolean;
    procedure Send(DestID : Byte;var X;Size : Word);
    property OnReceive : TReceiveEvent read FOnReceive write FOnReceive;
    property OnConnect : TConnectEvent read FOnConnect write FOnConnect;
  end;

implementation

constructor TMutexMIC.Create(AOwner : TComponent;Name : string;MMFBlockCount, MMFBlockSize : Cardinal);
begin
  inherited Create(AOwner);
  FName:=Name;
  MMFBlock:=MMFBlockSize;
  if MMFBlock > 65536 then MMFBlock:=65536;
  MMFSize:=MMFBlockCount*MMFBlock;
  MIC_SEND:=RegisterWindowMessage(PChar('MIC_'+FName+'_SEND'));
  MIC_ONOFF:=RegisterWindowMessage(PChar('MIC_'+FName+'_ONOFF'));
end;

procedure TMutexMIC.AfterConstruction;
var
  a : Integer;
  b : Boolean;
  TempHandle : THandle;
begin
  //Eigener einmaliger Mutex
  InstanceNumber:=255;
  for a:=0 to 254 do
  begin
    InstanceRunning[a]:=True;
    TempHandle:=CreateMutex(nil,True,PChar('TMutexMIC-'+FName+'-MAIN-'+InttoStr(a)));
    if GetLastError = 0 then
    begin
      if InstanceNumber = 255 then
      begin
        InstanceNumber:=a;
        MainMutex:=TempHandle;
      end else
      begin
        InstanceRunning[a]:=False;
        CloseHandle(TempHandle);
      end;
    end else
      CloseHandle(TempHandle);
  end;
  if MainMutex = 0 then Halt;
  //Global anmelden
  PostMessage(HWND_BROADCAST,MIC_ONOFF,InstanceNumber,0);
  //MMF erstellen. Oder schon da?
  HMMF:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,MMFSize,PChar('TMutexMIC-'+FName+'-MMF'));
  b:=GetLastError <> ERROR_ALREADY_EXISTS;
  if HMMF = 0 then Halt;
  PMMF:=MapViewOfFile(HMMF,FILE_MAP_ALL_ACCESS,0,0,0);
  if PMMF = nil then
  begin
    CloseHandle(HMMF);
    Halt;
  end;
  if b then FillChar(PMMF^,MMFSize,0);
  //Lauscher auf!
  OldOnMessage:=Application.OnMessage;
  Application.OnMessage:=MICReceiver;
end;

procedure TMutexMIC.BeforeDestruction;
begin
  PostMessage(HWND_BROADCAST,MIC_ONOFF,InstanceNumber,1);
  UnMapViewOfFile(PMMF);
  CloseHandle(HMMF);
  CloseHandle(MainMutex);
end;

function TMutexMIC.IsRunning(ID : Byte) : Boolean;
begin
  Result:=InstanceRunning[ID];
end;

//MMF-Zugriffsmutex setzen, ggf. eine Sekunde warten
function TMutexMIC.MMFLock : Boolean;
begin
  Result:=True;
  LockMutex:=CreateMutex(nil,False,PChar('TMutexMIC-'+FName+'-LOCK'));
  if LockMutex = 0 then Result:=False else
  if WaitForSingleObject(LockMutex,1000) = WAIT_FAILED then Result:=False;
end;

//MMF-Zugriffsmutex löschen
procedure TMutexMIC.MMFUnlock;
begin
  ReleaseMutex(LockMutex);
  CloseHandle(LockMutex);
end;

procedure TMutexMIC.Send(DestID : Byte;var X;Size : Word);
var
  a, b : Integer;
  buf : array[0..3] of Byte;
  w : Word;
  p : ^Byte;
begin
  if not InstanceRunning[DestID] then Exit;
  if Size > MMFBlock-4 then Exit;
  if MMFLock then
  begin
    //Datenpaket erstellen
    buf[0]:=InstanceNumber;
    buf[1]:=DestID;
    buf[2]:=Hi(Size);
    buf[3]:=Lo(Size);
    //Freien Platz im MMF finden und dort ablegen
    b:=MMFSize div MMFBlock-1;
    p:=PMMF;
    for a:=0 to b do
    begin
      Move(p^,w,2);
      if w = 0 then
      begin
        Move(buf,p^,4);
        Inc(p,4);
        Move(X,p^,Size);
        Break;
      end;
      Inc(p,MMFBlock);
    end;
    MMFUnlock;
    //Gegenüber benachrichtigen: "Sie haben Post"
    PostMessage(HWND_BROADCAST,MIC_SEND,InstanceNumber,DestID);
  end;
end;

//Wenn eine andere Instanz ruft ...
procedure TMutexMIC.MICReceiver(var msg: tagMsg; var Handled: Boolean);
var
  a, b : Integer;
  buf : array[0..3] of Byte;
  dat : array of Byte;
  p : ^Byte;
  SourceID : Byte;
begin
  if (msg.message = MIC_SEND) and (msg.lParam = InstanceNumber) then
  begin
    if MMFLock then
    begin
      SourceID:=255;
      //Datenpakete mit eigener Zieladresse auslesen und aus dem MMF löschen
      b:=MMFSize div MMFBlock-1;
      p:=PMMF;
      for a:=0 to b do
      begin
        Move(p^,buf,4);
        if (buf[1] = InstanceNumber) and (buf[2]*256+buf[3] > 0) then
        begin
          SourceID:=buf[0];
          SetLength(dat,buf[2]*256+buf[3]);
          Inc(p,4);
          Move(p^,dat[0],Length(dat));
          Dec(p,4);
          FillChar(buf,4,0);
          Move(buf,p^,4);
          Break;
        end;
        Inc(p,MMFBlock);
      end;
      MMFUnlock;
      if Assigned(FOnReceive) then FOnReceive(SourceID,dat[0],Length(dat));
    end;
    Handled:=True;
    Exit;
  end;
  if msg.message = MIC_ONOFF then
  begin
    if msg.lParam = 0 then InstanceRunning[msg.wParam]:=True else
      InstanceRunning[msg.wParam]:=False;
    if Assigned(FOnConnect) then FOnConnect(msg.wparam);
    Handled:=True;
    Exit;
  end;
  if Assigned(OldOnMessage) then OldOnMessage(msg,Handled);
end;

end.