deliantra/Deliantra-Client/DC.pm

=head1 NAME

CFClient - undocumented utility garbage for our crossfire client

=head1 SYNOPSIS

 use CFClient;

=head1 DESCRIPTION

=over 4

=cut

package CFClient;

BEGIN {
   $VERSION = '0.1';

   use XSLoader;
   XSLoader::load "CFClient", $VERSION;
}

use utf8;

use Carp ();
use AnyEvent ();
use BerkeleyDB;

sub find_rcfile($) {
   my $path;

   for (grep !ref, @INC) {
      $path = "$_/CFClient/resources/$_[0]";
      return $path if -r $path;
   }

   die "FATAL: can't find required file $_[0]\n";
}

sub read_cfg {
   my ($file) = @_;

   open CFG, $file
      or return;

   my $CFG;

   local $/;
   $CFG = eval <CFG>;

   $::CFG = $CFG;

   close CFG;
}

sub write_cfg {
   my ($file) = @_;

   open CFG, ">$file"
      or return;

   {
      require Data::Dumper;
      local $Data::Dumper::Purity = 1;
      $::CFG->{VERSION} = $::VERSION;
      print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
   }

   close CFG;
}

mkdir "$Crossfire::VARDIR/cfplus", 0777;

our $DB_ENV;

{
   use strict;

   my $recover = $BerkeleyDB::db_version >= 4.4 
                 ? eval "DB_REGISTER | DB_RECOVER"
                 : 0;

   $DB_ENV = new BerkeleyDB::Env
                    -Home => "$Crossfire::VARDIR/cfplus",
                    -Cachesize => 1_000_000,
                    -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
#                 -ErrPrefix => "DATABASE",
                    -Verbose => 1,
                    -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover,
                    -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE,
                       or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
}

sub db_table($) {
   my ($table) = @_;

   $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;

   new CFClient::Database
      -Env      => $DB_ENV,
      -Filename => $table,
#      -Filename => "database",
#      -Subname  => $table,
      -Property => DB_CHKSUM,
      -Flags    => DB_CREATE | DB_UPGRADE,
         or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
}

sub pod_to_pango($) {
   my ($pom) = @_;

   $pom->present ("CFClient::PodToPango")
}

sub pod_to_pango_list($) {
   my ($pom) = @_;

   [
      map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "],
         split /\n/, $pom->present ("CFClient::PodToPango")
   ]
}

package CFClient::PodToPango;

use base Pod::POM::View::Text;

our $indent = 0;

*view_seq_code   =
*view_seq_bold   = sub { "<b>$_[1]</b>" };
*view_seq_italic = sub { "<i>$_[1]</i>" };
*view_seq_space  =
*view_seq_link   =
*view_seq_index  = sub { CFClient::UI::Label::escape ($_[1]) };

sub view_seq_text {
   my $text = $_[1];
   $text =~ s/\s+/ /g;
   CFClient::UI::Label::escape ($text)
}

sub view_item {
   ("\t" x ($indent / 4))
   . $_[1]->title->present ($_[0])
   . "\n"
   . $_[1]->content->present ($_[0])
}

sub view_verbatim {
   (join "",
       map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
          split /\n/, CFClient::UI::Label::escape ($_[1]))
   . "\n"
}

sub view_textblock {
   ("\t" x ($indent / 2)) . "$_[1]\n\n"
}

sub view_head1 {
   "\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
   . $_[1]->content->present ($_[0])
};

sub view_head2 {
   "\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
   . $_[1]->content->present ($_[0])
};

sub view_head3 {
   "\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
   . $_[1]->content->present ($_[0])
};

sub view_over {
   local $indent = $indent + $_[1]->indent;
   $_[1]->content->present ($_[0])
}

package CFClient::Database;

our @ISA = BerkeleyDB::Btree::;

sub get($$) {
   my $data;

   $_[0]->db_get ($_[1], $data) == 0
      ? $data
      : ()
}

my %DB_SYNC;

sub put($$$) {
   my ($db, $key, $data) = @_;

   $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });

   $db->db_put ($key => $data)
}

package CFClient::Item;

use strict;
use Crossfire::Protocol::Constants;

