← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to packages/extra/ptc/x11/image.inc

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

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