use
Carp
qw(cluck carp confess)
;
use
constant
STANDARD_COMPLIANT_BUT_EVEN_SLOWER
=> 0;
use
constant
DEFAULT_BLINK_DELAY
=> 1000;
@Games::Rezrov::ZIO_Tk::ISA
=
qw(
Games::Rezrov::ZIO_Generic
Games::Rezrov::ZIO_Color
)
;
dumb_fonts
font_cache
font_size
line_height
fixed_font_width
current_font
cursor_id
cursor_x
cursor_status
blink_id
zfont
last_text_id
variable_font_family
)
;
my
(
$w_main
,
$c
,
$status_line
,
$upper_lines
);
my
(
$abs_x
,
$abs_row
,
$abs_col
,
$rows
,
@widgets
);
my
$Y_BORDER
;
my
$initialized
;
sub
new {
my
(
$type
,
%options
) =
@_
;
my
$self
= new Games::Rezrov::ZIO_Generic(
%options
);
bless
$self
,
$type
;
$self
->font_cache({});
$self
->zfont(Games::Rezrov::ZConst::FONT_NORMAL);
$abs_row
=0;
return
$self
;
}
sub
set_version {
my
(
$self
,
$need_status
,
$init_sub
) =
@_
;
$w_main
= MainWindow->new();
$w_main
->title(
"rezrov"
);
$w_main
->
bind
(
'<Configure>'
=> [
$self
=>
'set_geometry'
]);
$w_main
->
bind
(
'<Control-c>'
=> [
$self
=>
'cleanup'
]);
my
$is_win32
= ($^O =~ /mswin32/i) ? 1 : 0;
my
(
$DEFAULT_VARIABLE_FAMILY
,
$DEFAULT_FONT_SIZE
);
if
(
$is_win32
) {
$DEFAULT_VARIABLE_FAMILY
=
"times new roman"
;
$DEFAULT_FONT_SIZE
= 14;
}
else
{
$DEFAULT_VARIABLE_FAMILY
=
"times"
;
$DEFAULT_FONT_SIZE
= 18;
}
my
$options
=
$self
->zio_options();
my
$vff
=
lc
(
$options
->{
"family"
} ||
$DEFAULT_VARIABLE_FAMILY
);
unless
(
grep
{
lc
(
$_
) eq
$vff
}
$w_main
->fontFamilies()) {
$self
->fatal_error(
sprintf
"Invalid font family \"%s\"; available families are:\n %s\n"
,
$vff
,
join
"\n "
, column_list([
sort
$w_main
->fontFamilies()]));
}
$self
->variable_font_family(
$vff
);
$self
->font_size(
$options
->{
"fontsize"
} ||
$DEFAULT_FONT_SIZE
);
$self
->parse_color_options(
$options
);
my
$f_variable
=
$self
->set_text_style(Games::Rezrov::ZConst::STYLE_ROMAN);
my
$f_fixed
=
$self
->set_text_style(Games::Rezrov::ZConst::STYLE_FIXED);
$self
->set_text_style(Games::Rezrov::ZConst::STYLE_ROMAN);
die
"Couldn't init fixed font!"
unless
$f_fixed
;
die
"Couldn't init variable font!"
unless
$f_variable
;
my
$font_width
=
$w_main
->fontMeasure(
$f_fixed
,
"X"
);
my
$line_height
=
$self
->biggest_metric(
$f_fixed
,
$f_variable
,
"-linespace"
);
$line_height
+=
$options
->{
"fontspace"
}
if
exists
$options
->{
"fontspace"
};
my
$canvas_x
=
$options
->{
"x"
} ||
int
(
$w_main
->screenwidth * 0.7);
my
$canvas_y
;
if
(
$options
->{
"y"
}) {
$canvas_y
=
$options
->{
"y"
};
}
else
{
my
$y
=
int
(
$w_main
->screenheight * 0.6);
my
$rows
=
int
(
$y
/
$line_height
);
$canvas_y
=
$rows
*
$line_height
;
}
$c
=
$w_main
->Canvas(
"-width"
=>
$canvas_x
,
"-height"
=>
$canvas_y
,
"-bg"
=>
$self
->default_bg(),
"-takefocus"
=> 1,
"-highlightthickness"
=> 0,
);
if
(
$need_status
) {
$status_line
=
$w_main
->Canvas(
"-borderwidth"
=> 0,
"-relief"
=>
"flat"
,
"-width"
=>
$canvas_x
,
"-height"
=>
$line_height
,
"-bg"
=>
$self
->sbg(),
"-takefocus"
=> 0,
);
$status_line
->
pack
(
"-anchor"
=>
"n"
,
"-fill"
=>
"x"
);
}
$self
->line_height(
$line_height
);
$Y_BORDER
=
$line_height
/ 2;
$self
->fixed_font_width(
$font_width
);
$self
->set_geometry();
$abs_x
= X_BORDER;
$abs_col
= 0;
$abs_row
=
int
(
$canvas_y
/
$line_height
);
$c
->
pack
(
"-anchor"
=>
"s"
,
"-expand"
=> 1,
"-fill"
=>
"both"
);
$w_main
->
after
(0,
$init_sub
);
$initialized
= 1;
MainLoop;
return
1;
}
sub
update {
$c
->update();
}
sub
fatal_error {
if
(
$initialized
) {
$_
[0]->SUPER::fatal_error(
$_
[1]);
}
else
{
die
$_
[1];
}
}
sub
fixed_font_default {
return
0;
}
sub
manual_status_line {
return
1;
}
sub
create_text {
my
(
$self
,
$widget
,
@args
) =
@_
;
push
@args
, (
"-font"
=>
$self
->current_font())
if
$self
->current_font();
return
$self
->last_text_id(
$widget
->create(
"text"
,
@args
));
}
sub
write_string {
my
(
$self
,
$string
,
$x
,
$y
) =
@_
;
$self
->absolute_move(
$x
,
$y
)
if
defined
(
$x
) and
defined
(
$y
);
my
$abs_y
=
$self
->get_y();
my
$is_f3
;
if
(
$self
->zfont() == 3) {
$self
->fatal_error(
"long buf in write_string w/font 3 on"
)
if
length
(
$string
) > 1;
$is_f3
= 1;
}
foreach
my
$list
(
@widgets
) {
my
$line
=
$list
->[
$abs_row
];
my
$after
=
$abs_col
+
length
(
$string
);
for
(
my
$col
=
$abs_col
;
$col
<
$after
;
$col
++) {
if
(
exists
$line
->{
$col
}) {
foreach
(@{
$line
->{
$col
}}) {
$c
->
delete
(
$_
);
}
delete
$line
->{
$col
};
}
}
}
my
$is_reverse
= Games::Rezrov::StoryFile::font_mask() & Games::Rezrov::ZConst::STYLE_REVERSE;
my
$id
;
if
(
$is_f3
) {
print
STDERR
"reverse f3 char!\n"
if
$is_reverse
;
if
(
my
$vec_list
=
$Games::Rezrov::FontVectors::vecs
{
ord
(
$string
)}) {
my
(
$x1
,
$y1
);
my
$x_mult
=
$self
->fixed_font_width() / 7;
my
$y_mult
=
$self
->line_height() / 7;
my
$si
;
foreach
my
$list
(@{
$vec_list
}) {
next
unless
@{
$list
};
my
@mapped
;
my
(
$is_rect
,
$is_poly
);
if
(
$list
->[0] eq
"R"
) {
$si
= 1;
$is_rect
= 1;
}
elsif
(
$list
->[0] eq
"P"
) {
$si
= 1;
$is_poly
= 1;
}
else
{
$si
= 0;
}
while
(
$si
< @{
$list
}) {
(
$x1
,
$y1
) = @{
$list
}[
$si
,
$si
+1];
$si
+= 2;
push
@mapped
, (
$abs_x
+ ((8 -
$x1
) *
$x_mult
),
$abs_y
+ ((
$y1
- 4) *
$y_mult
));
}
if
(
$is_rect
) {
$id
=
$c
->create(
"rectangle"
,
@mapped
,
"-fill"
=>
$self
->fg(),
"-outline"
=>
undef
,
);
}
elsif
(
$is_poly
) {
$id
=
$c
->create(
"polygon"
,
@mapped
,
"-fill"
=>
$self
->fg(),
"-outline"
=>
undef
,
);
}
else
{
$id
=
$c
->create(
"line"
,
@mapped
,
"-fill"
=>
$self
->fg());
}
$self
->track_widget(
$id
);
}
}
else
{
printf
STDERR
"Unhandled font 3 char %d (%s)\n"
,
ord
(
$string
),
$string
;
$id
=
$self
->create_text(
$c
,
$abs_x
,
$abs_y
,
"-anchor"
=> TEXT_ANCHOR,
"-text"
=>
"*"
,
"-fill"
=>
$self
->fg());
}
$abs_x
+=
$self
->fixed_font_width();
$abs_col
++;
}
else
{
$id
=
$self
->create_text(
$c
,
$abs_x
,
$abs_y
,
"-anchor"
=> TEXT_ANCHOR,
"-text"
=>
$string
,
"-fill"
=>
$is_reverse
?
$self
->bg() :
$self
->fg());
$self
->track_widget(
$id
);
my
$sw
=
$self
->string_width(
$string
);
$self
->create_reverse(
$id
,
$sw
+ X_BORDER,
$is_reverse
)
if
$is_reverse
or
$self
->bg() ne
$self
->default_bg();
$abs_x
+=
$sw
;
$abs_col
+=
length
(
$string
);
}
}
sub
create_reverse {
my
(
$self
,
$text_id
,
$width
,
$is_reverse
) =
@_
;
unless
(
defined
$text_id
) {
$width
=
$self
->get_width() -
$abs_x
;
$is_reverse
= 0;
}
my
$abs_y
=
$self
->get_y();
my
$top
=
$abs_y
;
my
$bottom
=
$abs_y
+
$self
->line_height();
my
$lh2
=
$self
->line_height() / 2;
$top
=
$abs_y
-
$lh2
;
$bottom
=
$abs_y
+
$lh2
;
my
$id
=
$c
->create(
"polygon"
,
$abs_x
,
$top
,
$abs_x
+
$width
,
$top
,
$abs_x
+
$width
,
$bottom
,
$abs_x
,
$bottom
,
"-fill"
=>
$is_reverse
?
$self
->fg() :
$self
->bg(),
);
$c
->lower(
$id
);
$self
->track_widget(
$id
);
$c
->lower(
$id
,
$text_id
)
if
defined
$text_id
;
}
sub
string_width {
my
$cf
=
$_
[0]->current_font();
if
(
$cf
) {
return
$w_main
->fontMeasure(
$cf
,
$_
[1]);
}
else
{
my
$id
=
$c
->create(
"text"
, 0,0,
"-text"
=>
$_
[1]);
my
(
$x1
,
$y1
,
$x2
,
$y2
) =
$c
->bbox(
$id
);
$c
->
delete
(
$id
);
printf
STDERR
"eek! %d\n"
,
$x2
-
$x1
;
return
(
$x2
-
$x1
);
}
}
sub
newline {
Games::Rezrov::StoryFile::flush();
if
(
$_
[0]->bg() ne
$_
[0]->default_bg()) {
print
"newline fill\n"
;
$_
[0]->create_reverse();
}
my
$line_height
=
$_
[0]->line_height();
$abs_x
= X_BORDER;
$abs_row
++;
$abs_col
= 0;
if
(
$abs_row
>=
$rows
) {
my
(
$id
,
$line
,
$ref
);
for
(
my
$win
= 0;
$win
<
@widgets
;
$win
++) {
die
"eek, unknown window $win"
if
$win
!= Games::Rezrov::ZConst::LOWER_WIN and
$win
!= Games::Rezrov::ZConst::UPPER_WIN;
my
$is_lower
=
$win
== Games::Rezrov::ZConst::LOWER_WIN;
my
$ref
=
$widgets
[
$win
];
my
@goner_rows
;
for
(
my
$line
=0;
$line
< $
if
(
$is_lower
) {
if
(
$line
<=
$upper_lines
) {
push
@goner_rows
,
$ref
->[
$line
];
}
}
else
{
next
if
(
$line
<
$upper_lines
);
@goner_rows
=
$ref
->[
$line
]
if
$line
==
$upper_lines
;
}
$ref
->[
$line
] =
$ref
->[
$line
+ 1];
foreach
(
values
%{
$ref
->[
$line
]}) {
foreach
(@{
$_
}) {
$c
->move(
$_
, 0, -
$line_height
);
if
(0 and
$c
->type(
$_
) eq
"text"
) {
printf
"now line %d (upr=%d): %s\n"
,
$line
,
$upper_lines
,
$c
->itemcget(
$_
,
"-text"
);
}
}
}
}
$ref
->[$
foreach
(
@goner_rows
) {
foreach
(
values
%{
$_
}) {
$c
->
delete
(
$_
)
foreach
@{
$_
};
}
}
}
$abs_row
--;
}
Games::Rezrov::StoryFile::register_newline();
$c
->update()
if
Games::Rezrov::ZOptions::MAXIMUM_SCROLLING();
}
sub
write_zchar {
if
(STANDARD_COMPLIANT_BUT_EVEN_SLOWER or
$_
[0]->zfont == 3) {
$_
[0]->write_string(
chr
(
$_
[1]));
}
else
{
$_
[0]->SUPER::buffer_zchar(
$_
[1]);
}
}
sub
absolute_move {
my
(
$self
,
$col
,
$row
) =
@_
;
Games::Rezrov::StoryFile::flush();
$abs_x
= X_BORDER + (
$col
*
$self
->fixed_font_width());
$abs_row
=
$row
;
$abs_col
=
$col
;
}
sub
get_pixel_position {
return
(
$abs_x
,
$_
[0]->get_y());
}
sub
get_pixel_geometry {
return
(get_width() - X_BORDER, get_height());
}
sub
get_position {
my
(
$self
,
$sub
) =
@_
;
my
(
$x
,
$r
,
$c
) = (
$abs_x
,
$abs_row
,
$abs_col
);
if
(
$sub
) {
return
sub
{
$abs_x
=
$x
;
$abs_row
=
$r
;
$abs_col
=
$c
;
};
}
else
{
return
(
$abs_col
,
$abs_row
);
}
}
sub
status_hook {
my
(
$self
,
$location
,
$right_chunk
) =
@_
;
my
$y
=
$status_line
->height() / 2;
$status_line
->
delete
(
$status_line
->find(
"all"
));
my
$id
=
$self
->create_text(
$status_line
,
X_BORDER,
$y
,
"-anchor"
=>
"w"
,
"-text"
=>
$location
,
"-fill"
=>
$self
->sfg());
$id
=
$self
->create_text(
$status_line
,
200,
$y
,
"-anchor"
=>
"e"
,
"-text"
=>
$right_chunk
,
"-fill"
=>
$self
->sfg());
my
(
$x1
,
$y1
,
$x2
,
$y2
) =
$status_line
->bbox(
$id
);
$status_line
->move(
$id
,
$c
->width() - X_BORDER -
$x2
, 0);
}
sub
cursor_on {
my
(
$self
,
$x
) =
@_
;
$self
->cursor_x(
$x
);
$self
->cursor_status(1);
$self
->draw_cursor();
$self
->blink_init();
}
sub
draw_cursor {
my
(
$self
) =
@_
;
my
$x
=
$self
->cursor_x();
return
unless
$x
;
$self
->cursor_off();
if
(
$self
->cursor_status()) {
my
$lh2
=
$self
->line_height() / 2;
my
$abs_y
=
$self
->get_y();
my
$top
=
$abs_y
-
$lh2
;
my
$bottom
=
$abs_y
+
$lh2
;
my
$cx
=
$self
->fixed_font_width() * 0.7;
my
$id
=
$c
->create(
"polygon"
,
$x
,
$top
,
$x
+
$cx
,
$top
,
$x
+
$cx
,
$bottom
,
$x
,
$bottom
,
"-fill"
=>
$self
->cc());
$self
->cursor_id(
$id
);
}
}
sub
cursor_off {
$c
->
delete
(
$_
[0]->cursor_id())
if
$_
[0]->cursor_id();
}
sub
get_input {
my
(
$self
,
$max
,
$single_char
,
%options
) =
@_
;
my
$buffer
=
""
;
my
$last_id
;
if
(
$self
->listening) {
$self
->update();
$buffer
=
$self
->recognize_line();
$self
->write_string(
$buffer
);
$self
->newline();
return
$buffer
;
}
if
(
$options
{
"-preloaded"
}) {
my
$pre
=
$options
{
"-preloaded"
};
my
$last
=
$self
->last_text_id();
my
$last_text
=
$c
->itemcget(
$last
,
"-text"
);
if
(
$last_text
=~ /
$pre
$/) {
$last_text
=~ s/
$pre
$//;
$c
->itemconfigure(
$last
,
"-text"
=>
$last_text
);
my
$width
=
$self
->string_width(
$pre
);
$last_id
=
$self
->create_text(
$c
,
$abs_x
-
$width
,
$self
->get_y(),
"-anchor"
=> TEXT_ANCHOR,
"-text"
=>
$pre
,
"-fill"
=>
$self
->fg(),
);
$self
->track_widget(
$last_id
);
$buffer
=
$pre
;
$self
->cursor_on(
$abs_x
);
$abs_x
-=
$width
;
}
else
{
print
STDERR
"miserable preload failure in get_input...\n"
;
}
}
else
{
$self
->cursor_on(
$abs_x
);
}
my
$done
= 0;
my
$callback
=
sub
{
my
$key
;
my
$supplied
;
if
(
ref
$_
[0]) {
if
(
$_
[1]) {
$supplied
= 1;
$key
=
$_
[1];
}
else
{
$key
=
ord
(
$w_main
->XEvent()->A());
}
}
else
{
$key
=
$_
[0];
$supplied
= 1;
}
$w_main
->break()
if
$key
== 9;
if
(
$key
== Games::Rezrov::ZConst::ASCII_CR or
$key
== Games::Rezrov::ZConst::ASCII_LF) {
$done
= 1;
$self
->cursor_off();
if
(
$single_char
) {
$buffer
=
chr
(Games::Rezrov::ZConst::Z_NEWLINE);
}
else
{
$self
->newline();
}
return
;
}
elsif
(
$key
== Games::Rezrov::ZConst::ASCII_DEL or
$key
== Games::Rezrov::ZConst::ASCII_BS) {
if
(
$single_char
) {
$done
= 1;
$buffer
=
chr
(Games::Rezrov::ZConst::Z_DELETE);
}
else
{
$buffer
=
substr
(
$buffer
, 0,
length
(
$buffer
) - 1)
if
length
$buffer
;
}
}
elsif
(
$supplied
or (
$key
>= 32 and
$key
<= 126)) {
$buffer
.=
chr
(
$key
);
}
else
{
printf
STDERR
"unhandled key code %d (%s)\n"
,
$key
,
chr
(
$key
)
if
$key
;
}
if
(
$single_char
) {
$done
= 1;
}
else
{
my
$cwin
=
$self
->current_window();
if
(
$last_id
) {
$c
->
delete
(
$last_id
);
}
$self
->cursor_off();
$last_id
=
$self
->create_text(
$c
,
$abs_x
,
$self
->get_y(),
"-anchor"
=> TEXT_ANCHOR,
"-text"
=>
$buffer
,
"-fill"
=>
$self
->fg());
$self
->track_widget(
$last_id
);
my
(
$x1
,
$y1
,
$x2
,
$y2
) =
$c
->bbox(
$last_id
);
$self
->cursor_on(
$x2
);
$c
->update();
}
};
$self
->bind_keys_to(
$callback
);
while
(
$done
== 0) {
$c
->
after
(10);
$c
->update();
}
$self
->cursor_off();
$self
->blink_init(1);
$self
->bind_keys_to(
sub
{});
return
$buffer
;
}
sub
bind_keys_to {
my
(
$self
,
$callback
) =
@_
;
$w_main
->
bind
(
"<Any-KeyPress>"
=>
$callback
);
$w_main
->
bind
(
"<Any-Down>"
=> [
$callback
=> Games::Rezrov::ZConst::Z_DOWN ]);
$w_main
->
bind
(
"<Any-Up>"
=> [
$callback
=> Games::Rezrov::ZConst::Z_UP ]);
$w_main
->
bind
(
"<Any-Left>"
=> [
$callback
=> Games::Rezrov::ZConst::Z_LEFT ]);
$w_main
->
bind
(
"<Any-Right>"
=> [
$callback
=> Games::Rezrov::ZConst::Z_RIGHT ]);
}
sub
clear_to_eol {
foreach
my
$list
(
@widgets
) {
while
(
my
(
$column
,
$ids
) =
each
%{
$list
->[
$abs_row
]}) {
if
(
$column
>=
$abs_col
) {
$c
->
delete
(
$_
)
foreach
(@{
$ids
});
delete
$list
->[
$abs_row
]->{
$column
};
}
}
}
}
sub
set_background_color {
$c
->configure(
"-bg"
=>
$_
[0]->bg());
}
sub
clear_screen {
$c
->
delete
(
$c
->find(
"all"
));
@widgets
= ();
widget_setup();
}
sub
widget_setup {
for
(
my
$win
=0;
$win
< 2;
$win
++) {
$widgets
[
$win
] = []
unless
defined
$widgets
[
$win
];
my
$ref
=
$widgets
[
$win
];
for
(
my
$row
= 0;
$row
<=
$rows
;
$row
++) {
$ref
->[
$row
] = {}
unless
defined
$ref
->[
$row
];
}
}
}
sub
set_text_style {
my
(
$self
,
$mask
) =
@_
;
if
(
$self
->dumb_fonts()) {
return
$self
->current_font(
""
);
}
else
{
my
$family
= (
$mask
& Games::Rezrov::ZConst::STYLE_FIXED) ?
FIXED_FAMILY :
$self
->variable_font_family();
my
$weight
= (
$mask
& Games::Rezrov::ZConst::STYLE_BOLD) ?
"bold"
:
"normal"
;
my
$slant
= (
$mask
& Games::Rezrov::ZConst::STYLE_ITALIC) ?
"italic"
:
"roman"
;
my
$key
=
$family
.
"_"
.
$weight
.
"_"
.
$slant
;
my
$fc
=
$self
->font_cache();
my
$font
;
unless
(
$font
=
$fc
->{
$key
}) {
$font
=
$w_main
->fontCreate(
"-family"
=>
$family
,
"-weight"
=>
$weight
,
"-slant"
=>
$slant
,
"-size"
=>
$self
->font_size());
$fc
->{
$key
} =
$font
;
}
$self
->current_font(
$font
);
return
$font
;
}
}
sub
groks_font_3 {
return
1;
}
sub
can_change_title {
return
1;
}
sub
can_use_color {
return
1;
}
sub
set_game_title {
$w_main
->title(
$_
[1]);
}
sub
cleanup {
$w_main
->destroy()
if
$w_main
;
Tk::
exit
();
}
sub
validate_family {
my
(
$self
,
$family
) =
@_
;
my
%families
=
map
{
lc
(
$_
) => 1}
$w_main
->fontFamilies();
if
(
exists
(
$families
{
lc
(
$family
)})) {
return
$family
;
}
else
{
die
sprintf
"%s is not a valid font family on your system. Valid families are: %s\n"
,
$family
,
join
", "
,
sort
keys
%families
;
}
}
sub
blink_init {
my
(
$self
,
$cancel
) =
@_
;
$w_main
->afterCancel(
$self
->blink_id())
if
$self
->blink_id();
unless
(
$cancel
) {
my
$blink_delay
=
exists
$self
->zio_options()->{
"blink"
} ?
$self
->zio_options()->{
"blink"
} : DEFAULT_BLINK_DELAY;
if
(
$blink_delay
) {
$self
->blink_id(
$w_main
->repeat(
$blink_delay
, [
$self
=>
'cursor_blinker'
]));
}
}
}
sub
cursor_blinker {
my
(
$self
) =
@_
;
$self
->cursor_status(!
$self
->cursor_status());
$self
->draw_cursor();
}
sub
split_window {
$upper_lines
=
$_
[1];
}
sub
get_height {
return
$c
->height() == 1 ?
$c
->reqheight() :
$c
->height();
}
sub
get_width {
return
$c
->width() == 1 ?
$c
->reqwidth() :
$c
->width();
}
sub
set_geometry {
my
$self
=
shift
;
my
(
$cx
,
$cy
) =
$self
->get_pixel_geometry();
my
$lh
=
$self
->line_height();
my
$old_y
=
$self
->get_y();
my
$old_rows
=
$rows
;
$rows
=
int
(
$cy
/
$lh
);
widget_setup();
my
$columns
=
int
(
$cx
/
$self
->fixed_font_width());
Games::Rezrov::StoryFile::rows(
$rows
);
Games::Rezrov::StoryFile::columns(
$columns
);
if
(
$abs_row
>=
$rows
) {
my
(
$save_col
,
$save_x
) = (
$abs_col
,
$abs_x
);
$self
->newline
for
$rows
..
$old_rows
- 1;
(
$abs_col
,
$abs_x
,
$abs_row
) = (
$save_col
,
$save_x
,
$rows
- 1);
}
}
sub
biggest_metric {
my
(
$self
,
$f1
,
$f2
,
$metric
) =
@_
;
my
$v1
=
$w_main
->fontMetrics(
$f1
,
$metric
);
my
$v2
=
$w_main
->fontMetrics(
$f2
,
$metric
);
return
$v1
>
$v2
?
$v1
:
$v2
;
}
sub
set_font {
return
$_
[0]->zfont(
$_
[1]);
}
sub
track_widget {
push
@{
$widgets
[
$_
[0]->current_window()][
$abs_row
]->{
$abs_col
}},
$_
[1];
}
sub
column_list {
my
(
$list
,
%options
) =
@_
;
my
$longest
= 0;
foreach
(@{
$list
}) {
my
$len
=
length
(
$_
);
$longest
=
$len
if
$len
>
$longest
;
}
$longest
+= 2;
my
$columns
= 75 /
$longest
;
my
$format
= (
"%-"
.
$longest
.
"s"
) x
$columns
;
my
@results
;
my
@list
= @{
$list
};
while
(
@list
) {
push
@results
,
sprintf
$format
,
splice
(
@list
,0,
$columns
);
}
return
@results
;
}
sub
get_y {
return
$Y_BORDER
+ (
$abs_row
*
$_
[0]->line_height());
}
sub
i_am_too_dumb_to_figure_this_out {
my
$msg
=
"I hate the tab key in Tk"
;
if
(1) {
*Tk::Error
=
sub
{};
die
$msg
;
}
else
{
unless
(
$Games::Rezrov::ZIO_Tk::ORIG_TK_HANDLER
) {
$Games::Rezrov::ZIO_Tk::ORIG_TK_HANDLER
= \
&Tk::Error
;
}
my
$restore_sub
=
sub
{
no
warnings;
*Tk::Error
=
$Games::Rezrov::ZIO_Tk::ORIG_TK_HANDLER
;
$w_main
->
bind
(
"<Bogus>"
=>
sub
{});
};
$w_main
->
after
(100,
$restore_sub
);
*Tk::Error
=
sub
{};
die
$msg
;
}
}
1;