/usr/lib/ocaml/lablgtk2/gDraw.ml is in liblablgtk2-ocaml-dev 2.16.0+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | (**************************************************************************)
(* Lablgtk *)
(* *)
(* This program is free software; you can redistribute it *)
(* and/or modify it under the terms of the GNU Library General *)
(* Public License as published by the Free Software Foundation *)
(* version 2, with the exception described in file COPYING which *)
(* comes with the library. *)
(* *)
(* This program is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Library General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Library General *)
(* Public License along with this program; if not, write to the *)
(* Free Software Foundation, Inc., 59 Temple Place, Suite 330, *)
(* Boston, MA 02111-1307 USA *)
(* *)
(* *)
(**************************************************************************)
(* $Id$ *)
open Gaux
open Gobject
open Gdk
type color = [
| `COLOR of Gdk.color
| `WHITE
| `BLACK
| `NAME of string
| `RGB of int * int * int
]
let default_colormap = GtkBase.Widget.get_default_colormap
let color ?(colormap = default_colormap ()) (c : color) =
match c with
| `COLOR col -> col
| #Gdk.Color.spec as def -> Color.alloc ~colormap def
let conv_color : color data_conv =
{ kind = `POINTER;
proj = (function `POINTER (Some c) -> `COLOR (Obj.magic c)
| _ -> failwith "GDraw.get_color");
inj = (fun c -> `POINTER (Some (Obj.magic (color c : Gdk.color)))) }
type optcolor = [
| `COLOR of Gdk.color
| `WHITE
| `BLACK
| `NAME of string
| `RGB of int * int * int
| `DEFAULT
]
let optcolor ?colormap (c : optcolor) =
match c with
| `DEFAULT -> None
| #color as c -> Some (color ?colormap c)
let conv_optcolor : optcolor data_conv =
{ kind = `POINTER;
proj = (function `POINTER (Some c) -> `COLOR (Obj.magic c)
| `POINTER None -> `DEFAULT
| _ -> failwith "GDraw.get_color");
inj = (fun c -> `POINTER (Obj.magic (optcolor c : Gdk.color option))) }
class drawable ?(colormap = default_colormap ()) w = object (self)
val colormap = colormap
val mutable gc = GC.create w
val w = w
method colormap = colormap
method gc = gc
method set_gc x = gc <- x
method color = color ~colormap
method set_foreground col = GC.set_foreground gc (self#color col)
method set_background col = GC.set_background gc (self#color col)
method size = Drawable.get_size w
method depth = Drawable.get_depth w
method gc_values = GC.get_values gc
method set_clip_region = GC.set_clip_region gc
method set_clip_origin = GC.set_clip_origin gc
method set_clip_mask = GC.set_clip_mask gc
method set_clip_rectangle = GC.set_clip_rectangle gc
method set_line_attributes ?width ?style ?cap ?join () =
let v = GC.get_values gc in
GC.set_line_attributes gc
~width:(default v.GC.line_width ~opt:width)
~style:(default v.GC.line_style ~opt:style)
~cap:(default v.GC.cap_style ~opt:cap)
~join:(default v.GC.join_style ~opt:join)
method point = Draw.point w gc
method line = Draw.line w gc
method rectangle = Draw.rectangle w gc
method arc = Draw.arc w gc
method polygon = Draw.polygon w gc
method string s = Draw.string w gc s
method put_layout ~x ~y ?fore ?back lay =
Draw.layout w gc ~x ~y lay
?fore:(may_map self#color fore) ?back:(may_map self#color back)
method put_image ~x ~y = Draw.image w gc ~xdest:x ~ydest:y
method put_pixmap ~x ~y = Draw.pixmap w gc ~xdest:x ~ydest:y
method put_rgb_data = Rgb.draw_image w gc
method put_pixbuf ~x ~y = GdkPixbuf.draw_pixbuf w gc ~dest_x:x ~dest_y:y
method points = Draw.points w gc
method lines = Draw.lines w gc
method segments = Draw.segments w gc
end
class pixmap ?colormap ?mask pm = object
inherit drawable ?colormap pm as pixmap
val bitmap = may_map mask ~f:
begin fun x ->
let mask = new drawable x in
mask#set_foreground `WHITE;
mask
end
val mask : Gdk.bitmap option = mask
method pixmap : Gdk.pixmap = w
method mask = mask
method set_line_attributes ?width ?style ?cap ?join () =
pixmap#set_line_attributes ?width ?style ?cap ?join ();
may bitmap ~f:(fun m -> m#set_line_attributes ?width ?style ?cap ?join ())
method point ~x ~y =
pixmap#point ~x ~y;
may bitmap ~f:(fun m -> m#point ~x ~y)
method line ~x ~y ~x:x' ~y:y' =
pixmap#line ~x ~y ~x:x' ~y:y';
may bitmap ~f:(fun m -> m#line ~x ~y ~x:x' ~y:y')
method rectangle ~x ~y ~width ~height ?filled () =
pixmap#rectangle ~x ~y ~width ~height ?filled ();
may bitmap ~f:(fun m -> m#rectangle ~x ~y ~width ~height ?filled ())
method arc ~x ~y ~width ~height ?filled ?start ?angle () =
pixmap#arc ~x ~y ~width ~height ?filled ?start ?angle ();
may bitmap
~f:(fun m -> m#arc ~x ~y ~width ~height ?filled ?start ?angle ());
method polygon ?filled l =
pixmap#polygon ?filled l;
may bitmap ~f:(fun m -> m#polygon ?filled l)
method string s ~font ~x ~y =
pixmap#string s ~font ~x ~y;
may bitmap ~f:(fun m -> m#string s ~font ~x ~y)
method points pts = pixmap#points pts; may bitmap ~f:(fun m -> m#points pts)
method lines pts = pixmap#lines pts; may bitmap ~f:(fun m -> m#lines pts)
method segments lns =
pixmap#segments lns; may bitmap ~f:(fun m -> m#segments lns)
method put_layout ~x ~y ?fore ?back lay =
pixmap#put_layout ~x ~y ?fore ?back lay;
may bitmap ~f:(fun (m : #drawable) -> m#put_layout ~x ~y lay)
end
class type misc_ops = object
method colormap : colormap
method realize : unit -> unit
method visual_depth : int
method window : window
end
let pixmap ~width ~height ?(mask=false)
?(window : < misc : #misc_ops; .. > option) ?colormap () =
let window, depth, colormap =
match window with
Some w ->
begin try
w#misc#realize ();
Some w#misc#window, w#misc#visual_depth,
match colormap with Some c -> c | None -> w#misc#colormap
with Gpointer.Null -> failwith "GDraw.pixmap : window"
end
| None ->
let colormap =
match colormap with Some c -> c | None -> default_colormap () in
None, (Gdk.Visual.depth (Gdk.Color.get_visual colormap)), colormap
in
let mask =
if not mask then None else
let bm = Bitmap.create ?window ~width ~height () in
let mask = new drawable bm in
mask#set_foreground `BLACK;
mask#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
Some bm
in
new pixmap (Pixmap.create ?window ~width ~height ~depth ()) ~colormap ?mask
let pixmap_from_xpm ~file ?window ?colormap ?transparent () =
let window =
try may_map window ~f:(fun w -> w#misc#realize (); w#misc#window)
with Gpointer.Null -> invalid_arg "GDraw.pixmap_from_xpm : window"
in
let colormap =
if colormap <> None || window <> None then colormap
else Some (default_colormap ())
in
let pm, mask =
try Pixmap.create_from_xpm ~file ?window ?colormap
?transparent:(may_map transparent ~f:(fun c -> color c)) ()
with _ -> invalid_arg ("GDraw.pixmap_from_xpm : " ^ file) in
new pixmap pm ?colormap ~mask
let pixmap_from_xpm_d ~data ?window ?colormap ?transparent () =
let window =
try may_map window ~f:(fun w -> w#misc#realize (); w#misc#window)
with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm_d : no window" in
let pm, mask =
Pixmap.create_from_xpm_d ~data ?colormap ?window
?transparent:(may_map transparent ~f:(fun c -> color c)) () in
new pixmap pm ?colormap ~mask
class drag_context context = object
val context = context
method status ?(time=Int32.zero) act = DnD.drag_status context act ~time
method suggested_action = DnD.drag_context_suggested_action context
method targets = List.map Gdk.Atom.name (DnD.drag_context_targets context)
end
|