ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/Main.pm
(Generate patch)

Comparing deliantra/Deliantra-Client/DC/Main.pm (file contents):
Revision 1.18 by root, Wed Jan 18 15:31:51 2012 UTC vs.
Revision 1.23 by root, Fri Nov 16 12:03:26 2012 UTC

… …
25BEGIN { *time = \&EV::time } 25BEGIN { *time = \&EV::time }
26 26
27use List::Util qw(max min); 27use List::Util qw(max min);
28 28
29use Deliantra; 29use Deliantra;
30use Deliantra::Util;
30use Deliantra::Protocol::Constants; 31use Deliantra::Protocol::Constants;
31 32
32use AnyEvent::Util (); 33use AnyEvent::Util ();
33use AnyEvent::Socket (); 34use AnyEvent::Socket ();
34use AnyEvent::DNS (); 35use AnyEvent::DNS ();
35 36
36use Compress::LZF; 37use Compress::LZF;
37use JSON::XS; 38use JSON::XS;
39use Urlader;
38 40
39use DC; 41use DC;
40 42
41sub crash($;$) { 43sub crash($;$) {
42 # nop at compiletime 44 # nop at compiletime
… …
44 46
45BEGIN { 47BEGIN {
46 $SIG{__DIE__} = sub { 48 $SIG{__DIE__} = sub {
47 return if $^S; # quick reject 49 return if $^S; # quick reject
48 50
49 # return if there are any eval contexts in the csall stack 51 # return if there are any eval contexts in the call stack
50 for my $i (0..999) { 52 for my $i (0..999) {
51 my ($sub, $is_require) = (caller $i)[3, 7] 53 my ($sub, $is_require) = (caller $i)[3, 7]
52 or last; 54 or last;
53 return if $sub eq "(eval)" && !$is_require; 55 return if $sub eq "(eval)" && !$is_require;
54 } 56 }
… …
127our $MENUBAR; # the hbox at the top 129our $MENUBAR; # the hbox at the top
128our $MENUPOPUP; 130our $MENUPOPUP;
129our $BUTTONBAR; # the menu buttons 131our $BUTTONBAR; # the menu buttons
130our $METASERVER; 132our $METASERVER;
131our $LOGIN_BUTTON; 133our $LOGIN_BUTTON;
134our $LOGIN_ERROR;
132our $QUIT_DIALOG; 135our $QUIT_DIALOG;
133our $HOST_ENTRY; 136our $HOST_ENTRY;
134our $FULLSCREEN_ENABLE; 137our $FULLSCREEN_ENABLE;
135our $PICKUP_ENABLE; 138our $PICKUP_ENABLE;
136our $SERVER_INFO; 139our $SERVER_INFO;
… …
250 : "[<span foreground='#888'>num</span>]"; 253 : "[<span foreground='#888'>num</span>]";
251 254
252 # <tt> around next statement works around some bug that keeps the 255 # <tt> around next statement works around some bug that keeps the
253 # "font =>" from being used on windows 256 # "font =>" from being used on windows
254 $MODBOX->set_markup ("<tt>$markup</tt>"); 257 $MODBOX->set_markup ("<tt>$markup</tt>");
258}
259
260sub errorbox {
261 my ($msg) = @_;
262
263 status $msg;
264
265 my $dialog = new DC::UI::Toplevel
266 x => "center",
267 y => "center",
268 z => 200,
269 title => "Error",
270 child => my $vbox = new DC::UI::VBox,
271 has_close_button => 1,
272 on_delete => sub {
273 $_[0]->destroy;
274 },
275 ;
276
277 add $vbox new DC::UI::Label
278 align => 0.5,
279 ellipsise => 0,
280 text => $msg;
281
282 add $vbox new DC::UI::Button
283 expand => 1,
284 text => "OK",
285 on_activate => sub {
286 $dialog->destroy;
287 0
288 }
289 ;
290
291 $dialog->show;
255} 292}
256 293
257############################################################################# 294#############################################################################
258#TODO: maybe move into own audio module... 295#TODO: maybe move into own audio module...
259 296
… …
688 ::message { markup => "Server has no newer version." }; 725 ::message { markup => "Server has no newer version." };
689 } 726 }
690 } else { 727 } else {
691 ::message { markup => "Server does not support software update." }; 728 ::message { markup => "Server does not support software update." };
692 } 729 }
693
694# $self->register_face_handler ($exp_table, sub {
695# my ($face) = @_;
696
697# $self->{exp_table} = $self->{json_coder}->decode (delete $face->{data});
698# $_->() for values %{ $self->{on_exp_update} || {} };
699# });
700 730
701 () 731 ()
702 }); 732 });
703} 733}
704 734
… …
934 $vbox->add (@dialog); 964 $vbox->add (@dialog);
935 $dialog->show; 965 $dialog->show;
936} 966}
937 967
938sub dc_connect { 968sub dc_connect {
939 my ($host, $port) = @_; 969 my ($host, $port, $create) = @_;
940 970
941 my $mapw = List::Util::min 48, List::Util::max 11, int 1.5 + $WIDTH * $CFG->{mapsize} * 0.01 / 32; 971 my $mapw = List::Util::min 48, List::Util::max 11, int 1.5 + $WIDTH * $CFG->{mapsize} * 0.01 / 32;
942 my $maph = List::Util::min 48, List::Util::max 11, int 1.5 + $HEIGHT * $CFG->{mapsize} * 0.01 / 32; 972 my $maph = List::Util::min 48, List::Util::max 11, int 1.5 + $HEIGHT * $CFG->{mapsize} * 0.01 / 32;
943 973
944 $CONN = 974 $CONN =
945 new DC::Protocol 975 new DC::Protocol
946 host => $host, 976 host => $host,
947 port => $port, 977 port => $port,
978 create_login => $create,
948 user => $PROFILE->{user}, 979 user => $PROFILE->{user},
949 pass => $PROFILE->{password}, 980 pass => $PROFILE->{password},
950 mapw => $mapw, 981 mapw => $mapw,
951 maph => $maph, 982 maph => $maph,
952 983
… …
974 ota_update_check; 1005 ota_update_check;
975 1006
976 status "successfully connected to the server"; 1007 status "successfully connected to the server";
977 } else { 1008 } else {
978 undef $CONN; 1009 undef $CONN;
979 status "unable to connect: $!"; 1010 $LOGIN_ERROR->{fg} = [1, 0, 0];
1011 $LOGIN_ERROR->set_text ("Unable to connect to server: $!");
980 stop_game(); 1012 stop_game();
981 } 1013 }
982 }, 1014 },
1015
1016 on_addme => sub {
1017 my ($ok, $msg) = @_;
1018
1019 $LOGIN_ERROR->{fg} = $ok ? [0, 1, 0] : [1, 0, 0];
1020 $LOGIN_ERROR->set_text ($msg);
1021 },
983 ; 1022 ;
984} 1023}
985 1024
986sub start_game { 1025sub start_game($) {
1026 my ($create) = @_;
1027
987 status "logging in..."; 1028 status "logging in...";
988 1029
989 my $server = $PROFILE->{host} || $DEFAULT_SERVER; 1030 my $server = $PROFILE->{host} || $DEFAULT_SERVER;
990 my ($host, $port) = AnyEvent::Socket::parse_hostport $server, "deliantra=13327" 1031 my ($host, $port) = AnyEvent::Socket::parse_hostport $server, "deliantra=13327"
991 or return status "$server: unable to parse server address, try an empty field."; 1032 or return status "$server: unable to parse server address, try an empty field.";
… …
1006 status "dns failure, using hardcoded address"; 1047 status "dns failure, using hardcoded address";
1007 $host = "194.126.175.154"; 1048 $host = "194.126.175.154";
1008 } 1049 }
1009 } 1050 }
1010 1051
1011 dc_connect $host, $port; 1052 dc_connect $host, $port, $create;
1012 }; 1053 };
1013 } else { 1054 } else {
1014 dc_connect $host, $port; 1055 dc_connect $host, $port, $create;
1015 } 1056 }
1016} 1057}
1017 1058
1018sub stop_game { 1059sub stop_game {
1019 crash "stop_game"; 1060 crash "stop_game";
… …
1852 $vbox->add (new DC::UI::FancyFrame 1893 $vbox->add (new DC::UI::FancyFrame
1853 label => "Login Settings", 1894 label => "Login Settings",
1854 child => (my $table = new DC::UI::Table expand => 1, col_expand => [0, 1]), 1895 child => (my $table = new DC::UI::Table expand => 1, col_expand => [0, 1]),
1855 ); 1896 );
1856 1897
1898 my $nullpw = "\x00" x 16;
1899
1857 $table->add_at (0, 4, new DC::UI::Label align => 1, text => "Username"); 1900 $table->add_at (0, 0, new DC::UI::Label align => 1, text => "Username");
1858 $table->add_at (1, 4, new DC::UI::Entry 1901 $table->add_at (1, 0, new DC::UI::Entry
1859 text => $PROFILE->{user}, 1902 text => $PROFILE->{user},
1860 tooltip => "The name of your character on the server. The name is case-sensitive!", 1903 tooltip => "The name of your character on the server. The name is case-sensitive!",
1861 on_changed => sub { my ($self, $value) = @_; $PROFILE->{user} = $value; 1 } 1904 on_changed => sub { my ($self, $value) = @_; $PROFILE->{user} = $value; 1 }
1862 ); 1905 );
1863 1906
1864 $table->add_at (0, 5, new DC::UI::Label align => 1, text => "Password"); 1907 $table->add_at (0, 1, new DC::UI::Label align => 1, text => "Password");
1865 $table->add_at (1, 5, new DC::UI::Entry 1908 $table->add_at (1, 1, my $pw1 = new DC::UI::Entry
1866 text => $PROFILE->{password}, 1909 text => $PROFILE->{password} ? $nullpw : "",
1867 hidden => 1, 1910 hidden => 1,
1868 tooltip => "The password for your character.", 1911 tooltip => "The password for your character.",
1869 on_changed => sub { my ($self, $value) = @_; $PROFILE->{password} = $value; 1 } 1912 on_focus_in => sub {
1913 my ($self) = @_;
1914 $self->set_text ("")
1915 if $self->{text} eq $nullpw;
1916 0
1917 },
1918 on_changed => sub {
1919 my ($self, $value) = @_;
1920 $PROFILE->{password} = Deliantra::Util::hash_pw $value
1921 if length $value && $value ne $nullpw;
1922 1
1923 },
1870 ); 1924 );
1871 1925
1872 $table->add_at (1, 11, $LOGIN_BUTTON = new DC::UI::Button 1926 $table->add_at (1, 2, $LOGIN_BUTTON = new DC::UI::Button
1873 expand => 1, 1927 expand => 1,
1874 text => "Login / Register", 1928 text => "Login to Existing Account",
1875 tooltip => "This button will either login to the account configured above or register a new account.", 1929 tooltip => "This button will login to the account given by the <b>Username</b> and <b>Password</b> fields above.",
1876 on_activate => sub { 1930 on_activate => sub {
1877 $CONN ? stop_game 1931 $CONN ? stop_game
1878 : start_game; 1932 : start_game 0;
1879 1 1933 1
1880 }, 1934 },
1881 ); 1935 );
1882 1936
1937 $table->add_at (0, 3, new DC::UI::Label align => 1, text => "Password");
1938 $table->add_at (1, 3, my $pw2 = new DC::UI::Entry
1939 hidden => 1,
1940 tooltip => "The new password for your character",
1941 );
1942
1943 $table->add_at (1, 4, new DC::UI::Button
1944 expand => 1,
1945 text => "Create New Account",
1946 tooltip => "This button will try to create a new account - you need to fill out the <b>Username</b> and the two <b>Password</b> fields above, using the same password for both <b>Password</b> fields.",
1947 on_activate => sub {
1948 if ($pw1->{text} ne $pw2->{text}) {
1949 $LOGIN_ERROR->{fg} = [1, 0, 0];
1950 $LOGIN_ERROR->set_text ("The passwords do not match - try to enter them again.");
1951 } else {
1952 $CONN or start_game 1;
1953 }
1954 1
1955 },
1956 );
1957
1958 $vbox->add (new DC::UI::FancyFrame
1959 label => "Server Message",
1960 tooltip => "The last message, or error, form the server.",
1961 child => ($LOGIN_ERROR = new DC::UI::Label valign => 0, ellipsise => 0),
1962 );
1963
1883 $vbox->add (new DC::UI::FancyFrame 1964 $vbox->add (new DC::UI::FancyFrame
1884 label => "How to Play", 1965 label => "How to Play",
1885 min_h => 240, 1966 min_h => 240,#d# should not be necessary - widget bug
1886 child => (new DC::UI::Label valign => 0, ellipsise => 0, 1967 child => (new DC::UI::Label valign => 0, ellipsise => 0,
1887 markup => 1968 markup =>
1888 "First select a suitable video resolution in the <b>Graphics</b> tab, above.\n\n" 1969 "First select a suitable video resolution in the <b>Graphics</b> tab, above.\n\n"
1889 . "Then register a new account (or use an existing one if you have one). " 1970 . "Then create a new account (or use an existing one if you have one).\n\n"
1890 . "To register an account, choose a username that hasn't been taken yet (just guess) and " 1971 . "To create an account, choose a username that hasn't been taken yet (just guess) and "
1891 . "try to log-in. Follow the instructions in the Log tab in the message window.", 1972 . "fill out the top two <b>Password</b> fields using the same password, then press <b>Create New Account</b>.",
1892 ), 1973 ),
1893 ); 1974 );
1894 1975
1895 $vbox 1976 $vbox
1896} 1977}
… …
2660 DC::set_theme $CFG->{uitheme}; 2741 DC::set_theme $CFG->{uitheme};
2661 2742
2662 DC::SDL_InitSubSystem DC::SDL_INIT_VIDEO if $SDL_REINIT; 2743 DC::SDL_InitSubSystem DC::SDL_INIT_VIDEO if $SDL_REINIT;
2663 $SDL_REINIT = 0; 2744 $SDL_REINIT = 0;
2664 2745
2665 @SDL_MODES = DC::SDL_ListModes 8, $CFG->{disable_alpha} ? 0 : 8; 2746 @SDL_MODES = DC::SDL_ListModes 8, $CFG->{disable_alpha} ? 0 : 2;
2666 @SDL_MODES = DC::SDL_ListModes 8, 8 unless @SDL_MODES; 2747 @SDL_MODES = DC::SDL_ListModes 8, 8 unless @SDL_MODES;
2667 @SDL_MODES = DC::SDL_ListModes 5, 0 unless @SDL_MODES; 2748 @SDL_MODES = DC::SDL_ListModes 5, 0 unless @SDL_MODES;
2668 @SDL_MODES or DC::fatal "Unable to find a usable video mode\n(hardware accelerated opengl fullscreen)"; 2749 @SDL_MODES or DC::fatal "Unable to find a usable video mode\n(hardware accelerated opengl fullscreen)";
2669 2750
2670 @SDL_MODES = sort { $a->[0] * $a->[1] <=> $b->[0] * $b->[1] } @SDL_MODES; 2751 @SDL_MODES = sort { $a->[0] * $a->[1] <=> $b->[0] * $b->[1] } @SDL_MODES;

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines