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
|
unit yokesharemem;
{$mode objfpc}{$H+}
interface
//http://community.freepascal.org:10000/docs-html/rtl/ipc/shmctl
// call CreateSharedMem when an application is created and CloseSharedMem when a program is closed
// along with NInstances, these functions return the number of concurrent instances.
// if a program crashes, the values may not be reset until the next reboot
uses
forms, classes,
{$IFDEF UNIX}
BaseUnix, SysUtils, ipc,dialogs;
{$ELSE}
winmemmap;
{$ENDIF}
function CreateSharedMem (lApp: TComponent): integer; //returns number of instances after including this one...
function CloseSharedMem: integer; //returns number of instances after after this one closes
function NInstances: integer; //returns number of instances
function SetShareFloats(lXmm,lYmm,lZmm: single): boolean;
function GetShareFloats(var lXmm,lYmm,lZmm: single): boolean;
implementation
type
TShareMem = record
Instances: integer;
Xmm,Ymm,Zmm: single;
end;
PIntBuffer = ^TShareMem;
var
gShareIntBuf: PIntBuffer;
gPrevShare : TShareMem;
function NInstances: integer;
begin
result := gShareIntBuf^.Instances;
end;
function SetShareFloats(lXmm,lYmm,lZmm: single): boolean;
begin
gShareIntBuf^.Xmm := lXmm;
gShareIntBuf^.Ymm := lYmm;
gShareIntBuf^.Zmm := lZmm;
gPrevShare := gShareIntBuf^;
end;
function GetShareFloats(var lXmm,lYmm,lZmm: single): boolean;
begin
lXmm := gShareIntBuf^.Xmm;
lYmm := gShareIntBuf^.Ymm;
lZmm := gShareIntBuf^.Zmm;
if (lXmm = gPrevShare.Xmm) and (lYmm = gPrevShare.Ymm) and(lZmm = gPrevShare.Zmm) then
result := false
else
result := true;
gPrevShare := gShareIntBuf^;
end;
{$IFNDEF UNIX} //Windows implementation
var
EMemMap : TEMemMap;
function CreateSharedMem (lApp: TComponent): integer; //returns number of instances after including this one...
var
I: integer;
begin
EMemMap:=TEMemMap.Create(lApp{Self});
EMemMap.CreateMutex('MRICROMUTEX3');
If NOT EMemMap.MapExisting('MRICROMAP3',SizeOf(TShareMem)) then begin
gPrevShare.Xmm:=0;
gPrevShare.Ymm:=0;
gPrevShare.Zmm:=0;
gPrevShare.Instances:=0;
If NOT EMemMap.CreateMemMap('MRICROMAP2',SizeOf(TShareMem),gPrevShare) then
EMemMap.RaiseMappingException;
gShareIntBuf := PINtBuffer(EMemMap.MemMap);
end else
gShareIntBuf^.Instances := gShareIntBuf^.Instances + 1;
end;
function CloseSharedMem: integer; //returns number of instances after after this one closesb
begin
EMemMap.Free;
end;
{$ELSE}
var
fshmid: longint;
segptr : Pointer;
function CreateSharedMem (lApp: TComponent): integer; //returns number of instances after including this one...
var
key : Tkey;
new: boolean;
const ftokpath = '.'#0;
begin
key := ftok (pchar(@ftokpath[1]),ord('S'));
fshmid := shmget(key,SizeOf(TShareMem) {segsize},IPC_CREAT or IPC_EXCL or 438);
If fshmid=-1 then begin
//showmessage('Loading existing memory.');
new := false;
fshmid := shmget(key,SizeOf(TShareMem){segsize},0);
If fshmid = -1 then begin
showmessage ('Shared memory : Error !'+inttostr(fpgeterrno));
halt(1);
end
end
else begin
new := true;
//showmessage ('Creating new shared memory segment.');
end;
segptr:=shmat(fshmid,nil,0);
gShareIntBuf := segptr;
if new then
gShareIntBuf^.Instances := 1
else
gShareIntBuf^.Instances :=gShareIntBuf^.Instances + 1;
result := gShareIntBuf^.Instances;
end;
function CloseSharedMem: integer;
//returns number of instances after this application quits
begin
gShareIntBuf^.Instances := gShareIntBuf^.Instances -1;
result := gShareIntBuf^.Instances;
if Assigned (segptr) then
shmdt (segptr);
if result < 1 then begin //last running instance - close shared memory
if shmctl (FShmId, IPC_RMID, nil) = -1 then
Showmessage('unable to release shared memory');
end;
end;
{$ENDIF}
end.
|