← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/ptc/src/x11/x11imagei.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/ptc/src/x11/x11imagei.inc
 
1
Const
 
2
{$WARNING this belongs to the ipc unit}
 
3
  IPC_PRIVATE = 0;
 
4
 
 
5
Constructor TX11Image.Create(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer; AFormat : TPTCFormat);
 
6
 
 
7
Begin
 
8
  FWidth := AWidth;
 
9
  FHeight := AHeight;
 
10
  FDisplay := ADisplay;
 
11
End;
 
12
 
 
13
Constructor TX11NormalImage.Create(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer; AFormat : TPTCFormat);
 
14
 
 
15
Var
 
16
  xpad, xpitch : Integer;
 
17
  tmp_FPixels : PChar;
 
18
 
 
19
Begin
 
20
  Inherited;
 
21
 
 
22
  xpad := AFormat.Bits;
 
23
  If AFormat.Bits = 24 Then
 
24
    xpad := 32;
 
25
  xpitch := AWidth * AFormat.Bits Div 8;
 
26
  Inc(xpitch, 3);
 
27
  xpitch := xpitch And (Not 3);
 
28
  FPixels := GetMem(xpitch * AHeight);
 
29
  Pointer(tmp_FPixels) := Pointer(FPixels);
 
30
  FImage := XCreateImage(ADisplay, DefaultVisual(ADisplay, AScreen),
 
31
                         DefaultDepth(ADisplay, AScreen),
 
32
                         ZPixmap, 0, tmp_FPixels,
 
33
                         AWidth, AHeight, xpad, 0);
 
34
  If FImage = Nil Then
 
35
    Raise TPTCError.Create('cannot create XImage');
 
36
End;
 
37
 
 
38
Destructor TX11NormalImage.Destroy;
 
39
 
 
40
Begin
 
41
  If FImage <> Nil Then
 
42
  Begin
 