sub desc_string {
   my ($self) = @_;

   my $desc =
      $self->{nrof} < 2
         ? $self->{name}
         : "$self->{nrof} × $self->{name_pl}";

   $self->{flags} & F_OPEN
      and $desc .= " (open)";
   $self->{flags} & F_APPLIED
      and $desc .= " (applied)";
   $self->{flags} & F_UNPAID
      and $desc .= " (unpaid)";
   $self->{flags} & F_MAGIC
      and $desc .= " (magic)";
   $self->{flags} & F_CURSED
      and $desc .= " (cursed)";
   $self->{flags} & F_DAMNED
      and $desc .= " (damned)";
   $self->{flags} & F_LOCKED
      and $desc .= " *";

   $desc
}

sub weight_string {
   my ($self) = @_;

   my $weight = ($self->{nrof} || 1) * $self->{weight};

   $weight < 0 ? "?" : $weight * 0.001
}

sub update_widgets {
   my ($self) = @_;

   my $button_cb = sub {
      my (undef, $ev, $x, $y) = @_;

      if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
         my $targ = $::CONN->{player}{tag};

         if ($self->{container} == $::CONN->{player}{tag}) {
            $targ = $::CONN->{open_container};
         }

         $::CONN->send ("move $targ $self->{tag} 0");
      } elsif ($ev->{button} == 1) {
         $::CONN->send ("examine $self->{tag}");
      } elsif ($ev->{button} == 2) {
         $::CONN->send ("apply $self->{tag}");
      } elsif ($ev->{button} == 3) {
         my @menu_items = (
            ["examine", sub { $::CONN->send ("examine $self->{tag}") }],
            ["mark",    sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
            ["apply",   sub { $::CONN->send ("apply $self->{tag}") }],
            (
               $self->{flags} & F_LOCKED
               ? (
                  ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
                 )
               : (
                  ["lock",   sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
                  ["drop",   sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
               )
            ),
         );

         CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
      }

      1
   };

   my $tooltip_std = "<small>"
                   . "Left click - examine item\n"
                   . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
                   . "Middle click - apply\n"
                   . "Right click - further options"
                   . "</small>\n";

   $self->{face_widget} ||= new CFClient::UI::Face 
      can_events => 1,
      can_hover  => 1,
      anim       => $self->{anim},
      animspeed  => $self->{animspeed}, # TODO# must be set at creation time
      on_button_down => $button_cb,
   ;
   $self->{face_widget}{face}      = $self->{face};
   $self->{face_widget}{anim}      = $self->{anim};
   $self->{face_widget}{animspeed} = $self->{animspeed};
   $self->{face_widget}->set_tooltip (
      "<b>Face/Animation.</b>\n"
    . "Item uses face #$self->{face}. "
    . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
    . "\n\n$tooltip_std"
   );
   
   $self->{desc_widget} ||= new CFClient::UI::Label
      can_events => 1,
      can_hover  => 1,
      ellipsise  => 2,
      align      => -1,
      on_button_down => $button_cb,
   ;
   my $desc = CFClient::Item::desc_string $self;
   $self->{desc_widget}->set_text ($desc);
   $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");

   $self->{weight_widget} ||= new CFClient::UI::Label
      can_events => 1,
      can_hover  => 1,
      ellipsise  => 0,
      align      => 0,
      on_button_down => $button_cb,
   ;
   $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);

   $self->{weight_widget}->set_tooltip (
      "<b>Weight</b>.\n"
    . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
    . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
    . "\n\n$tooltip_std"
   );
}

package CFClient::Recorder;

our $RECORD_WINDOW;

my $CMDBOX;
my $CURRENT_CMDS;
my $REC_BTN;

my @ALLOWED_MODIFIER_KEYS = (
   (CFClient::SDLK_LSHIFT) => "LSHIFT",
   (CFClient::SDLK_LCTRL ) => "LCTRL",
   (CFClient::SDLK_LALT  ) => "LALT",
   (CFClient::SDLK_LMETA ) => "LMETA",

   (CFClient::SDLK_RSHIFT) => "RSHIFT",
   (CFClient::SDLK_RCTRL ) => "RCTRL",
   (CFClient::SDLK_RALT  ) => "RALT",
   (CFClient::SDLK_RMETA ) => "RMETA",
);

my %ALLOWED_MODIFIERS = (
   (CFClient::KMOD_LSHIFT) => "LSHIFT",
   (CFClient::KMOD_LCTRL ) => "LCTRL",
   (CFClient::KMOD_LALT  ) => "LALT",
   (CFClient::KMOD_LMETA ) => "LMETA",

   (CFClient::KMOD_RSHIFT) => "RSHIFT",
   (CFClient::KMOD_RCTRL ) => "RCTRL",
   (CFClient::KMOD_RALT  ) => "RALT",
   (CFClient::KMOD_RMETA ) => "RMETA",
);

my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
my @DIRECT_BIND_KEYS = (
   CFClient::SDLK_F1,
   CFClient::SDLK_F2,
   CFClient::SDLK_F3,
   CFClient::SDLK_F4,
   CFClient::SDLK_F5,
   CFClient::SDLK_F6,
   CFClient::SDLK_F7,
   CFClient::SDLK_F8,
   CFClient::SDLK_F9,
   CFClient::SDLK_F10,
   CFClient::SDLK_F11,
   CFClient::SDLK_F12,
   CFClient::SDLK_F13,
   CFClient::SDLK_F14,
   CFClient::SDLK_F15,
);

# this binding dialog asks for a key-combo to be pressed
# and if successful it binds the modifier+symbol to the 
# supplied actions in $cmd.
# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
sub open_binding_dialog {
   my ($cmd) = @_;

   my $w = new CFClient::UI::FancyFrame
      title => "Bind Action";

   $w->add (my $vb = new CFClient::UI::VBox);
   $vb->add (new CFClient::UI::Label
      text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
             ."You can only bind 0-9 and F1-F15 without modifiers."
   );
   $vb->add (my $entry = new CFClient::UI::Entry
      text => "",
      on_key_down => sub {
         my ($entry, $ev) = @_;

         my $mod = $ev->{mod};
         my $sym = $ev->{sym};

         # XXX: This seems a little bit hackisch to me, but i have to ignore them
         if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
            return;
         }

         if ($mod == CFClient::KMOD_NONE
             and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
             and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
         {
            $::STATUSBOX->add (
               "Can't bind key ".CFClient::SDL_GetKeyName ($sym)
               ." directly without modifier! It would damage the completer handling."
            );
            return;
         }

         $entry->focus_out;

         $::CFG->{bindings}->{$mod}->{$sym} = $cmd;
         $::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");

         $w->destroy
      });

   $entry->focus_in;
   $w->center;
   $w->show;
}

sub keycombo_to_name {
   my ($mod, $sym) = @_;

   my $mods = join '+',
                 map { $ALLOWED_MODIFIERS{$_} }
                    grep { $_ & $mod }
                       keys %ALLOWED_MODIFIERS;
   $mods .= "+" if $mods ne '';

   return $mods . CFClient::SDL_GetKeyName ($sym);
}

sub clear_command_list {
   $CMDBOX->clear () if $CMDBOX;
}

sub set_command_list {
   my ($list) = @_;

   return unless $CMDBOX;

   $CMDBOX->clear ();
   $CURRENT_CMDS = $list;

   my $idx = 0;

   for (@$list) {
      $CMDBOX->add (my $hb = new CFClient::UI::HBox);

      my $i = $idx;
      $hb->add (new CFClient::UI::Button
         text => "delete",
         tooltip => "Deletes the action from the record",
         on_activate => sub {
            $CMDBOX->remove ($hb);
            $list->[$i] = undef;
         });

      $hb->add (new CFClient::UI::Label text => $_);

      $idx++
   }
}

# if $show is 1 the recorder will be shown
sub start {
   my ($show) = @_;

   $RECORD_WINDOW->show if $show;

   $REC_BTN->set_text ("stop recording");
   $REC_BTN->{recording} = 1;
   clear_command_list;
   $::CONN->start_record;
}

# if $autobind is 1 the recorder will be automatically
# jump into the binding query and hide the recorder window
sub stop {
   my ($autobind) = @_;

   $REC_BTN->set_text ("start recording");
   $REC_BTN->{recording} = 0;

   my $rec = $::CONN->stop_record;
   return unless ref $rec eq 'ARRAY';
   set_command_list ($rec);

   if ($autobind) {
      open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
      $RECORD_WINDOW->hide;
   }
}

sub make_window {
   $RECORD_WINDOW = new CFClient::UI::FancyFrame
      req_y => 1,
      req_x => -1,
      title => "Action Recorder";

   $RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
   $vb->add ($REC_BTN = new CFClient::UI::Button
      text => "start recording",
      tooltip => "Start/Stops recording of actions."
                ."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
                ."All subsequent actions after the recording started will be captured."
                ."The actions are displayed after the record was stopped."
                ."To bind the action you have to click on the 'Bind' button",
      on_activate => sub {
         my ($btn) = @_;

         unless ($btn->{recording}) {
            start;
         } else {
            stop;
         }
      });
   $vb->add ($CMDBOX = new CFClient::UI::VBox);
   $vb->add (new CFClient::UI::Button
      text => "bind",
      tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
      on_activate => sub {
         open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
      });

   $RECORD_WINDOW
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.78
Committed:	Mon May 29 22:02:06 2006 UTC (17 years, 11 months ago) by root
Branch:	MAIN
Changes since 1.77:	+1 -1 lines
Log Message:	update bdb open flags
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3	root	1.22	CFClient - undocumented utility garbage for our crossfire client
4	root	1.1
5			=head1 SYNOPSIS
6
7	root	1.22	use CFClient;
8	root	1.1
9			=head1 DESCRIPTION
10
11			=over 4
12
13			=cut
14
15	root	1.22	package CFClient;
16	root	1.1
17			BEGIN {
18			$VERSION = '0.1';
19
20	root	1.2	use XSLoader;
21	root	1.22	XSLoader::load "CFClient", $VERSION;
22	root	1.1	}
23
24	root	1.62	use utf8;
25
26	root	1.43	use Carp ();
27	root	1.52	use AnyEvent ();
28	root	1.34	use BerkeleyDB;
29	root	1.52
30	root	1.5	sub find_rcfile($) {
31			my $path;
32
33	root	1.46	for (grep !ref, @INC) {
34	root	1.22	$path = "$_/CFClient/resources/$_[0]";
35	root	1.5	return $path if -r $path;
36			}
37
38			die "FATAL: can't find required file $_[0]\n";
39			}
40
41			sub read_cfg {
42			my ($file) = @_;
43
44			open CFG, $file
45			or return;
46
47			my $CFG;
48
49			local $/;
50			$CFG = eval <CFG>;
51
52			$::CFG = $CFG;
53
54			close CFG;
55			}
56
57			sub write_cfg {
58			my ($file) = @_;
59
60			open CFG, ">$file"
61			or return;
62
63			{
64	elmex	1.9	require Data::Dumper;
65	root	1.5	local $Data::Dumper::Purity = 1;
66			$::CFG->{VERSION} = $::VERSION;
67			print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
68			}
69
70			close CFG;
71			}
72
73	root	1.75	mkdir "$Crossfire::VARDIR/cfplus", 0777;
74	root	1.34
75	root	1.77	our $DB_ENV;
76
77	root	1.76	{
78			use strict;
79
80	root	1.77	my $recover = $BerkeleyDB::db_version >= 4.4
81			? eval "DB_REGISTER \| DB_RECOVER"
82			: 0;
83
84			$DB_ENV = new BerkeleyDB::Env
85	root	1.76	-Home => "$Crossfire::VARDIR/cfplus",
86			-Cachesize => 1_000_000,
87			-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
88	root	1.39	# -ErrPrefix => "DATABASE",
89	root	1.76	-Verbose => 1,
90	root	1.77	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
91	root	1.78	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
92	root	1.76	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
93			}
94	root	1.34
95			sub db_table($) {
96	root	1.38	my ($table) = @_;
97
98			$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
99	root	1.76
100	root	1.34	new CFClient::Database
101			-Env => $DB_ENV,
102	root	1.38	-Filename => $table,
103			# -Filename => "database",
104			# -Subname => $table,
105	root	1.51	-Property => DB_CHKSUM,
106	root	1.34	-Flags => DB_CREATE \| DB_UPGRADE,
107	root	1.76	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
108	root	1.34	}
109
110	root	1.52	sub pod_to_pango($) {
111			my ($pom) = @_;
112
113			$pom->present ("CFClient::PodToPango")
114			}
115
116	root	1.60	sub pod_to_pango_list($) {
117			my ($pom) = @_;
118
119			[
120			map s/^(\s)// && [40 length $1, length $_ ? $_ : " "],
121			split /\n/, $pom->present ("CFClient::PodToPango")
122			]
123			}
124
125	root	1.52	package CFClient::PodToPango;
126
127			use base Pod::POM::View::Text;
128
129			our $indent = 0;
130
131			*view_seq_code =
132			*view_seq_bold = sub { "<b>$_[1]</b>" };
133			*view_seq_italic = sub { "<i>$_[1]</i>" };
134			*view_seq_space =
135			*view_seq_link =
136			*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
137
138			sub view_seq_text {
139			my $text = $_[1];
140			$text =~ s/\s+/ /g;
141			CFClient::UI::Label::escape ($text)
142			}
143
144			sub view_item {
145			("\t" x ($indent / 4))
146			. $_[1]->title->present ($_[0])
147			. "\n"
148			. $_[1]->content->present ($_[0])
149			}
150
151	root	1.53	sub view_verbatim {
152			(join "",
153	root	1.69	map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
154	root	1.53	split /\n/, CFClient::UI::Label::escape ($_[1]))
155			. "\n"
156			}
157
158	root	1.52	sub view_textblock {
159			("\t" x ($indent / 2)) . "$_[1]\n\n"
160			}
161
162	root	1.60	sub view_head1 {
163	root	1.69	"\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
164	root	1.60	. $_[1]->content->present ($_[0])
165			};
166
167	root	1.52	sub view_head2 {
168	root	1.69	"\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
169			. $_[1]->content->present ($_[0])
170			};
171
172			sub view_head3 {
173			"\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
174	root	1.52	. $_[1]->content->present ($_[0])
175			};
176
177			sub view_over {
178			local $indent = $indent + $_[1]->indent;
179			$_[1]->content->present ($_[0])
180			}
181
182	root	1.34	package CFClient::Database;
183
184			our @ISA = BerkeleyDB::Btree::;
185
186			sub get($$) {
187			my $data;
188
189			$_[0]->db_get ($_[1], $data) == 0
190			? $data
191	root	1.37	: ()
192	root	1.34	}
193
194			my %DB_SYNC;
195
196			sub put($$$) {
197			my ($db, $key, $data) = @_;
198
199	root	1.37	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
200	root	1.34
201	root	1.37	$db->db_put ($key => $data)
202	root	1.34	}
203
204	root	1.62	package CFClient::Item;
205
206	root	1.71	use strict;
207			use Crossfire::Protocol::Constants;
208
209	root	1.62	sub desc_string {
210			my ($self) = @_;
211
212			my $desc =
213			$self->{nrof} < 2
214			? $self->{name}
215			: "$self->{nrof} × $self->{name_pl}";
216
217	root	1.71	$self->{flags} & F_OPEN
218	root	1.62	and $desc .= " (open)";
219	root	1.71	$self->{flags} & F_APPLIED
220	root	1.62	and $desc .= " (applied)";
221	root	1.71	$self->{flags} & F_UNPAID
222	root	1.62	and $desc .= " (unpaid)";
223	root	1.71	$self->{flags} & F_MAGIC
224	root	1.62	and $desc .= " (magic)";
225	root	1.71	$self->{flags} & F_CURSED
226	root	1.62	and $desc .= " (cursed)";
227	root	1.71	$self->{flags} & F_DAMNED
228	root	1.62	and $desc .= " (damned)";
229	root	1.71	$self->{flags} & F_LOCKED
230	root	1.62	and $desc .= " *";
231
232			$desc
233			}
234
235			sub weight_string {
236			my ($self) = @_;
237
238			my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
239
240			$weight < 0 ? "?" : $weight * 0.001
241			}
242
243			sub update_widgets {
244			my ($self) = @_;
245
246	root	1.63	my $button_cb = sub {
247			my (undef, $ev, $x, $y) = @_;
248
249			if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
250			my $targ = $::CONN->{player}{tag};
251
252			if ($self->{container} == $::CONN->{player}{tag}) {
253	elmex	1.64	$targ = $::CONN->{open_container};
254	root	1.63	}
255
256			$::CONN->send ("move $targ $self->{tag} 0");
257			} elsif ($ev->{button} == 1) {
258			$::CONN->send ("examine $self->{tag}");
259			} elsif ($ev->{button} == 2) {
260			$::CONN->send ("apply $self->{tag}");
261			} elsif ($ev->{button} == 3) {
262			my @menu_items = (
263			["examine", sub { $::CONN->send ("examine $self->{tag}") }],
264			["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
265			["apply", sub { $::CONN->send ("apply $self->{tag}") }],
266			(
267	root	1.71	$self->{flags} & F_LOCKED
268	root	1.63	? (
269			["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
270			)
271			: (
272			["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
273	elmex	1.64	["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
274	root	1.63	)
275			),
276			);
277
278			CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
279			}
280
281			1
282			};
283
284	root	1.62	my $tooltip_std = "<small>"
285			. "Left click - examine item\n"
286			. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
287			. "Middle click - apply\n"
288			. "Right click - further options"
289			. "</small>\n";
290
291	root	1.63	$self->{face_widget} \|\|= new CFClient::UI::Face
292			can_events => 1,
293			can_hover => 1,
294	root	1.67	anim => $self->{anim},
295	root	1.66	animspeed => $self->{animspeed}, # TODO# must be set at creation time
296	root	1.72	on_button_down => $button_cb,
297	root	1.63	;
298	root	1.62	$self->{face_widget}{face} = $self->{face};
299			$self->{face_widget}{anim} = $self->{anim};
300	root	1.65	$self->{face_widget}{animspeed} = $self->{animspeed};
301	root	1.62	$self->{face_widget}->set_tooltip (
302			"<b>Face/Animation.</b>\n"
303			. "Item uses face #$self->{face}. "
304			. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
305			. "\n\n$tooltip_std"
306			);
307
308	root	1.63	$self->{desc_widget} \|\|= new CFClient::UI::Label
309			can_events => 1,
310			can_hover => 1,
311			ellipsise => 2,
312	root	1.68	align => -1,
313	root	1.72	on_button_down => $button_cb,
314	root	1.63	;
315			my $desc = CFClient::Item::desc_string $self;
316			$self->{desc_widget}->set_text ($desc);
317			$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
318
319			$self->{weight_widget} \|\|= new CFClient::UI::Label
320			can_events => 1,
321			can_hover => 1,
322			ellipsise => 0,
323	root	1.68	align => 0,
324	root	1.72	on_button_down => $button_cb,
325	root	1.63	;
326	root	1.62	$self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
327
328			$self->{weight_widget}->set_tooltip (
329			"<b>Weight</b>.\n"
330			. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
331			. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
332			. "\n\n$tooltip_std"
333			);
334			}
335
336	elmex	1.73	package CFClient::Recorder;
337
338			our $RECORD_WINDOW;
339
340			my $CMDBOX;
341			my $CURRENT_CMDS;
342			my $REC_BTN;
343
344			my @ALLOWED_MODIFIER_KEYS = (
345			(CFClient::SDLK_LSHIFT) => "LSHIFT",
346			(CFClient::SDLK_LCTRL ) => "LCTRL",
347			(CFClient::SDLK_LALT ) => "LALT",
348			(CFClient::SDLK_LMETA ) => "LMETA",
349
350			(CFClient::SDLK_RSHIFT) => "RSHIFT",
351			(CFClient::SDLK_RCTRL ) => "RCTRL",
352			(CFClient::SDLK_RALT ) => "RALT",
353			(CFClient::SDLK_RMETA ) => "RMETA",
354			);
355
356			my %ALLOWED_MODIFIERS = (
357			(CFClient::KMOD_LSHIFT) => "LSHIFT",
358			(CFClient::KMOD_LCTRL ) => "LCTRL",
359			(CFClient::KMOD_LALT ) => "LALT",
360			(CFClient::KMOD_LMETA ) => "LMETA",
361
362			(CFClient::KMOD_RSHIFT) => "RSHIFT",
363			(CFClient::KMOD_RCTRL ) => "RCTRL",
364			(CFClient::KMOD_RALT ) => "RALT",
365			(CFClient::KMOD_RMETA ) => "RMETA",
366			);
367
368			my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
369			my @DIRECT_BIND_KEYS = (
370			CFClient::SDLK_F1,
371			CFClient::SDLK_F2,
372			CFClient::SDLK_F3,
373			CFClient::SDLK_F4,
374			CFClient::SDLK_F5,
375			CFClient::SDLK_F6,
376			CFClient::SDLK_F7,
377			CFClient::SDLK_F8,
378			CFClient::SDLK_F9,
379			CFClient::SDLK_F10,
380			CFClient::SDLK_F11,
381			CFClient::SDLK_F12,
382			CFClient::SDLK_F13,
383			CFClient::SDLK_F14,
384			CFClient::SDLK_F15,
385			);
386
387			# this binding dialog asks for a key-combo to be pressed
388			# and if successful it binds the modifier+symbol to the
389			# supplied actions in $cmd.
390			# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
391			sub open_binding_dialog {
392			my ($cmd) = @_;
393
394			my $w = new CFClient::UI::FancyFrame
395			title => "Bind Action";
396
397			$w->add (my $vb = new CFClient::UI::VBox);
398			$vb->add (new CFClient::UI::Label
399			text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
400			."You can only bind 0-9 and F1-F15 without modifiers."
401			);
402			$vb->add (my $entry = new CFClient::UI::Entry
403			text => "",
404			on_key_down => sub {
405			my ($entry, $ev) = @_;
406
407			my $mod = $ev->{mod};
408			my $sym = $ev->{sym};
409
410			# XXX: This seems a little bit hackisch to me, but i have to ignore them
411			if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
412			return;
413			}
414
415			if ($mod == CFClient::KMOD_NONE
416			and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
417			and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
418			{
419			$::STATUSBOX->add (
420			"Can't bind key ".CFClient::SDL_GetKeyName ($sym)
421			." directly without modifier! It would damage the completer handling."
422			);
423			return;
424			}
425
426			$entry->focus_out;
427
428			$::CFG->{bindings}->{$mod}->{$sym} = $cmd;
429	elmex	1.74	$::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
430	elmex	1.73
431			$w->destroy
432			});
433
434			$entry->focus_in;
435			$w->center;
436			$w->show;
437			}
438
439			sub keycombo_to_name {
440			my ($mod, $sym) = @_;
441
442			my $mods = join '+',
443			map { $ALLOWED_MODIFIERS{$_} }
444			grep { $_ & $mod }
445			keys %ALLOWED_MODIFIERS;
446			$mods .= "+" if $mods ne '';
447
448			return $mods . CFClient::SDL_GetKeyName ($sym);
449			}
450
451			sub clear_command_list {
452			$CMDBOX->clear () if $CMDBOX;
453			}
454
455			sub set_command_list {
456			my ($list) = @_;
457
458			return unless $CMDBOX;
459
460			$CMDBOX->clear ();
461			$CURRENT_CMDS = $list;
462
463			my $idx = 0;
464
465			for (@$list) {
466			$CMDBOX->add (my $hb = new CFClient::UI::HBox);
467
468			my $i = $idx;
469			$hb->add (new CFClient::UI::Button
470	elmex	1.74	text => "delete",
471	elmex	1.73	tooltip => "Deletes the action from the record",
472			on_activate => sub {
473			$CMDBOX->remove ($hb);
474			$list->[$i] = undef;
475			});
476
477			$hb->add (new CFClient::UI::Label text => $_);
478
479			$idx++
480			}
481			}
482
483			# if $show is 1 the recorder will be shown
484			sub start {
485			my ($show) = @_;
486
487			$RECORD_WINDOW->show if $show;
488
489			$REC_BTN->set_text ("stop recording");
490			$REC_BTN->{recording} = 1;
491			clear_command_list;
492			$::CONN->start_record;
493			}
494
495			# if $autobind is 1 the recorder will be automatically
496			# jump into the binding query and hide the recorder window
497			sub stop {
498			my ($autobind) = @_;
499
500			$REC_BTN->set_text ("start recording");
501			$REC_BTN->{recording} = 0;
502
503			my $rec = $::CONN->stop_record;
504			return unless ref $rec eq 'ARRAY';
505			set_command_list ($rec);
506
507			if ($autobind) {
508			open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
509			$RECORD_WINDOW->hide;
510			}
511			}
512
513			sub make_window {
514			$RECORD_WINDOW = new CFClient::UI::FancyFrame
515			req_y => 1,
516			req_x => -1,
517			title => "Action Recorder";
518
519			$RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
520			$vb->add ($REC_BTN = new CFClient::UI::Button
521			text => "start recording",
522			tooltip => "Start/Stops recording of actions."
523	elmex	1.74	."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
524	elmex	1.73	."All subsequent actions after the recording started will be captured."
525			."The actions are displayed after the record was stopped."
526			."To bind the action you have to click on the 'Bind' button",
527			on_activate => sub {
528			my ($btn) = @_;
529
530			unless ($btn->{recording}) {
531			start;
532			} else {
533			stop;
534			}
535			});
536			$vb->add ($CMDBOX = new CFClient::UI::VBox);
537			$vb->add (new CFClient::UI::Button
538			text => "bind",
539			tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
540			on_activate => sub {
541			open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
542			});
543
544			$RECORD_WINDOW
545			}
546
547	root	1.1	1;
548
549			=back
550
551			=head1 AUTHOR
552
553			Marc Lehmann <schmorp@schmorp.de>
554			http://home.schmorp.de/
555
556			=cut
557