$X11::GLX::DWIM::VERSION
=
'0.06'
;
has
display
=> (
is
=>
'lazy'
);
sub
_build_display {
my
$self
=
shift
;
$log
->trace(
'Connecting to display server'
);
return
X11::Xlib->new;
}
has
screen
=> (
is
=>
'lazy'
);
sub
_build_screen {
shift
->display->screen }
has
_glx_version
=> (
is
=>
'lazy'
);
sub
_build__glx_version {
X11::GLX::glXQueryVersion(
shift
->display,
my
$major
,
my
$minor
);
$log
->tracef(
'GLX Version %d.%d'
,
$major
,
$minor
)
if
$log
->is_trace;
return
[
$major
,
$minor
];
}
sub
glx_version {
join
"."
, @{
shift
->_glx_version } }
sub
glx_version_bcd {
my
$v
=
shift
->_glx_version;
$v
->[0] * 100 +
$v
->[1] }
has
glx_extensions
=> (
is
=>
'lazy'
);
sub
_build_glx_extensions {
X11::GLX::glXQueryExtensionsString(
shift
->display);
}
has
_fbconfig_args
=> (
is
=>
'ro'
,
init_arg
=>
'fbconfig'
);
has
fbconfig
=> (
is
=>
'lazy'
,
init_arg
=>
undef
);
has
_visual_info_args
=> (
is
=>
'ro'
,
init_arg
=>
'visual_info'
);
has
visual_info
=> (
is
=>
'lazy'
,
init_arg
=>
undef
);
sub
_build_fbconfig {
my
$self
=
shift
;
return
undef
unless
$self
->glx_version_bcd >= 103 && X11::GLX->can(
'glXChooseFBConfig'
);
my
$arg
=
$self
->_fbconfig_args;
if
(!
$arg
) {
if
(
defined
$self
->_visual_info_args) {
croak(
"TODO: convert visual_info args to fbconfig"
);
}
else
{
$arg
= [
X11::GLX::
GLX_DOUBLEBUFFER
=> 1,
X11::GLX::
GLX_RED_SIZE
=> 8,
X11::GLX::
GLX_GREEN_SIZE
=> 8,
X11::GLX::
GLX_BLUE_SIZE
=> 8,
];
}
}
return
$arg
if
ref
(
$arg
) &&
ref
(
$arg
)->isa(
'X11::GLX::FBConfig'
);
$log
->tracef(
'Calling glXChooseFBConfig'
);
my
@fbc
= X11::GLX::glXChooseFBConfig(
$self
->display,
$self
->screen->screen_number,
$arg
);
$log
->tracef(
" found %d matching fbconfigs"
,
scalar
@fbc
);
my
@fbc_with_visual
=
grep
{
$_
->visual_id }
@fbc
;
$log
->tracef(
" %d of which have an X11 Visual"
,
scalar
@fbc_with_visual
);
my
$ret
;
my
$want_alpha
= 0;
for
(0..
$#$arg
) {
if
(
$arg
->[
$_
] == X11::GLX::GLX_ALPHA_SIZE &&
$_
<
$#$arg
&&
$arg
->[
$_
+1] > 0) {
$want_alpha
= 1;
}
}
if
(
$want_alpha
and X11::Xlib->can(
'XRenderFindVisualFormat'
) and
$self
->display->XRenderQueryVersion()) {
$log
->tracef(
"Calling XRenderFindVisualFormat for %d configs"
,
scalar
@fbc_with_visual
);
my
@fbc_xrender_alpha
=
grep
{
my
$fmt
=
$self
->display->XRenderFindVisualFormat(
$_
->visual_info->visual);
$fmt
&&
$fmt
->direct_alphaMask
}
@fbc_with_visual
;
$log
->tracef(
" %d have XRender picture formats with alpha channel"
,
scalar
@fbc_xrender_alpha
);
$ret
=
$fbc_xrender_alpha
[0]
if
@fbc_xrender_alpha
;
}
$ret
||=
$fbc_with_visual
[0]
if
@fbc_with_visual
;
$ret
||=
$fbc
[0]
if
@fbc
;
defined
$ret
or croak
"No matching FBConfig available on server"
;
$log
->tracef(
'Chose GLXFBConfig %d; dbl-buf=%d %dbpp r=%d g=%d b=%d a=%d'
,
$ret
->xid,
$ret
->doublebuffer,
$ret
->buffer_size,
$ret
->red_size,
$ret
->green_size,
$ret
->blue_size,
$ret
->alpha_size)
if
$log
->is_trace;
return
$ret
;
}
sub
_build_visual_info {
my
$self
=
shift
;
if
(
$self
->glx_version_bcd >= 103 && X11::GLX->can(
'glXChooseFBConfig'
)) {
my
$vis
=
$self
->fbconfig->visual_info;
$log
->tracef(
'Using visual %d (0x%X) from FBConfig'
,
$vis
->visualid,
$vis
->visualid)
if
$log
->is_trace;
return
$vis
;
}
my
$arg
=
$self
->_visual_info_args;
$log
->tracef(
'Calling glXChooseVisual with %s options'
,
$arg
?
'custom'
:
'default'
);
my
$vis_info
= !
$arg
? X11::GLX::glXChooseVisual(
$self
->display,
$self
->screen->screen_number)
:
ref
$arg
eq
'ARRAY'
? X11::GLX::glXChooseVisual(
$self
->display,
$self
->screen->screen_number,
$arg
)
:
ref
(
$arg
)->isa(
'X11::Xlib::Visual'
)?
$self
->display->visual_info(
$arg
)
: croak
"Can't convert $arg to XVisualInfo"
;
$log
->tracef(
'Chose visual %d (0x%X)'
,
$vis_info
->visualid,
$vis_info
->visualid)
if
$log
->is_trace;
return
$vis_info
;
}
has
colormap
=> (
is
=>
'lazy'
);
sub
_build_colormap {
my
$self
=
shift
;
my
$vis
=
$self
->visual_info->visual;
$log
->tracef(
"Creating colormap for visual %s"
,
$vis
->id)
if
$log
->is_trace;
$self
->display->new_colormap(
$self
->screen->root_window,
$vis
);
}
has
_glx_context_args
=> (
is
=>
'ro'
,
init_arg
=>
'glx_context'
);
has
glx_context
=> (
is
=>
'rw'
,
init_arg
=>
undef
,
lazy
=> 1,
builder
=> 1,
clearer
=> 1,
predicate
=> 1 );
before
'clear_glx_context'
=>
sub
{
my
$self
=
shift
;
if
(
$self
->has_glx_context) {
$self
->clear_target;
$log
->trace(
'destroying old GLX context'
);
X11::GLX::glXDestroyContext(
$self
->display,
$self
->glx_context);
}
};
before
'glx_context'
=>
sub
{
if
(
@_
> 1) {
my
$self
=
$_
[0];
$_
[1] or croak
"Use clear_glx_context instead of setting a false value"
;
$self
->clear_glx_context
if
$self
->has_glx_context;
$_
[1]=
$self
->_build_glx_context(
$_
[1]);
}
};
sub
_build_glx_context {
my
(
$self
,
$args
)=
@_
;
$args
||=
$self
->_glx_context_args || {
direct
=> 1 };
return
$args
if
ref
(
$args
)->isa(
'X11::GLX::Context'
);
ref
(
$args
) eq
'HASH'
or croak
"Don't know how to use $args as a glx_context"
;
my
$direct
=
$args
->{direct};
my
$shared
=
$args
->{shared};
my
$fbc
=
$self
->fbconfig;
my
$vis
=
$self
->visual_info;
if
(!
defined
$shared
) {
$direct
= 1
unless
defined
$direct
;
}
elsif
(!
ref
$shared
||
ref
(
$shared
)->isa(
'X11::Xlib::XID'
)) {
my
$id
= !
ref
(
$shared
)?
$shared
:
$shared
->xid;
$direct
= 0
unless
defined
$direct
;
$log
->trace(
"Importing GLX context id=$id"
)
if
$log
->is_trace;
$shared
= X11::GLX::glXImportContextEXT(
$self
->display,
$id
)
or
die
"Can't import remote GLX context '$id'"
;
}
elsif
(
ref
(
$shared
)->isa(
'X11::GLX::Context'
)) {
$direct
= 0
unless
defined
$direct
;
}
else
{
croak
"Don't know how to share GLX context with $shared"
;
}
if
(
$fbc
) {
$log
->tracef(
"Calling glXCreateNewContext config=%s render_type=GLX_RGBA_TYPE shared=%s direct=%s"
,
$fbc
,
$shared
,
$direct
)
if
$log
->is_trace;
return
X11::GLX::glXCreateNewContext(
$self
->display,
$fbc
, X11::GLX::GLX_RGBA_TYPE,
$shared
,
$direct
);
}
else
{
$log
->tracef(
"Calling glXCreateContext visual=%s shared=%s direct=%s"
,
$vis
,
$shared
,
$direct
)
if
$log
->is_trace;
return
X11::GLX::glXCreateContext(
$self
->display,
$vis
,
$shared
,
$direct
);
}
}
has
_target_args
=> (
is
=>
'rw'
,
init_arg
=>
'target'
);
has
target
=> (
is
=>
'rw'
,
init_arg
=>
undef
,
clearer
=> 1,
predicate
=> 1,
reader
=>
'_get_target'
,
writer
=>
'_set_target'
);
before
clear_target
=>
sub
{
if
(
$_
[0]->has_target) {
$log
->trace(
"Un-setting GLX target with glXMakeCurrent(0, undef)"
);
X11::GLX::glXMakeCurrent(
$_
[0]->display)
or croak
"Can't un-set GLX target"
;
}
};
sub
target {
my
$self
=
shift
;
if
(
@_
|| !
$self
->has_target) {
if
(
@_
&& !
defined
$_
[0]) {
croak(
"Call clear_target instead of setting to undef"
);
}
my
$target
=
$self
->_inflate_target(
@_
?
$_
[0] :
$self
->_target_args);
if
(
$target
->isa(
'X11::Xlib::Window'
)) {
my
$evmask
=
$target
->event_mask;
my
$changed
;
unless
(
$evmask
& X11::Xlib::StructureNotifyMask) {
$changed
= 1;
$target
->event_mask(
$evmask
| X11::Xlib::StructureNotifyMask);
}
$log
->trace(
'Calling XMapWindow'
);
$target
->show;
$self
->display->wait_event(
window
=>
$target
->xid,
event_type
=> X11::Xlib::MapNotify,
timeout
=> 5,
loop
=> 1)
or
$log
->
warn
(
"didn't get MapNotify event?"
);
$target
->event_mask(
$evmask
)
if
$changed
;
}
$log
->trace(
'Calling glXMakeCurrent'
);
X11::GLX::glXMakeCurrent(
$self
->display,
$target
->xid,
$self
->glx_context)
or croak
"Can't set target to $target, glXMakeCurrent failed"
;
$self
->_set_target(
$target
);
$self
->apply_gl_projection
if
$self
->gl_projection;
}
return
$self
->_get_target;
}
sub
_inflate_target {
my
(
$self
,
$arg
)=
@_
;
$arg
||= {
window
=> 1 };
$log
->tracef(
"Creating target for %s"
,
$arg
);
return
!
ref
$arg
?
$self
->display->get_cached_xobj(
$arg
)
:
ref
(
$arg
)->isa(
'X11::Xlib::XID'
)?
$arg
:
ref
(
$arg
) eq
'HASH'
? (
$arg
->{window}?
$self
->create_render_window(
$arg
->{window})
:
$arg
->{pixmap}?
$self
->create_render_pixmap(
$arg
->{pixmap})
: croak
"Expected target->{window} or target->{pixmap}"
)
: croak
"Don't know how to set $arg as the GL rendering target"
;
}
has
gl_clear_bits
=> (
is
=>
'rw'
,
lazy
=> 1,
builder
=> 1 );
has
gl_projection
=> (
is
=>
'rw'
,
trigger
=> \
&_changed_gl_projection
);
sub
_changed_gl_projection {
my
(
$self
,
$newval
)=
@_
;
$self
->apply_gl_projection
if
$newval
&&
$self
->has_target;
}
sub
create_render_window {
my
$self
=
shift
;
my
%args
=
@_
== 1 &&
ref
(
$_
[0]) eq
'HASH'
? %{
$_
[0] }
: (1&
@_
) == 0?
@_
:
@_
== 1 &&
$_
[0] eq
'1'
? ()
: croak
"Can't construct window from ("
.
join
(',
', @_).'
)';
$args
{x} ||= 0;
$args
{y} ||= 0;
if
(!
$args
{width} || !
$args
{height}) {
$args
{width} ||=
$self
->screen->width -
$args
{x};
$args
{height} ||=
$self
->screen->height -
$args
{y};
}
$args
{class}= X11::Xlib::InputOutput
unless
defined
$args
{class};
$args
{visual} ||=
$self
->visual_info->visual;
$args
{colormap} ||=
$self
->colormap;
$args
{parent} ||=
$self
->screen->root_window;
$args
{depth} ||=
$self
->visual_info->depth;
$args
{min_width} ||=
$args
{width};
$args
{min_height} ||=
$args
{height};
$args
{border_pixel} ||= 0;
$args
{border_width} ||= 0;
$args
{background_pixmap} ||= 0;
$log
->tracef(
"create window: %s"
, {
map
{
$_
=>
"$args{$_}"
}
keys
%args
})
if
$log
->is_trace;
return
$self
->display->new_window(
%args
);
}
sub
create_render_pixmap {
my
$self
=
shift
;
my
%args
=
@_
== 1 &&
ref
(
$_
[0]) eq
'HASH'
? %{
$_
[0] } :
@_
;
$args
{width} &&
$args
{height}
or croak
"require 'width' and 'height'"
;
$args
{depth} ||=
$self
->visual_info->depth;
$log
->tracef(
"create X pixmap: %s"
, \
%args
);
my
$x_pixmap
=
$self
->display->new_pixmap(
$self
->screen,
$args
{width},
$args
{height},
$args
{depth});
$log
->tracef(
"create GLX pixmap: %s %s"
,
$self
->visual_info,
$x_pixmap
)
if
$log
->is_trace;
my
$glx_pixmap_xid
= X11::GLX::glXCreateGLXPixmap(
$self
->display,
$self
->visual_info,
$x_pixmap
);
return
$self
->display->get_cached_xobj(
$glx_pixmap_xid
,
'X11::GLX::Pixmap'
,
width
=>
$args
{width},
height
=>
$args
{height},
x_pixmap
=>
$x_pixmap
,
autofree
=> 1
);
}
sub
begin_frame {
my
$self
=
shift
;
$self
->target;
$log
->trace(
'Calling glClear'
);
X11::GLX::DWIM::_glClear(
$self
->gl_clear_bits);
}
sub
end_frame {
my
$self
=
shift
;
$log
->trace(
'Calling glXSwapBuffers'
);
X11::GLX::glXSwapBuffers(
$self
->display,
$self
->target);
X11::GLX::DWIM::_glFlush();
my
$e
=
$self
->get_gl_errors;
$log
->error(
"OpenGL error bits: "
,
join
(
', '
,
values
%$e
))
if
$e
;
return
!
$e
;
}
sub
swap_buffers {
my
$self
=
shift
;
$log
->trace(
'Calling glXSwapBuffers'
);
X11::GLX::glXSwapBuffers(
$self
->display,
$self
->target);
}
my
%_gl_err_msg
= (
map
{
eval
{ X11::GLX->can(
$_
)->() =>
$_
} }
qw(
GL_INVALID_ENUM
GL_INVALID_VALUE
GL_INVALID_OPERATION
GL_INVALID_FRAMEBUFFER_OPERATION
GL_OUT_OF_MEMORY
GL_STACK_OVERFLOW
GL_STACK_UNDERFLOW
GL_TABLE_TOO_LARGE
)
);
sub
get_gl_errors {
my
$self
=
shift
;
$self
->display->flush_sync;
my
(
%errors
,
$e
);
$errors
{
$e
}=
$_gl_err_msg
{
$e
} ||
"(unrecognized) "
.
$e
while
((
$e
= X11::GLX::DWIM::_glGetError()));
return
(
keys
%errors
)? \
%errors
:
undef
;
}
sub
apply_gl_projection {
my
$self
=
shift
;
my
%args
= !
@_
? %{
$self
->gl_projection || {} }
:
@_
== 1 &&
ref
(
$_
[0]) eq
'HASH'
? %{
$_
[0] }
:
@_
;
my
(
$ortho
,
$l
,
$r
,
$t
,
$b
,
$near
,
$far
,
$x
,
$y
,
$z
,
$aspect
,
$mirror_x
,
$mirror_y
)
=
delete
@args
{
qw/ ortho left right top bottom near far x y z aspect mirror_x mirror_y /
};
croak
"Unexpected arguments to apply_gl_projection"
if
keys
%args
;
my
$have_w
=
defined
$l
&&
defined
$r
;
my
$have_h
=
defined
$t
&&
defined
$b
;
unless
(
$have_h
&&
$have_w
) {
if
(!
$aspect
or
$aspect
eq
'auto'
) {
my
(
$w
,
$h
)=
$self
->target->get_w_h;
my
$screen
=
$self
->screen;
$aspect
= (
$screen
->width_mm /
$screen
->width *
$w
)
/ (
$screen
->height_mm /
$screen
->height *
$h
);
}
if
(!
$have_w
) {
if
(!
$have_h
) {
$t
= (
defined
$b
? -
$b
: 1)
unless
defined
$t
;
$b
= -
$t
unless
defined
$b
;
}
my
$w
= (
$t
-
$b
) *
$aspect
;
$r
= (
defined
$l
?
$l
+
$w
:
$w
/ 2)
unless
defined
$r
;
$l
=
$r
-
$w
unless
defined
$l
;
}
else
{
my
$h
= (
$r
-
$l
) /
$aspect
;
$t
= (
defined
$b
?
$b
+
$h
:
$h
/ 2)
unless
defined
$t
;
$b
=
$t
-
$h
unless
defined
$b
;
}
}
(
$l
,
$r
)= (
$r
,
$l
)
if
$mirror_x
;
(
$t
,
$b
)= (
$b
,
$t
)
if
$mirror_y
;
$near
= 1
unless
defined
$near
;
$far
= 1000
unless
defined
$far
;
defined
$_
or
$_
= 0
for
(
$x
,
$y
,
$z
);
if
(
$z
&& !
$ortho
) {
my
$scale
= 1.0/
$z
;
$l
*=
$scale
;
$r
*=
$scale
;
$t
*=
$scale
;
$b
*=
$scale
;
}
$log
->tracef(
'Setting projection matrix: l=%.4lf r=%.4lf b=%.4lf t=%.4lf near=%.4lf far=%.4lf; translate %.4lf,%.4lf,%.4lf'
,
$l
,
$r
,
$b
,
$t
,
$near
,
$far
, -
$x
, -
$y
, -
$z
);
X11::GLX::DWIM::_set_projection_matrix(
$ortho
? 0 : 1,
$l
,
$r
,
$b
,
$t
,
$near
,
$far
,
$x
,
$y
,
$z
,
$mirror_x
? 1: 0,
$mirror_y
? 1 : 0
);
}
sub
DESTROY {
my
$self
=
shift
;
$self
->clear_target;
$self
->clear_glx_context;
}
1;