43
    { Restore XImage's buffer pointer }
 
44
    FImage^.data := Nil;
 
45
    XDestroyImage(FImage);
 
46
  End;
 
47
 
 
48
  If FPixels <> Nil Then
 
49
    FreeMem(FPixels);
 
50
 
 
51
  Inherited Destroy;
 
52
End;
 
53
 
 
54
Procedure TX11NormalImage.Put(AWindow : TWindow; AGC : TGC; AX, AY : Integer);
 
55
 
 
56
Begin
 
57
  XPutImage(FDisplay, AWindow, AGC, FImage, 0, 0, AX, AY, FWidth, FHeight);
 
58
  XSync(FDisplay, False);
 
59
End;
 
60
 
 
61
Procedure TX11NormalImage.Put(AWindow : TWindow; AGC : TGC; ASX, ASY, ADX, ADY,
 
62
                    AWidth, AHeight : Integer);
 
63
 
 
64
Begin
 
65
  XPutImage(FDisplay, AWindow, AGC, FImage, ASX, ASY, ADX, ADY, AWidth, AHeight);
 
66
  XSync(FDisplay, False);
 
67
End;
 
68
 
 
69
Function TX11NormalImage.Lock : Pointer;
 
70
 
 
71
Begin
 
72
  Result := FPixels;
 
73
End;
 
74
 
 
75
Function TX11NormalImage.Pitch : Integer;
 
76
 
 
77
Begin
 
78
  Result := FImage^.bytes_per_line;
 
79
End;
 
80
 
 
81
Function TX11NormalImage.Name : String;
 
82
 
 
83
Begin
 
84
  Result := 'XImage';
 
85
End;
 
86
 
 
87
{$IFDEF ENABLE_X11_EXTENSION_XSHM}
 
88
 
 
89
Var
 
90
  Fshm_error : Boolean;
 
91
  Fshm_oldhandler : Function(disp : PDisplay; xev : PXErrorEvent) : Integer; CDecl;
 
92
 
 
93
Function Fshm_errorhandler(disp : PDisplay; xev : PXErrorEvent) : Integer; CDecl;
 
94
 
 
95
Begin
 
96
  If xev^.error_code=BadAccess Then
 
97
  Begin
 
98
    Fshm_error := True;
 
99
    Result := 0;
 
100
  End
 
101
  Else
 
102
    Result := Fshm_oldhandler(disp, xev);
 
103
End;
 
104
 
 
105
Constructor TX11ShmImage.Create(ADisplay : PDisplay; AScreen, AWidth, AHeight : Integer; AFormat : TPTCFormat);
 
106
 
 
107
Begin
 
108
  Inherited;
 
109
 
 
110
  FShmInfo.shmid := -1;
 
111
  FShmInfo.shmaddr := Pointer(-1);
 
112
  FImage := XShmCreateImage(ADisplay, DefaultVisual(ADisplay, AScreen),
 
113
                            DefaultDepth(ADisplay, AScreen),
 
114
                            ZPixmap, Nil, @FShmInfo, AWidth, AHeight);
 
115
  If FImage = Nil Then
 
116
    Raise TPTCError.Create('cannot create SHM image');
 
117
 
 
118
  FShmInfo.shmid := shmget(IPC_PRIVATE, FImage^.bytes_per_line * FImage^.height,
 
119
                           IPC_CREAT Or &777);
 
120
  If FShmInfo.shmid = -1 Then
 
121
    Raise TPTCError.Create('cannot get shared memory segment');
 
122
 
 
123
  FShmInfo.shmaddr := shmat(FShmInfo.shmid, Nil, 0);
 
124
  FShmInfo.readOnly := False;
 
125
  FImage^.data := FShmInfo.shmaddr;
 
126
 
 
127
  If Pointer(FShmInfo.shmaddr) = Pointer(-1) Then
 
128
    Raise TPTCError.Create('cannot allocate shared memory');
 
129
 
 
130
  // Try and attach the segment to the server. Bugfix: Have to catch
 
131
  // bad access errors in case it runs over the net.
 
132
  Fshm_error := False;
 
133
  Fshm_oldhandler := XSetErrorHandler(@Fshm_errorhandler);
 
134
  Try
 
135
    If XShmAttach(ADisplay, @FShmInfo) = 0 Then
 
136
      Raise TPTCError.Create('cannot attach shared memory segment to display');
 
137
 
 
138
    XSync(ADisplay, False);
 
139
    If Fshm_error Then
 
140
      Raise TPTCError.Create('cannot attach shared memory segment to display');
 
141
    FShmAttached := True;
 
142
  Finally
 
143
    XSetErrorHandler(Fshm_oldhandler);
 
144
  End;
 
145
End;
 
146
 
 
147
Destructor TX11ShmImage.Destroy;
 
148
 
 
149
Begin
 
150
  If FShmAttached Then
 
151
  Begin
 
152
    XShmDetach(FDisplay, @FShmInfo);
 
153
    XSync(FDisplay, False);
 
154
  End;
 
155
  If FImage <> Nil Then
 
156
    XDestroyImage(FImage);
 
157
  If Pointer(FShmInfo.shmaddr) <> Pointer(-1) Then
 
158
    shmdt(FShmInfo.shmaddr);
 
159
  If FShmInfo.shmid <> -1 Then
 
160
    shmctl(FShmInfo.shmid, IPC_RMID, Nil);
 
161
 
 
162
  Inherited Destroy;
 
163
End;
 
164
 
 
165
Procedure TX11ShmImage.Put(AWindow : TWindow; AGC : TGC; AX, AY : Integer);
 
166
 
 
167
Begin
 
168
  XShmPutImage(FDisplay, AWindow, AGC, FImage, 0, 0, AX, AY, FWidth, FHeight, False);
 
169
  XSync(FDisplay, False);
 
170
End;
 
171
 
 
172
Procedure TX11ShmImage.Put(AWindow : TWindow; AGC : TGC; ASX, ASY, ADX, ADY,
 
173
                    AWidth, AHeight : Integer);
 
174
 
 
175
Begin
 
176
  XShmPutImage(FDisplay, AWindow, AGC, FImage, ASX, ASY, ADX, ADY, FWidth, FHeight, False);
 
177
  XSync(FDisplay, False);
 
178
End;
 
179
 
 
180
Function TX11ShmImage.Lock : Pointer;
 
181
 
 
182
Begin
 
183
  Result := Pointer(FShmInfo.shmaddr);
 
184
End;
 
185
 
 
186
Function TX11ShmImage.Pitch : Integer;
 
187
 
 
188
Begin
 
189
  Result := FImage^.bytes_per_line;
 
190
End;
 
191
 
 
192
Function TX11ShmImage.Name : String;
 
193
 
 
194
Begin
 
195
  Result := 'MIT-Shm';
 
196
End;
 
197
{$ENDIF ENABLE_X11_EXTENSION_XSHM}