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;

{
   use strict;

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