1# -*- perl -*- 2 3# 4# Author: Slaven Rezic 5# 6# Copyright (C) 1999-2008,2012 Slaven Rezic. All rights reserved. 7# This package is free software; you can redistribute it and/or 8# modify it under the same terms as Perl itself. 9# 10# Mail: slaven@rezic.de 11# WWW: http://bbbike.sourceforge.net 12# 13 14package BBBikeAdvanced; 15 16package main; 17 18use Config; 19use strict; 20use BBBikeGlobalVars; 21use BBBikeProcUtil qw(double_fork); 22 23use your qw($BBBike::Menubar::option_menu 24 $BBBike::check_bbbike_temp_blockings::temp_blockings_pl 25 $BBBikeEdit::prefer_tracks 26 $BBBikeEdit::bbd_penalty_multiply $BBBikeEdit::bbd_penalty_invert 27 $BBBikeEdit::gps_penalty_multiply 28 $Devel::Trace::TRACE 29 $DB_File::DB_BTREE 30 $Karte::Standard::obj $Karte::Polar::obj 31 ); 32 33BEGIN { 34 if (!defined &M) { 35 eval 'sub M ($) { @_ }'; warn $@ if $@; 36 } 37} 38 39use constant MAX_LAYERS => 100; 40 41my $LINETYPES_RX = qr{(?:str|p|sperre)}; 42 43sub start_ptksh { 44 # Is there already a (withdrawn) ptksh? 45 foreach my $mw0 (Tk::MainWindow::Existing()) { 46 if ($mw0->title =~ /^ptksh/) { 47 $mw0->deiconify; 48 $mw0->raise; 49 return; 50 } 51 } 52 my @perldirs = $Config{'scriptdir'}; 53 push @perldirs, dirname(dirname($^X)); # for the SiePerl installation 54 my $perldir; 55 TRY: { 56 # "local" probably does not work here, we're in a MainLoop... 57 $Data::Dumper::Deparse = 1; # if I need a "ptksh" window, then I need more diagnostics! 58 $Data::Dumper::Sortkeys = 1; 59 60 # Find the ptksh script 61 for $perldir (@perldirs) { 62 if (-r "$perldir/ptksh") { 63 require "$perldir/ptksh"; 64 last TRY; 65 } 66 } 67 $perldir = dirname($^X); 68 if (-r "$perldir/ptksh") { 69 require "$perldir/ptksh"; 70 } else { 71 my $f = ((Tk::MainWindow::Existing())[0])->getOpenFile 72 ((-d $perldir ? (-initialdir => $perldir) : ()), 73 -title => "Path to ptksh", 74 ); 75 if (defined $f) { 76 require $f; 77 } else { 78 return; 79 } 80 } 81 } 82 83 # The created mainwindow is unnecessary - destroy it 84 foreach my $mw0 (Tk::MainWindow::Existing()) { 85 if ($mw0->title eq '$mw') { 86 $mw0->destroy; 87 } elsif ($mw0->title eq 'ptksh') { 88 $mw0->protocol('WM_DELETE_WINDOW' => [$mw0, 'withdraw']); 89 } 90 } 91} 92 93sub advanced_option_menu { 94 my $opbm = shift || $BBBike::Menubar::option_menu; 95 $opbm->separator; 96 $opbm->command(-label => 'Ptksh', 97 -command => \&start_ptksh, 98 ($top->screenheight < 768 && $Tk::VERSION >= 800 ? (-columnbreak => 1) : ()), 99 ); 100 $opbm->command(-label => 'WidgetDump', 101 -command => sub { 102 require Tk::WidgetDump; 103 $top->WidgetDump; 104 }); 105 my $add_pl = "$tmpdir/add.pl"; 106 $opbm->command(-label => "Eval $add_pl", 107 -command => sub { 108 if (-f "$add_pl") { 109 do $add_pl; 110 warn $@ if $@; 111 return; 112 } 113 if ($top->can('getOpenFile')) { 114 my $f = $top->getOpenFile 115 (-filetypes => 116 [ 117 [M("Perl-Skripte"), ['.pl']], 118 [M("Perl-Module"), '.pm' ], 119 [M("Alle Dateien"), '*', ], 120 ]); 121 if (defined $f and -f $f) { 122 do $f; 123 warn $@ if $@; 124 } 125 } else { 126 warn "Nothing found"; 127 } 128 } 129 ); 130 $opbm->command(-label => 'Reload program and modules', 131 -command => sub { reload_new_modules() }); 132 $opbm->command(-label => 'Destroy all toplevels', 133 -command => sub { destroy_all_toplevels() }); 134 $opbm->command(-label => 'Re-call some subs', 135 -command => sub { recall_some_subs() }); 136 $opbm->command(-label => 'Reload photos', 137 -command => sub { %photo = (); $top->{MapImages} = {}; load_photos() }, 138 ); 139 $opbm->command(-label => M"Datenverzeichnis �ndern ...", 140 -command => sub { change_datadir() }); 141 142 $top->bind("<Pause>" => sub { 143 eval { 144 require Tk::WidgetDump; 145 $top->WidgetDump; 146 }; warn $@ if $@; 147 require Config; 148 my $perldir = $Config::Config{'scriptdir'}; 149 require "$perldir/ptksh"; 150 }); 151 152} 153 154sub custom_draw_dialog { 155 custom_draw(@_); # return file name 156} 157 158my $custom_draw_directory; 159sub custom_draw { 160 my $linetype = shift; 161 my $abk = shift or die "Missing abk"; 162 my $file = shift; 163 my(%args) = @_; 164 # XXX -retargs is a hack, please refactor the whole plot_additional_layer 165 # and custom_draw thingy 166 my $retargs = (delete $args{-retargs}) || {}; 167 my $draw = eval '\%' . $linetype . "_draw"; 168 my $fileref = eval '\%' . $linetype . "_file"; 169 my $name_draw = eval '\%' . $linetype . "_name_draw"; 170 my $coord_input; 171 my $center_beginning = 0; 172 173 $custom_draw_directory = $datadir if !defined $custom_draw_directory; 174 175 require File::Basename; 176 177 if (!defined $file) { 178 die "Tk 800 needed" 179 unless $Tk::VERSION >= 800; 180 my $get_file = sub { 181 my $_file = $top->getOpenFile 182 (-filetypes => 183 [ 184 # XXX use Strassen->filetypes? 185 [M"BBD-Dateien", '.bbd'], 186 [M"BBBike-Route-Dateien", '.bbr'], 187 [M"ESRI-Shape-Dateien", '.shp'], 188 [M"MapInfo-Dateien", ['.mif','.MIF']], 189 ($advanced 190 ? [M"ARC/DCW/E00-Dateien", ['.e00','.E00']] 191 : () 192 ), 193 ($linetype eq 'p' 194 ? [M"Gpsman-Waypoints", ['.wpt']] 195 : [M"Gpsman-Tracks oder -Routen", ['.trk', '.rte']] 196 ), 197 [M"Alle Dateien", '*'], 198 ], 199 (defined $file ? (-initialdir => $file =~ m{/$} ? $file : File::Basename::dirname($file)) : ()), 200 ); 201 $file = $_file if defined $_file; 202 }; 203 204 if (eval { require Tk::PathEntry; 1 }) { 205 my $t = $top->Toplevel; 206 $t->title(M("Zus�tzlich zeichnen")); 207 $t->transient($top) if $transient; 208 209 my $f; 210 $f = $t->Frame->pack(-fill => "x"); 211 my $weiter = 0; 212 my $pe; 213 Tk::grid($pe = $f->PathEntry(-textvariable => \$file, 214 (!defined $file ? (-initialdir => $custom_draw_directory) : ()), 215 -selectcmd => sub { 216 $pe->focusNext; 217 }, 218# -cancelcmd => sub { 219# $weiter = -1; 220# }, 221 ), 222 $f->Button(-image => $t->Getimage("openfolder"), 223 -command => $get_file, 224 -takefocus => 0, 225 ) 226 ); 227 $pe->focus; 228 $f = $t->Frame->pack(-fill => "x"); 229 Tk::grid($f->Checkbutton(-text => M"Namen zeichnen", 230 -variable => \$args{-namedraw}), 231 -sticky => "w", 232 ); 233 if ($linetype eq "p") { 234 Tk::grid($f->Checkbutton(-text => M"�berlappungen vermeiden", 235 -variable => \$args{-nooverlaplabel}), 236 -sticky => "w", 237 ); 238 } 239 240 { 241 my $e; 242 if (eval { require Tk::NumEntry; 1 }) { 243 $e = $f->NumEntry(-minvalue => 1, 244 -maxvalue => 20, 245 -textvariable => \$args{Width}, 246 -width => 3, 247 ); 248 } else { 249 $e = $f->Entry(-width => 3, 250 -textvariable => \$args{Width}); 251 } 252 Tk::grid($f->Label(-text => $linetype eq "p" ? M"Punktbreite" : M"Linienbreite"), 253 $e, 254 -sticky => "w", 255 ); 256 } 257 Tk::grid($f->Label(-text => M"Kartenkoordinaten"), 258 my $om = $f->Optionmenu 259 (-variable => \$coord_input, 260#XXX this causes -width to be ignored? -anchor => "w", 261 -width => 10, 262 -options => [ (map { [ $Karte::map{$_}->name, $_ ] } @Karte::map) ]), 263 -sticky => "w", 264 ); 265 $coord_input = "Standard"; 266 267 Tk::grid($f->Label(-text => M"Auf Anfang zentrieren"), 268 $f->Checkbutton(-variable => \$center_beginning), 269 -sticky => "w"); 270 271 $f = $t->Frame->pack(-fill => "x"); 272 Tk::grid($f->Button(Name => "ok", 273 -command => sub { 274 $weiter = 1; 275 }), 276 $f->Button(Name => "cancel", 277 -command => sub { 278 $weiter = -1; 279 }) 280 ); 281 $t->OnDestroy(sub { $weiter = -1 if !$weiter }); 282 $t->waitVariable(\$weiter); 283 $t->destroy if Tk::Exists($t); 284 285 undef $file if $weiter == -1; 286 287 } else { 288 $get_file->(); 289 } 290 291 if (!defined $file) { 292 $draw->{$abk} = 0; 293 return; 294 } 295 296 $custom_draw_directory = File::Basename::dirname($file); 297 298 } 299 300 # XXX not nice, but it works... 301 if ($file =~ /\.bbr$/) { 302 my $tmpfile = "$tmpdir/" . basename($file); 303 require Route::Heavy; 304 my $s = Route::as_strassen($file); 305 $s->write($tmpfile); 306 $file = $tmpfile; 307 } 308 309 @BBBike::ExtFile::scrollregion = (); 310 undef $BBBike::ExtFile::center_on_coord; 311 $fileref->{$abk} = $file; 312 # zus�tzliches desc-File einlesen: 313 if ($file =~ /(.*)\.bbd(\.gz)?$/) { 314 my $desc_file = "$1.desc"; 315 warn "Try to load description file $desc_file" 316 if $verbose; 317 read_desc_file($desc_file, $abk); # XXX obsolete 318 handle_global_directives($file, $abk); 319 } 320 321 if ($args{-namedraw}) { 322 $retargs->{NameDraw} = $args{-namedraw}; 323 delete $args{-namedraw}; 324 $name_draw->{$abk} = 1; 325 } 326 if ($args{-nooverlaplabel}) { 327 delete $args{-nooverlaplabel}; 328 $no_overlap_label{$abk} = 1; 329 } 330 331 my $do_close = 1; 332 $do_close = delete $args{-close} if exists $args{-close}; 333 334 # XXX the condition should be defined $default_line_width, 335 # but can't use it because of the Checkbutton/Menu bug 336 if ($default_line_width && (!defined $args{Width} || $args{Width} eq "")) { 337 $args{Width} = $default_line_width; 338 } 339 if ($args{Width}) { 340 $retargs->{Width} = $args{Width}; 341 } 342 $args{-draw} = 1; 343 $args{-filename} = $file; 344 if (defined $coord_input && $coord_input ne "Standard") { 345 $args{-map} = $coord_input; 346 $retargs->{-map} = $coord_input; 347 } 348 if ($linetype eq 'p') { 349 delete $p_obj{$abk}; 350 } else { 351 delete $str_obj{$abk}; 352 } 353 plot($linetype, $abk, %args); 354 355 # XXX The bindings should also be recycled if the layer is deleted! 356 for (($linetype eq 'p' ? ("$abk-img", "$abk-fg") : ($abk))) { 357 $c->bind($_, "<ButtonRelease-1>" => \&set_route_point); 358 } 359 360 if (@BBBike::ExtFile::scrollregion) { 361 set_scrollregion(@BBBike::ExtFile::scrollregion); 362 } 363 if ($BBBike::ExtFile::p_attrib && $linetype eq 'p') { 364 $p_attrib{$abk} = $BBBike::ExtFile::p_attrib; 365 } else { 366 delete $p_attrib{$abk}; 367 } 368 if ($BBBike::ExtFile::str_attrib && $linetype eq 'str') { 369 $str_attrib{$abk} = $BBBike::ExtFile::str_attrib; 370 } else { 371 delete $str_attrib{$abk}; 372 } 373 374 my $coord; 375 if (defined $BBBike::ExtFile::center_on_coord) { 376 $coord = $BBBike::ExtFile::center_on_coord; 377 } elsif ($center_beginning) { 378 my $obj = $linetype eq 'p' ? \%p_obj : \%str_obj; 379 if ($obj->{$abk}) { 380 my $r = $obj->{$abk}->get(0); 381 if ($r) { 382 $coord = $r->[Strassen::COORDS()]->[0]; 383 my $conv = $obj->{$abk}->get_conversion; # XXX %conv_args??? 384 if ($conv) { 385 $coord = $conv->($coord); 386 } 387 } 388 } 389 } 390 if (defined $coord) { 391 choose_from_plz(-coord => $coord); 392 } 393 394 $toplevel{"chooseort-$abk-$linetype"}->destroy 395 if $toplevel{"chooseort-$abk-$linetype"} && $do_close; 396 397 $file; # return filename 398} 399 400sub read_desc_file { 401 warn "Using .desc files is obsolete, please consider to switch to global in-file directives. See doc/bbd.pod for some information"; 402 my $desc_file = shift; 403 my $abk = shift; 404 @BBBike::ExtFile::scrollregion = (); 405 if (-r $desc_file && -f $desc_file) { 406 warn "Read $desc_file...\n" if $verbose; 407 require Safe; 408 #XXX problems! 409 #require Symbol; 410 #Symbol::delete_package("BBBike::ExtFile"); 411 my $compartment = new Safe("BBBike::ExtFile"); 412 if (defined $abk) { 413 $BBBike::ExtFile::abk = $BBBike::ExtFile::abk = $abk; 414 } 415 # $str_attrib and $p_attrib should be used in favour of 416 # %str_attrib and %p_attrib 417 my @shared_symbols = 418 qw(%line_width %line_length 419 %str_color %outline_color 420 %str_attrib %p_attrib 421 $str_attrib $p_attrib 422 %category_size %category_color %category_width %category_image 423 %category_stipple 424 ); 425 $compartment->share(@shared_symbols); 426 $compartment->rdo($desc_file); 427 warn $@ if $@; 428 no strict 'refs'; 429 for my $symbol (@shared_symbols) { 430 $symbol =~ s/^.//; 431 undef *{"BBBike::ExtFile::$symbol"}; 432 } 433 } 434} 435 436# e.g. from .desc files 437sub set_scrollregion { 438 my @in = @_; 439 @scrollregion = (transpose(@in[0,3]), transpose(@in[2,1])); 440 $c->configure(-scrollregion => \@scrollregion); 441} 442 443sub enlarge_scrollregion { 444 my @in = @_; 445 my @new_scrollregion = (transpose(@in[0,3]), transpose(@in[2,1])); 446 enlarge_transposed_scrollregion(@new_scrollregion); 447} 448 449sub enlarge_transposed_scrollregion { 450 my @new_scrollregion = @_; 451 $scrollregion[0] = $new_scrollregion[0] 452 if ($new_scrollregion[0] < $scrollregion[0]); 453 $scrollregion[1] = $new_scrollregion[1] 454 if ($new_scrollregion[1] < $scrollregion[1]); 455 $scrollregion[2] = $new_scrollregion[2] 456 if ($new_scrollregion[2] > $scrollregion[2]); 457 $scrollregion[3] = $new_scrollregion[3] 458 if ($new_scrollregion[3] > $scrollregion[3]); 459 $c->configure(-scrollregion => \@scrollregion); 460} 461 462sub _layer_tag_expr { 463 my $abk = shift; 464 "$abk || $abk-fg || $abk-img"; 465} 466 467sub enlarge_scrollregion_for_layer { 468 my $abk = shift; 469 IncBusy($top); 470 eval { 471 my(@bbox) = $c->bbox(_layer_tag_expr($abk)); 472 if (@bbox) { 473 enlarge_transposed_scrollregion(@bbox); 474 } else { 475 die "No bbox for tag $abk: maybe the layer is empty"; 476 } 477 }; 478 my $err = $@; 479 DecBusy($top); 480 if ($err) { 481 status_message($err, 'die'); 482 } 483} 484 485sub enlarge_scrollregion_from_descfile { 486 my $f = shift; 487 if (!defined $f) { 488 $f = $top->getOpenFile(-filetypes => [ 489 [M"Desc-Dateien", '.desc'], 490 [M"Alle Dateien", '*'], 491 ]); 492 } 493 if (defined $f) { 494 # XXX replace with handle_global_directives function 495 read_desc_file($f); 496 if (@BBBike::ExtFile::scrollregion) { 497 enlarge_scrollregion(@BBBike::ExtFile::scrollregion); 498 } 499 } 500} 501 502sub tk_plot_additional_layer { 503 my($linetype) = @_; 504 plot_additional_layer($linetype); 505} 506 507sub plot_additional_sperre_layer { 508 plot_additional_layer("sperre"); 509} 510 511# Called from last cmdline (initial layers) 512sub plot_additional_layer_cmdline { 513 my($layer_def, %args) = @_; 514 my($layer_type, $layer_filename); 515 if ($layer_def =~ m{^($LINETYPES_RX)=(.*)}) { 516 ($layer_type, $layer_filename) = ($1, $2); 517 } else { 518 519 ($layer_type, $layer_filename) = ('str', $layer_def); 520 } 521 plot_additional_layer($layer_type, $layer_filename, %args); 522} 523 524sub plot_additional_layer { 525 my($linetype, $file, %args) = @_; 526 my $abk = next_free_layer(); 527 if (!defined $abk) { 528 status_message(M"Keine Layer frei!", 'error'); 529 return; 530 } 531 if ($linetype eq 'sperre') { 532 $abk = "$abk-sperre"; 533 } 534 if ($linetype !~ /^$LINETYPES_RX$/) { 535#XXXdel $str_draw{$abk} = 1; 536# } elsif ($linetype eq 'p') { 537#XXXdel $p_draw{$abk} = 1; 538# } else { 539 die "Unknown linetype $linetype, should be str, sperre or p"; 540 } 541 warn "Use new Layer $abk\n"; 542 add_to_stack($abk, "before", "pp"); 543 544 my @args; 545 { 546 # "sperre" linetype should be "p" for drawing, but still "sperre" 547 # for the last loaded menu 548 my $linetype_for_menu = $linetype; 549 if ($linetype eq 'sperre') { 550 $linetype = 'p'; 551 } 552 $args{-retargs} = {}; 553 if (defined $file) { 554 custom_draw($linetype, $abk, $file, %args); 555 } else { 556 $file = custom_draw_dialog($linetype, $abk, undef, %args); 557 } 558 @args = %{ $args{-retargs} }; 559 push @args, -linetype => $linetype_for_menu; 560 } 561 562 if (defined $file) { 563 if ($linetype eq 'sperre' && $net) { 564 my $s = $p_obj{$abk} || Strassen->new($file); 565 $net->make_sperre($s, Type => "all"); 566 } 567 my $add_def; 568 if (@args) { 569 $add_def = "\t" . join "\t", @args; 570 } 571 add_last_loaded($file, $last_loaded_layers_obj, $add_def); 572 save_last_loaded($last_loaded_layers_obj); 573 } 574 575 Hooks::get_hooks("after_new_layer")->execute; 576 $abk; 577} 578 579sub additional_layer_dialog { 580 my(%args) = @_; 581 my $title = delete $args{-title} || M"Stra�en/Punkte ausw�hlen"; 582 my $cb = delete $args{-cb}; # callback for all layers 583 my $p_cb = delete $args{-pcb} || $cb; # callback for point layers 584 my $s_cb = delete $args{-scb} || $cb; # callback for street layers 585 my $token = delete $args{-token}; 586 587 my $t; 588 if (defined $token) { 589 $t = redisplay_top($top, $token, 590 -title => $title); 591 return if !defined $t; 592 } else { 593 $t = $top->Toplevel; 594 $t->title($title); 595 $t->transient($top) if $transient; 596 } 597 $t->geometry("300x400"); 598 require Tk::Pane; 599 my $f = $t->Scrolled("Pane", -scrollbars => "osoe", 600 -sticky => 'nw', 601 )->pack(-fill => "both", -expand => 1); 602 my($delete_pane,$fill_pane); 603 $delete_pane = sub { 604 $f->Walk(sub { 605 $_[0]->destroy 606 if (Tk::Exists($_[0]) && 607 ($_[0]->isa("Tk::Button") || $_[0]->isa("Tk::Label"))); 608 }); 609 }; 610 $fill_pane = sub { 611 my @pack_opts = qw(-fill x -expand 1 -anchor w); 612 my @b_opts = qw(-justify left -anchor w); 613 ## not sure if this is really necessary, we have at least the titlebar 614 #$f->Label(-text => $title, -font => $font{large}, @b_opts)->pack(@pack_opts); 615 for my $i (1..MAX_LAYERS) { 616 my $abk = "L$i"; 617 if ($str_draw{$abk}) { 618 $f->Button(-text => "Stra�en $abk ($str_file{$abk})", 619 @b_opts, 620 -command => sub { 621 $s_cb->($abk); 622 })->pack(@pack_opts); 623 } 624 if ($p_draw{$abk}) { 625 $f->Button(-text => "Punkte $abk ($p_file{$abk})", 626 @b_opts, 627 -command => sub { 628 $p_cb->($abk); 629 })->pack(@pack_opts); 630 } 631 if ($p_draw{"$abk-sperre"}) { 632 $f->Button(-text => "Sperrungen $abk (" . $p_file{"$abk-sperre"} . ")", 633 @b_opts, 634 -command => sub { 635 $p_cb->($abk . "-sperre"); 636 })->pack(@pack_opts); 637 } 638 } 639 }; 640 $fill_pane->(); 641 642 $t->Button(Name => "close", 643 -command => sub { 644 $t->destroy; 645 })->pack(-anchor => "w"); 646 647 my $tpath = $t->PathName; 648 for my $hook (qw(after_new_layer after_delete_layer)) { 649 Hooks::get_hooks($hook)->add 650 (sub { $delete_pane->(); $fill_pane->() }, $tpath); 651 } 652 $t->OnDestroy 653 (sub { 654 for my $hook (qw(after_new_layer after_delete_layer)) { 655 Hooks::get_hooks($hook)->del($tpath); 656 } 657 }); 658} 659 660sub select_layers_for_net_dialog { 661 my $t = $top->Toplevel; 662 $t->title(M("Layer ausw�hlen")); 663 $t->transient($top) if $transient; 664 $t->geometry("300x400"); 665 require Tk::Pane; 666 my $f = $t->Scrolled("Pane", -scrollbars => "osoe", 667 -sticky => 'nw', 668 )->pack(-fill => "both", -expand => 1); 669 670 my %_custom_net_str = %custom_net_str; 671 for my $i (1..MAX_LAYERS) { 672 my $abk = "L$i"; 673 if ($str_draw{$abk}) { 674 $f->Checkbutton(-text => "Stra�en $abk ($str_file{$abk})", 675 -variable => \$_custom_net_str{$abk}, 676 )->pack(-anchor => "w"); 677 } 678 } 679 680 my $wait = 0; 681 { 682 my $f = $t->Frame->pack(-fill => "x"); 683 $f->Button(Name => "ok", 684 -command => sub { 685 $wait = +1; 686 })->pack(-side => "left"); 687 $f->Button(Name => "close", 688 -command => sub { 689 $wait = -1; 690 })->pack(-side => "left"); 691 } 692 $t->OnDestroy(sub { $wait = -1 }); 693 $t->waitVariable(\$wait); 694 if ($wait > 0) { 695 my $changed = 0; 696 while(my($k,$v) = each %_custom_net_str) { 697 $changed++ if $custom_net_str{$k} != $v; 698 $custom_net_str{$k} = $v; 699 } 700 make_net() if $changed; 701 } 702 $t->destroy if Tk::Exists($t); 703} 704 705# XXX missing "sperre" layer types 706sub choose_from_additional_layer { 707 additional_layer_dialog 708 (-title => M"Stra�en/Punkte ausw�hlen", 709 -scb => sub { 710 my $abk = shift; 711 choose_ort('s', $abk, -rebuild => 1); 712 }, 713 -pcb => sub { 714 my $abk = shift; 715 choose_ort('p', $abk, -rebuild => 1); 716 }, 717 -token => 'choose_from_additional_layer', 718 ); 719} 720 721sub delete_additional_layer { 722 my $t = $top->Toplevel; 723 my $tpath = $t->PathName; 724 $t->title(M"Zus�tzliche Layer l�schen"); 725 $t->transient($top) if $transient; 726 $t->geometry("300x400"); 727 require Tk::Pane; 728 my $f = $t->Scrolled("Pane", -scrollbars => "osoe", 729 -sticky => 'nw', 730 )->pack(-fill => "both", -expand => 1); 731 732 my($delete_pane,$fill_pane); 733 $delete_pane = sub { 734 $f->Walk(sub { 735 $_[0]->destroy 736 if (Tk::Exists($_[0]) && 737 ($_[0]->isa("Tk::Button") || $_[0]->isa("Tk::Label"))); 738 }); 739 }; 740 $fill_pane = sub { 741 my $seen = 0; 742 for my $i (1..MAX_LAYERS) { 743 my $abk = "L$i"; 744 if ($str_draw{$abk} || $p_draw{$abk} || $p_draw{"$abk-sperre"}) { 745 my(@files); 746 push @files, $str_file{$abk} if $str_file{$abk}; 747 push @files, $p_file{$abk} if $p_file{$abk}; 748 push @files, $p_file{"$abk-sperre"} if $p_file{"$abk-sperre"}; 749 my $files = ""; 750 if (@files) { 751 $files = "(" .join(",", @files) . ")"; 752 } 753 $f->Button 754 (-text => "Layer $abk $files", 755 -command => sub { 756 delete_layer_without_hooks($abk); 757 $f->after(20, sub { 758 $delete_pane->(); 759 $fill_pane->(); 760 Hooks::get_hooks("after_delete_layer")->execute_except($tpath); 761 }); 762 })->pack(-anchor => "w"); 763 $seen++; 764 } 765 } 766 if (!$seen) { 767 $f->Label(-text => M"Keine zus�tzlichen Layer vorhanden")->pack(-anchor => "w"); 768 } 769 }; 770 771 $fill_pane->(); 772 $t->Button(Name => "close", 773 -command => sub { 774 $t->destroy; 775 })->pack(-anchor => "w"); 776 777 for my $hook (qw(after_new_layer after_delete_layer)) { 778 Hooks::get_hooks($hook)->add 779 (sub { $delete_pane->(); $fill_pane->() }, $tpath); 780 } 781 $t->OnDestroy 782 (sub { 783 for my $hook (qw(after_new_layer after_delete_layer)) { 784 Hooks::get_hooks($hook)->del($tpath); 785 } 786 }); 787 788} 789 790sub delete_layer_without_hooks { 791 my($abk) = @_; 792 if ($str_draw{$abk}) { 793 $str_draw{$abk} = 0; 794 plot('str',$abk); 795 plot('str',$abk,Canvas => $overview_canvas,-draw => 0) if $overview_canvas; 796 delete $str_file{$abk}; 797 delete $str_obj{$abk}; 798 } 799 if ($p_draw{$abk}) { 800 $p_draw{$abk} = 0; 801 plot('p',$abk); 802 # XXX overview canvas? 803 delete $p_file{$abk}; 804 delete $p_obj{$abk}; 805 } 806 if ($p_draw{"$abk-sperre"}) { 807 $p_draw{"$abk-sperre"} = 0; 808 plot('p',"$abk-sperre"); 809 # XXX overview canvas? 810 delete $p_file{"$abk-sperre"}; 811 # XXX This should also undo the net changes 812 } 813} 814 815sub delete_layer { 816 my($abk) = @_; 817 delete_layer_without_hooks($abk); 818 Hooks::get_hooks("after_delete_layer")->execute; 819} 820 821sub tk_draw_layer_in_overview { 822 additional_layer_dialog 823 (-title => M"Layer in �bersichtskarte zeichnen", 824 -cb => sub { 825 my $abk = shift; 826 draw_layer_in_overview($abk); 827 }, 828 -token => 'choose_from_additional_layer', 829 ); 830} 831 832sub draw_layer_in_overview { 833 my $abk = shift; 834 if (!$overview_canvas) { 835 # XXX maybe remember for later instead 836 status_message(M"Die �bersichtskarte ist noch nicht verf�gbar.", "info"); 837 return; 838 } 839 # XXX support for point layers missing 840 plotstr($abk, 841 Canvas => $overview_canvas, 842 ); 843 # XXX it's not possible to remove layers! 844} 845 846sub tk_zoom_view_for_layer { 847 additional_layer_dialog 848 (-title => M"Ausschnitt an Layer anpassen", 849 -cb => sub { 850 my $abk = shift; 851 zoom_view_for_layer($abk); 852 }, 853 -token => 'choose_from_additional_layer', 854 ); 855} 856 857sub zoom_view_for_layer { 858 my $abk = shift; 859 IncBusy($top); 860 eval { 861 my(@bbox) = $c->bbox(_layer_tag_expr($abk)); 862 if (@bbox) { 863 zoom_view(@bbox); 864 } else { 865 die "No bbox for tag $abk: maybe the layer is empty"; 866 } 867 }; 868 my $err = $@; 869 DecBusy($top); 870 if ($err) { 871 status_message($err, 'die'); 872 } 873} 874 875sub tk_set_scrollregion_for_layer { 876 additional_layer_dialog 877 (-title => M"Scrollregion an Layer anpassen", 878 -cb => sub { 879 my $abk = shift; 880 set_scrollregion_for_layer($abk); 881 }, 882 -token => 'choose_from_additional_layer', 883 ); 884} 885 886sub set_scrollregion_for_layer { 887 my $abk = shift; 888 IncBusy($top); 889 eval { 890 my(@bbox) = $c->bbox(_layer_tag_expr($abk)); 891 if (@bbox) { 892 @scrollregion = @bbox; 893 $c->configure(-scrollregion => [@scrollregion]); 894 } else { 895 die "No bbox for tag $abk: maybe the layer is empty"; 896 } 897 }; 898 my $err = $@; 899 DecBusy($top); 900 if ($err) { 901 status_message($err, 'die'); 902 } 903} 904 905sub tk_enlarge_scrollregion_for_layer { 906 additional_layer_dialog 907 (-title => M"Scrollregion f�r Layer vergr��ern", 908 -cb => sub { 909 my $abk = shift; 910 enlarge_scrollregion_for_layer($abk); 911 }, 912 -token => 'choose_from_additional_layer', 913 ); 914} 915 916sub change_datadir { 917 require Tk::DirTree; 918 my $t = $top->Toplevel; 919 $t->title(M"Neues Datenverzeichnis w�hlen"); 920 my $newdir = $datadir; 921 my $ok = 0; 922 my $f = $t->Frame->pack(-fill => "x", -side => "bottom"); 923 my $d = $t->Scrolled('DirTree', 924 -scrollbars => 'osoe', 925 -width => 35, 926 -height => 20, 927 -selectmode => 'browse', 928 -exportselection => 1, 929 -browsecmd => sub { $newdir = shift }, 930 -command => sub { $ok = 1 }, 931 )->pack(-fill => "both", -expand => 1); 932 $d->chdir($newdir); 933 $f->Button(Name => 'ok', 934 -command => sub { $ok = 1 })->pack(-side => 'left'); 935 $f->Button(Name => 'cancel', 936 -command => sub { $ok = -1 })->pack(-side => 'left'); 937 $f->waitVariable(\$ok); 938 if ($ok == 1) { 939 set_datadir($newdir); 940 } 941 $t->destroy; 942} 943 944use vars qw($standard_command_index $editstandard_command_index 945 @edit_mode_any_cmd); 946 947$without_zoom_factor = 1 if !defined $without_zoom_factor; 948 949sub set_coord_interactive { 950 my $t = redisplay_top($top, 'set_coord_interactive', 951 -title => M"Punktkoordinaten setzen"); 952 return if !defined $t; 953 954 my $fill_coordsystem_list; 955 my $use_full_coordsystem_list = 0; 956 957 my $coord_menu; 958 my $coord_output = $coord_output; 959 { 960 require Tk::Optionmenu; 961 my $f = $t->Frame->pack(-anchor => "w", -fill => "x"); 962 $f->Label(-text => M("Koordinatensystem").":")->pack(-side => "left"); 963 $coord_menu = $f->Optionmenu(-variable => \$coord_output, 964 )->pack(-side => "left", -fill => "x"); 965 $fill_coordsystem_list = sub { 966 my @coordsystem_list = ((map { [ $Karte::map{$_}->name, $_ ] } @Karte::map), "canvas"); 967 if (!$use_full_coordsystem_list) { 968 @coordsystem_list = grep { 969 ref $_ eq 'ARRAY' && 970 $_->[1] =~ /^(polar|standard|gps|gdf)$/; 971 } @coordsystem_list; 972 } 973 $coord_menu->configure(-options => [ @coordsystem_list ]); 974 }; 975 $fill_coordsystem_list->(); 976 } 977 { 978 my $f = $t->Frame->pack(-anchor => "w", -fill => "x"); 979 $f->Checkbutton(-text => "erweiterte Liste", 980 -variable => \$use_full_coordsystem_list, 981 -command => $fill_coordsystem_list, 982 )->pack(-side => "right"); 983 } 984 985 my($valx, $valy); 986 my(%val2, %val3); 987 my $set_sub = sub { 988 my($orig) = @_; 989 if ($orig == 2) { 990 require Karte::Polar; 991 $valx = Karte::Polar::dms2ddd($val2{'X'}->[0], $val2{'X'}->[1], $val2{'X'}->[2]); 992 $valy = Karte::Polar::dms2ddd($val2{'Y'}->[0], $val2{'Y'}->[1], $val2{'Y'}->[2]); 993 } elsif ($orig == 3) { 994 require Karte::Polar; 995 $valx = Karte::Polar::dmm2ddd($val3{'X'}->[0], $val3{'X'}->[1]); 996 $valy = Karte::Polar::dmm2ddd($val3{'Y'}->[0], $val3{'Y'}->[1]); 997 } 998 my($setx, $sety); 999 if ($coord_output eq 'canvas') { 1000 ($setx, $sety) = ($valx, $valy); 1001 } else { 1002 ($setx, $sety) = transpose($Karte::map{$coord_output}->map2standard($valx, $valy)); 1003 } 1004 mark_point('-x' => $setx, '-y' => $sety, 1005 -clever_center => 1); 1006 }; 1007 1008 my $f1 = $t->Frame->pack(-anchor => "w"); 1009 my $lx = $f1->Label(-text => "X:"); 1010 my $ex = $f1->Entry(-textvariable => \$valx); 1011 my $ly = $f1->Label(-text => "Y:"); 1012 my $ey = $f1->Entry(-textvariable => \$valy); 1013 my $get_selection_sub = sub { 1014 my $interactive = shift; 1015 1016 my $error_msg = sub { 1017 my $msg = shift; 1018 if ($interactive) { 1019 $f1->messageBox(-icon => "error", 1020 -message => $msg); 1021 } else { 1022 warn $msg; 1023 } 1024 }; 1025 1026 my $s; 1027 Tk::catch { 1028 $s = $f1->SelectionGet('-selection' => ($os eq 'win' 1029 ? "CLIPBOARD" 1030 : "PRIMARY")); 1031 }; 1032 if (defined $s && $s =~ /^\s*([NS]\d+\s+\d+\s+[\d\.]+) 1033 \s+([EW]\d+\s+\d+\s+[\d\.]+) 1034 \s*$ 1035 /x) { 1036 my($lat,$long) = ($1, $2); 1037 require Karte::Polar; 1038 my $y = Karte::Polar::dms_string2ddd($lat); 1039 my $x = Karte::Polar::dms_string2ddd($long); 1040 if (defined $x && defined $y) { 1041 ($valx, $valy) = ($x, $y); 1042 $set_sub->(1); 1043 } else { 1044 $error_msg->("Can't parse selection $s"); 1045 } 1046 } elsif (defined $s and $s =~ /\d/) { 1047 $s =~ s/^[^\d.+-]+//; 1048 $s =~ s/[^\d.+-]+$//; 1049 my($x,$y) = split(/[^\d.+-]+/, $s); 1050 if (defined $x and defined $y) { 1051 ($valx, $valy) = ($x, $y); 1052 $set_sub->(1); 1053 } else { 1054 $error_msg->("Can't parse selection $s"); 1055 } 1056 } else { 1057 $error_msg->("No useable selection"); 1058 } 1059 }; 1060 my $selb = $f1->Button 1061 (-text => M"Selection", 1062 -command => sub { $get_selection_sub->(1) }); 1063 my $sb = $f1->Button(-text => M"Setzen", 1064 -command => sub { $set_sub->(1) }, 1065 ); 1066 my $autocheck = 0; 1067 my $acb; 1068 my $auto_sub = sub { 1069 $get_selection_sub->(0); 1070 $set_sub->(1); 1071 $f1->after(100, sub { 1072 $acb->invoke; 1073 $acb->invoke; 1074 }); 1075 }; 1076 $acb = $f1->Checkbutton 1077 (-text => M"Auto-detect", 1078 -variable => \$autocheck, 1079 -command => sub { 1080 if ($autocheck) { 1081 $f1->SelectionOwn(-command => $auto_sub); 1082 # Hack to reinstall SelectionOwn handler 1083 } else { 1084 $f1->SelectionOwn; 1085 } 1086 }); 1087 1088 $lx->grid($ex, $selb, $acb); 1089 $ly->grid($ey, $sb); 1090 $ex->focus; 1091 1092 my $polar_f; 1093 { 1094 my $f = $polar_f = $t->Frame->pack(-anchor => "w"); 1095 for my $def (["DMS", 2], 1096 ["DMM", 3], 1097 ) { 1098 my($dms_type, $set_sub_type) = @$def; 1099 my $ff = $polar_f->Frame->pack(-anchor => "w"); 1100 my %label = ('Y' => M"geog. Breite ($dms_type)", 1101 'X' => M"geog. L�nge ($dms_type)", 1102 ); 1103 for my $ord ('Y', 'X') { 1104 my @e2; 1105 push @e2, $ff->Label(-text => $label{$ord} . ":"); 1106 if ($dms_type eq 'DMS') { 1107 for my $i (0 .. 2) { 1108 push @e2, $ff->Entry(-textvariable => \$val2{$ord}->[$i], 1109 # seconds: place for decimal and one digit after decimal 1110 -width => ($i == 2 ? 4 : 2)); 1111 if ($i == 0) { 1112 push @e2, $ff->Label(-text => "�"); 1113 } elsif ($i == 1) { 1114 push @e2, $ff->Label(-text => "'"); 1115 } elsif ($i == 2) { 1116 push @e2, $ff->Label(-text => "\""); 1117 if ($ord eq 'X') { 1118 push @e2, $ff->Button(-text => M"Setzen", 1119 -command => sub { $set_sub->($set_sub_type) }, 1120 ); 1121 } 1122 } 1123 } 1124 } else { 1125 push @e2, $ff->Entry(-textvariable => \$val3{$ord}->[0], 1126 -width => 2); 1127 push @e2, $ff->Label(-text => "�"); 1128 push @e2, $ff->Entry(-textvariable => \$val3{$ord}->[1], 1129 -width => 6); 1130 push @e2, $ff->Label(-text => "'"); 1131 if ($ord eq 'X') { 1132 push @e2, $ff->Button(-text => M"Setzen", 1133 -command => sub { $set_sub->($set_sub_type) }, 1134 ); 1135 } 1136 } 1137 my $first = shift @e2; 1138 $first->grid(@e2); 1139 } 1140 } 1141 } 1142 1143 { 1144 # combined: 1145 # www.berliner-stadtplan.com, www.berlinonline.de 1146 1147 my $f = $t->Frame->pack(-anchor => "w", -fill => "x"); 1148 $f->Label(-text => M"Stadtplan-URL")->pack(-side => "left"); 1149 my $url; 1150 $f->Entry(-textvariable => \$url)->pack(-side => "left", -fill => "x", -expand => 1); 1151 $f->Button 1152 (-text => M"Selection", 1153 -command => sub { 1154 Tk::catch { 1155 $url 1156 = $f1->SelectionGet('-selection' => ($os eq 'win' 1157 ? "CLIPBOARD" 1158 : "PRIMARY")); 1159 $url =~ s/\n//g; 1160 }; 1161 })->pack(-side => "left"); 1162 $f->Button 1163 (-text => M"Setzen", 1164 -command => sub { 1165 my $ret = parse_url_for_coords($url); 1166 my($x_s, $y_s, $x_ddd, $y_ddd) = @{$ret}{qw(x_s y_s x_ddd y_ddd)}; 1167 if (defined $x_s) { 1168 my($tx,$ty) = transpose($x_s, $y_s); 1169 mark_point('-x' => $tx, '-y' => $ty, -clever_center => 1); 1170 } 1171 if (defined $x_ddd) { 1172 $coord_output = "polar"; 1173 $coord_menu->setOption('polar'); # XXX $Karte::map{'polar'}->name); #XXX should be better in Tk 1174 $valx = $x_ddd; 1175 $valy = $y_ddd; 1176 } 1177 })->pack(-side => "left"); 1178 } 1179 1180 my $coord_menu_sub = sub { 1181 if ($coord_output eq 'polar') { 1182 $polar_f->Walk(sub { eval { $_[0]->configure(-state => "normal") } }); 1183 } else { 1184 $polar_f->Walk(sub { eval { $_[0]->configure(-state => "disabled") } }); 1185 } 1186 }; 1187 1188 $coord_menu->configure(-command => $coord_menu_sub); 1189 $coord_menu_sub->(); 1190 1191 $t->Popup(@popup_style); 1192} 1193 1194sub parse_url_for_coords { 1195 my($url, %args) = @_; 1196 my $q = $args{quiet}; 1197 my($x_ddd, $y_ddd); # polar/DDD 1198 my($x_s, $y_s); # BBBike coordinates 1199 if (0 && $url =~ m{gps=(\d+)%7C(\d+)}) { 1200 # XXX passt nicht ... 1201 my($x, $y) = ($1, $2); 1202 require Karte::Polar; 1203 $x_ddd = 13 + $x/10000; 1204 $y_ddd = 52 + $y/10000; 1205 warn "$x $y $x_ddd $y_ddd"; 1206 } elsif ($url =~ m{x_wgs/(.*?)/y_wgs/(.*?)/} || # berliner-stadtplan old 1207 $url =~ m{x_wgs=(.*?)[&;]y_wgs=([\.\d]+)} 1208 ) { 1209 my($x, $y) = ($1, $2); 1210 require Karte::Polar; 1211 $x_ddd = Karte::Polar::dmm2ddd(13, $x); 1212 $y_ddd = Karte::Polar::dmm2ddd(52, $y); 1213 } elsif ($url =~ m{x_wgsv=([\d\.]+)&y_wgsv=([\d\.]+)}) { # berliner-stadtpan new (2007-07-24) 1214 ($x_ddd, $y_ddd) = ($1, $2); 1215 } elsif ($url =~ m{/gps_x/(\d+),(\d+)/gps_y/(\d+),(\d+)}) { # berliner-stadtplan24 (ca. 2007-08-10) 1216 ($x_ddd, $y_ddd) = ($1.".".$2, $3.".".$4); 1217 } elsif ($url =~ /ADR_ZIP=(\d+)&ADR_STREET=(.+?)&ADR_HOUSE=(.*)/) { 1218 my($zip, $street, $hnr) = ($1, $2, $3); 1219 local @INC = @INC; 1220 push @INC, "$FindBin::RealBin/miscsrc"; 1221 require TelbuchDBApprox; 1222 my $tb = TelbuchDBApprox->new(-approxhnr => 1); 1223 my(@res) = $tb->search("$street $hnr", $zip); 1224 if (!@res) { 1225 return if $q; 1226 status_message(M("Kein Ergebnis gefunden"), "die"); 1227 } 1228 ($x_s,$y_s) = split /,/, $res[0]->{Coord}; 1229 } elsif ($url =~ /params=(\d+)_(\d+)_(?:([\d\.]+)_)?([NS])_(\d+)_(\d+)_(?:([\d\.]+)_)?([EW])/) { # wikipedia mapsources, deg min (sec) 1230 $y_ddd = $1 + $2/60 + $3/3600; 1231 $y_ddd *= -1 if $4 eq 'S'; 1232 $x_ddd = $5 + $6/60 + $7/3600; 1233 $x_ddd *= -1 if $8 eq 'W'; 1234 } elsif ($url =~ /params=(\d+)\.(\d+)_([NS])_(\d+)\.(\d+)_([EW])/) { # wikipedia mapsources, decimal degrees 1235 $y_ddd = sprintf "%s.%s", $1, $2; 1236 $y_ddd *= -1 if $3 eq 'S'; 1237 $x_ddd = sprintf "%s.%s", $4, $5; 1238 $x_ddd *= -1 if $6 eq 'W'; 1239 } elsif ($url =~ m{[\?&]ll=([0-9.]+),([0-9.]+)}) { # google maps 1240 $x_ddd = $2; 1241 $y_ddd = $1; 1242 } elsif ($url =~ m{ll=([0-9.]+),([0-9.]+)}) { 1243 $x_ddd = $2; 1244 $y_ddd = $1; 1245 } elsif ($url =~ /LL=%2B([0-9.]+)%2B([0-9.]+)/) { 1246 $x_ddd = $2; 1247 $y_ddd = $1; 1248 } elsif ($url =~ /lat=([0-9.]+).*long?=([0-9.]+)/) { # e.g. goyellow.de 1249 $x_ddd = $2; 1250 $y_ddd = $1; 1251 } elsif ($url =~ /long?=([0-9.]+).*lat=([0-9.]+)/) { # e.g. goyellow.de new 1252 $x_ddd = $1; 1253 $y_ddd = $2; 1254 } elsif ($url =~ /cp=([0-9.]+)~([0-9.]+)&/) { # e.g. maps.live.com 1255 $x_ddd = $2; 1256 $y_ddd = $1; 1257 } elsif ($url =~ /lt=([0-9.]+)&ln=([0-9.]+)/) { # e.g. www.panoramio.com 1258 $x_ddd = $2; 1259 $y_ddd = $1; 1260 } 1261 1262 if (defined $x_ddd && defined $y_ddd) { 1263 ($x_s,$y_s) = $Karte::Polar::obj->map2standard($x_ddd, $y_ddd); 1264 } elsif (defined $x_s && defined $y_s) { 1265 ($x_ddd,$y_ddd) = $Karte::Polar::obj->standard2map($x_s, $y_s); 1266 } 1267 1268 return if (!defined $x_s); 1269 1270 return { x_ddd => $x_ddd, 1271 y_ddd => $y_ddd, 1272 x_s => $x_s, 1273 y_s => $y_s, 1274 }; 1275} 1276 1277sub set_line_coord_interactive { 1278 my(%args) = @_; 1279 if (!defined $coord_output || 1280 !$Karte::map{$coord_output}) { 1281 die M"Karte-Objekt nicht definiert... Aus/Eingabe richtig setzen!\n"; 1282 return; 1283 } 1284 1285 my $t = redisplay_top($top, 'set_line_coord_interactive', 1286 -title => M"Linienkoordinaten setzen", 1287 -geometry => $args{-geometry}, 1288 ); 1289 return if !defined $t; 1290 1291 my $map = "auto-detect"; 1292 1293 my $set_sub = sub { 1294 my(@mark_args) = @_; 1295 my @coords = (); 1296 my @selection_types = ('PRIMARY', 'CLIPBOARD'); 1297 if ($os eq 'win') { 1298 @selection_types = ('CLIPBOARD'); 1299 } 1300 for my $selection_type (@selection_types) { 1301 my $s = eval { $t->SelectionGet('-selection' => $selection_type) }; 1302 next if $@; 1303 if ($map eq 'postgis') { 1304 while ($s =~ /(?:MULTI)?(?:POINT|LINESTRING|POLYGON)\(([\d \.\)\(,]+)\)/g) { 1305 (my $coords = $1) =~ s{\),\(}{,}g; 1306 $coords =~ s{[\(\)]}{}g; 1307 my @_coords = split /,/, $coords; 1308 for (@_coords) { 1309 my($x, $y) = split / /, $_; 1310 push @coords, [$x,$y]; # XXX assume always standard coordinates here, maybe should also auto-detect? 1311 } 1312 } 1313 } else { 1314 # DDD or BBBike coordinates 1315 while ($s =~ /([-+]?[0-9\.]+),([-+]?[0-9\.]+)/g) { 1316 my($x,$y) = ($1,$2); 1317 my $_map = $map; 1318 if ($map eq 'auto-detect') { 1319 if ($x =~ m{\.} && $y =~ m{\.} && $x <= 180 && $x >= -180 && $y <= 90 && $y >= -90) { 1320 $_map = "polar"; 1321 } else { 1322 $_map = "standard"; 1323 } 1324 } 1325 if ($_map eq 'polar') { 1326 ($x,$y) = $Karte::Standard::obj->trim_accuracy($Karte::Polar::obj->map2standard($x,$y)); 1327 } 1328 push @coords, [$x,$y]; 1329 } 1330 1331 # DMS coordinates with trailing NESW 1332 while ($s =~ m{(\d+)�(\d+)'(\d+(?:\.\d+)?)"([NS]).*?(\d+)�(\d+)'(\d+(?:\.\d+)?)"([EW])}g) { 1333 # sigh, it seems that I have to use the ugly $1...$8 list :-( 1334 my($lat_deg,$lat_min,$lat_sec,$lat_sgn, 1335 $lon_deg,$lon_min,$lon_sec,$lon_sgn) = ($1,$2,$3,$4,$5,$6,$7,$8); 1336 my $lat = $lat_deg + $lat_min/60 + $lat_sec/3600; 1337 $lat *= -1 if $lat_sgn =~ m{s}i; 1338 my $lon = $lon_deg + $lon_min/60 + $lon_sec/3600; 1339 $lon *= -1 if $lon_sgn =~ m{w}i; 1340 my($x,$y) = $Karte::Standard::obj->trim_accuracy($Karte::Polar::obj->map2standard($lon,$lat)); 1341 push @coords, [$x,$y]; 1342 } 1343 1344 # DMM coordinates with preceding NESW 1345 while ($s =~ m{([NS])(\d+)�\s*([\d\.]+).*?([EW])(\d+)�\s*([\d\.]+)}g) { 1346 my($lat_sgn,$lat_deg,$lat_min, 1347 $lon_sgn,$lon_deg,$lon_min) = ($1,$2,$3,$4,$5,$6); 1348 my $lat = $lat_deg + $lat_min/60; 1349 $lat *= -1 if $lat_sgn =~ m{s}i; 1350 my $lon = $lon_deg + $lon_min/60; 1351 $lon *= -1 if $lon_sgn =~ m{w}i; 1352 my($x,$y) = $Karte::Standard::obj->trim_accuracy($Karte::Polar::obj->map2standard($lon,$lat)); 1353 push @coords, [$x,$y]; 1354 } 1355 1356 # OSM XML snippets 1357 while ($s =~ m{(?: 1358 \blat="([^"]+)"\s+lon="([^"]+)" 1359 | \blon="([^"]+)"\s+lat="([^"]+)" 1360 )}xg) { 1361 my($x,$y); 1362 if (defined $1) { # lat-lon detected 1363 ($y,$x) = ($1,$2); 1364 } else { # lon-lat detected 1365 ($x,$y) = ($1,$2); 1366 } 1367 ($x,$y) = $Karte::Standard::obj->trim_accuracy($Karte::Polar::obj->map2standard($x,$y)); 1368 push @coords, [$x, $y]; 1369 } 1370 } 1371 last if (@coords); # otherwise try the other selection type 1372 } 1373 if (!@coords) { 1374 warn "No coordinates found in any of the selections"; 1375 return; 1376 } 1377 my @line_coords; 1378 foreach (@coords) { 1379 my($valx,$valy) = @$_; 1380 my($setx, $sety) = transpose($Karte::map{$coord_output}->map2standard($valx, $valy)); 1381 push @line_coords, [$setx, $sety]; 1382 } 1383 mark_street(-coords => \@line_coords, 1384 -type => 's', 1385 @mark_args, 1386 ); 1387 }; 1388 1389 my $b = $t->Button 1390 (-text => M("Selection setzen") . " (F11)", 1391 -command => sub { 1392 $set_sub->(-clever_center => 1); 1393 })->pack; 1394 $b->bind("<3>" => sub { 1395 $set_sub->(-dont_center => 1); 1396 }); 1397 $top->bind("<F11>" => sub { $b->invoke }); 1398 1399 $t->Label(-text => "Koordinatensystem:")->pack(-anchor => "w"); 1400 $t->Radiobutton(-variable => \$map, 1401 -value => "auto-detect", 1402 -text => "Auto-detect")->pack(-anchor => "w"); 1403 $t->Radiobutton(-variable => \$map, 1404 -value => "standard", 1405 -text => "Standard (BBBike)")->pack(-anchor => "w"); 1406 $t->Radiobutton(-variable => \$map, 1407 -value => "polar", 1408 -text => "WGS 84")->pack(-anchor => "w"); 1409 $t->Radiobutton(-variable => \$map, 1410 -value => "postgis", 1411 -text => "PostGIS-styled")->pack(-anchor => "w"); 1412} 1413 1414sub coord_to_markers_dialog { 1415 my(%args) = @_; 1416 my $t = redisplay_top($top, 'coord_to_markers_dialog', 1417 -title => M"Koordinaten aus Selection", 1418 -geometry => $args{-geometry}, 1419 ); 1420 return if !defined $t; 1421 1422 my @marker_points; 1423 my $marker_points_no = 0; 1424 my $orig_steady_mark = $steady_mark; 1425 $steady_mark = 1; 1426 my $cur_index = 0; 1427 1428 my $update_marker_points = sub { 1429 $marker_points_no = scalar @marker_points; 1430 if ($marker_points_no == 0) { 1431 delete_markers(); 1432 } else { 1433 my @transposed_marker_points; 1434 for (@marker_points) { 1435 my($tx,$ty) = transpose($_->[0][0], $_->[0][1]); 1436 push @transposed_marker_points, [[$tx,$ty]]; 1437 } 1438 mark_street(-coords => \@transposed_marker_points, 1439 ## I think I prefer centering to the last point 1440 #-clever_center => 1, 1441 ); 1442 } 1443 }; 1444 1445 my $center_to_point = sub { 1446 my($index) = @_; 1447 my($tx,$ty) = transpose($marker_points[$index]->[0][0], 1448 $marker_points[$index]->[0][1]); 1449 mark_point(-point => "$tx,$ty", 1450 -dont_mark => 1); 1451 }; 1452 1453 my $repeater; 1454 my $last_sel; 1455 $repeater = $t->repeat 1456 (1000, sub { 1457 if (!Tk::Exists($t)) { 1458 $repeater->cancel; 1459 return; 1460 } 1461 my $s; 1462 Tk::catch { 1463 $s = $t->SelectionGet('-selection' => ($os eq 'win' 1464 ? "CLIPBOARD" 1465 : "PRIMARY")); 1466 }; 1467 if (defined $s) { 1468 return if (defined $last_sel && $s eq $last_sel); 1469 $last_sel = $s; 1470 my $ret = parse_url_for_coords($s, quiet => 1); 1471 if ($ret) { 1472 push @marker_points, [[$ret->{x_s}, $ret->{y_s}]]; 1473 $update_marker_points->(); 1474 } else { 1475 if ($verbose && $verbose >= 2) { 1476 warn "Can't parse coords in url <$s>\n"; 1477 } 1478 } 1479 } 1480 }); 1481 1482 Tk::grid($t->Label(-text => M("Punkte erkannt").":"), 1483 $t->Label(-textvariable => \$marker_points_no), 1484 -sticky => "ew"); 1485 Tk::grid($t->Button(-text => M"Letzten Punkt l�schen", 1486 -command => sub { 1487 pop @marker_points if @marker_points; 1488 $update_marker_points->(); 1489 }, 1490 ), 1491 -columnspan => 2, 1492 -sticky => "ew"); 1493 Tk::grid($t->Button(-text => M"Reset", 1494 -command => sub { 1495 @marker_points = (); 1496 $cur_index = 0; 1497 $update_marker_points->(); 1498 }, 1499 ), 1500 -columnspan => 2, 1501 -sticky => "ew"); 1502 { 1503 my $f; 1504 Tk::grid($f = $t->Frame, 1505 -columnspan => 2, 1506 -sticky => "ew"); 1507 $f->Button(-text => "<<", 1508 -command => sub { 1509 return if !@marker_points; 1510 $cur_index--; 1511 if ($cur_index < 0) { 1512 $cur_index = $#marker_points; 1513 } 1514 $center_to_point->($cur_index); 1515 }, 1516 )->pack(-side => "left", -fill => "x"); 1517 $f->Button(-text => ">>", 1518 -command => sub { 1519 return if !@marker_points; 1520 $cur_index++; 1521 if ($cur_index > $#marker_points) { 1522 $cur_index = 0; 1523 } 1524 $center_to_point->($cur_index); 1525 }, 1526 )->pack(-side => "left", -fill => "x"); 1527 $f->Label(-text => "Index:")->pack(-side => "left"); 1528 $f->Label(-textvariable => \$cur_index)->pack(-side => "left"); 1529 } 1530 Tk::grid($t->Button(-text => M"Dump to STDERR", 1531 -command => sub { 1532 print STDERR join("\n", map { join(" ", map { join(",", map { int } @$_) } @$_) } @marker_points), "\n"; 1533 }, 1534 ), 1535 -columnspan => 2, 1536 -sticky => "ew"); 1537 Tk::grid($t->Button(Name => "close", 1538 -command => sub { 1539 $t->destroy; 1540 }, 1541 ), 1542 -columnspan => 2, 1543 -sticky => "ew"); 1544 $t->OnDestroy(sub { $steady_mark = $orig_steady_mark; }); 1545} 1546 1547sub add_search_menu_entries { 1548 my $sbm = shift; 1549 $sbm->checkbutton(-label => M"Such-Statistik", 1550 -variable => \$search_stat); 1551 $sbm->checkbutton(-label => M"Visual Search", 1552 -variable => \$search_visual, 1553 -command => sub { 1554 if (!$search_visual) { 1555 $c->delete("visual"); 1556 } 1557 }); 1558 my $search_algorithm = $global_search_args{'Algorithm'} || "A*"; 1559 $sbm->cascade(-label => M"Algorithmus"); 1560 { 1561 my $asbm = $sbm->Menu(-title => M"Algorithmus"); 1562 $sbm->entryconfigure("last", -menu => $asbm); 1563 foreach my $a ('A*', 'C-A*', 'C-A*-2', 'srt') { 1564 $asbm->radiobutton 1565 (-label => $a, 1566 -variable => \$search_algorithm, 1567 -value => $a, 1568 -command => sub { 1569 my $old_search_algo = $global_search_args{'Algorithm'}; 1570 $global_search_args{'Algorithm'} = $search_algorithm; 1571 if ($net) { 1572 if ( ($search_algorithm =~ /^C-A\*-2/ && 1573 $old_search_algo !~ /^C-A\*-2/) 1574 || 1575 ($search_algorithm !~ /^C-A\*-2/ && 1576 $old_search_algo =~ /^C-A\*-2/) 1577 ) { 1578 undef $net; 1579 warn "undef net"; 1580 } 1581 } 1582 } 1583 ); 1584 } 1585 } 1586 $sbm->separator; 1587} 1588 1589sub add_search_net_menu_entries { 1590 my $sbm = shift; 1591 $sbm->cascade(-label => M"Netz �ndern"); 1592 my $nsbm = $sbm->Menu(-title => M"Netz �ndern"); 1593 $sbm->entryconfigure('last', -menu => $nsbm); 1594 foreach my $def ([M"Stra�en (Fahrrad)", 's'], 1595 ($devel_host ? [M"Stra�en (Auto)", 's-car'] : ()), 1596 (!$skip_features{'u-bahn'} || !$skip_features{'s-bahn'} ? [M"U/S-Bahn", 'us'] : ()), 1597 (!$skip_features{'r-bahn'} ? [M"R-Bahn", 'r'] : ()), 1598 (!$skip_features{'u-bahn'} || !$skip_features{'s-bahn'} || !$skip_features{'r-bahn'} ? [M"Gesamtes Bahnnetz", 'rus'] : ()), 1599 [M"Wasserrouten", 'wr'], 1600 [M"Custom", 'custom'], 1601 ) { 1602 my($label, $value) = @$def; 1603 $nsbm->radiobutton(-label => $label, 1604 -variable => \$net_type, 1605 -value => $value, 1606 -command => \&change_net_type, 1607 ); 1608 } 1609 $nsbm->checkbutton(-label => M"Add fragezeichen", 1610 -variable => \$add_net{fz}, 1611 -command => \&change_net_type, 1612 ); 1613 $nsbm->checkbutton(-label => M"Add custom", 1614 -variable => \$add_net{custom}, 1615 -command => \&change_net_type, 1616 ); 1617 # XXX check whether this is significant in any way, and if not: 1618 # delete! Also change_net_type has to be amended, maybe. 1619 if ($devel_host) { 1620 $nsbm->checkbutton(-label => M"Add IS data", 1621 -variable => \$add_net{is}, 1622 -command => \&change_net_type, 1623 ); 1624 } 1625 $nsbm->command(-label => M"Layer f�r Custom ausw�hlen", 1626 -command => sub { 1627 select_layers_for_net_dialog(); 1628 }); 1629} 1630 1631sub advanced_coord_menu { 1632 my $bpcm = shift; 1633 $bpcm->command 1634 (-label => M"Stra�en-Editor", 1635 -command => sub { 1636 require BBBikeEdit; 1637 BBBikeEdit::editmenu($top); 1638 }); 1639 $bpcm->separator; 1640 $bpcm->command(-label => M"Koordinaten setzen", 1641 -command => \&set_coord_interactive); 1642 $bpcm->command(-label => M"Linienkoordinaten setzen", 1643 -command => \&set_line_coord_interactive); 1644 $bpcm->command(-label => M"Koordinaten aus Selection", 1645 -command => \&coord_to_markers_dialog); 1646 $bpcm->separator; 1647 $bpcm->command(-label => M"Koordinatenliste zeigen", 1648 -command => \&show_coord_list); 1649 $bpcm->command(-label => M"Path to Selection", 1650 -command => \&path_to_selection); 1651 $bpcm->command(-label => M"Marks to Path", 1652 -command => \&marks_to_path); 1653 $bpcm->command(-label => M"Marks to Selection", 1654 -command => \&marks_to_selection); 1655 $bpcm->separator; 1656 { 1657 $bpcm->checkbutton(-label => M"Kreuzungen/Kurvenpunkte (pp) zeichnen (zuk�nftige Layer)", 1658 -variable => \$p_draw{'pp'}); 1659 push(@edit_mode_cmd, 1660 sub { 1661 $p_draw{'pp'} = 1; 1662 }); 1663 push(@standard_mode_cmd, 1664 sub { 1665 $p_draw{'pp'} = 0; 1666 }); 1667 $bpcm->checkbutton(-label => M"pp f�r alle zuk�nftigen Layer", 1668 -variable => \$p_sub_draw{'pp-all'}); 1669 } 1670 $bpcm->cascade(-label => M('Kurvenpunkte/Kreuzungen')); 1671 { 1672 my $csm = $bpcm->Menu(-title => M('Kurvenpunkte/Kreuzungen')); 1673 $bpcm->entryconfigure('last', -menu => $csm); 1674 foreach my $coldef ([M"Kurvenpunkte rot", '#800000'], 1675 [M"Kurvenpunkte gr�n", '#008000'], 1676 [M"Kurvenpunkte blau", '#000080'], 1677 [M"Kurvenpunkte schwarz", '#000000'], 1678 ) { 1679 $csm->radiobutton(-label => $coldef->[0], 1680 -variable => ref $pp_color ? \$pp_color->[0] : \$pp_color, 1681 -value => $coldef->[1], 1682 -command => sub { pp_color() }, 1683 ); 1684 } 1685 if (0 && ref $pp_color) { # not yet used 1686 $csm->separator; 1687 foreach my $coldef ([M"Kreuzungen blau", 'blue'], 1688 [M"Kreuzungen schwarz", 'black'], 1689 ) { 1690 $csm->radiobutton(-label => $coldef->[0], 1691 -variable => \$pp_color->[1], 1692 -value => $coldef->[1], 1693 -command => sub { pp_color() }, 1694 ); 1695 } 1696 } 1697 } 1698 $bpcm->checkbutton(-label => M"Pr�fix-Ausgabe", 1699 -variable => \$use_current_coord_prefix, 1700 ); 1701 $bpcm->checkbutton(-label => M"Pl�tze zeichnen", 1702 -variable => \$p_draw{'pl'}, 1703 -command => sub { plot('p','pl') }, 1704 ); 1705#XXX del: 1706# # XXX should move someday to bbbike, main streets menu 1707# $bpcm->cascade(-label => M"Kommentare zeichnen"); 1708# { 1709# my $c_bpcm = $bpcm->Menu(-title => M"Kommentare zeichnen"); 1710# $bpcm->entryconfigure("last", -menu => $c_bpcm); 1711# foreach my $_type (@comments_types) { 1712# my $type = my $label = $_type; 1713# my $def = 'comm-' . $type; 1714# $c_bpcm->checkbutton 1715# (-label => $label, 1716# -variable => \$str_draw{$def}, 1717# -command => sub { 1718# my $file = "comments_" . $type . ($edit_mode ? "-orig" : ""); 1719# plot('str', $def, Filename => $file); 1720# }, 1721# ); 1722# } 1723# } 1724 1725 $bpcm->command(-label => M"Schnelles Neuladen von �nderungen", 1726 -command => sub { reload_all() }, 1727 -accelerator => 'Ctrl-R', 1728 ); 1729 $bpcm->command(-label => M"Gr�ndliches Neuladen von �nderungen", 1730 -command => sub { reload_all(force => 1) }, 1731 ); 1732 $bpcm->checkbutton(-label => M"Lazy drawing f�r alle Layer", 1733 -variable => \$lazy_plot, 1734 ); 1735 $bpcm->cascade(-label => M"Markierungen"); 1736 { 1737 my $c_bpcm = $bpcm->Menu(-title => M"Markierungen"); 1738 $bpcm->entryconfigure("last", -menu => $c_bpcm); 1739 $c_bpcm->command 1740 (-label => M"Verschieben der Markierung", 1741 -command => sub { require BBBikeEdit; 1742 BBBikeEdit::move_marks_by_delta(); 1743 }, 1744 ); 1745 $c_bpcm->command 1746 (-label => M"Reset mark_adjusted-Tag", 1747 -command => sub { require BBBikeEdit; 1748 BBBikeEdit::reset_map_adjusted_tag(); 1749 }, 1750 ); 1751 } 1752## XXX NYI: 1753# $bpcm->command(-label => M"Neuzeichnen aller Layer", 1754# -command => sub { reload_all_unconditionally() }, 1755# ); 1756 $bpcm->separator; 1757 1758 $bpcm->cascade(-label => M"Edit-Modus"); 1759 { 1760 my $c_bpcm = $bpcm->Menu(-title => M"Edit-Modus"); 1761 $bpcm->entryconfigure("last", -menu => $c_bpcm); 1762 $c_bpcm->command 1763 (-label => M"Edit-Modus", 1764 -command => sub { switch_edit_standard_mode() }, 1765 ); 1766 $editstandard_command_index = $c_bpcm->index('last'); 1767 $c_bpcm->command 1768 (-label => M"Standard-Modus", 1769 -command => sub { switch_standard_mode() }, 1770 ); 1771 $standard_command_index = $c_bpcm->index('last'); 1772 $c_bpcm->command 1773 (-label => M"Andere Edit-Modi", 1774 -command => sub { choose_edit_any_mode() }, 1775 ); 1776 } 1777 my $obsolete_menu; 1778 for my $def ({menu => "Editierfunktionen", 1779 items => [{Label => M"Ampelschaltung", 1780 Type => 'ampel'}, 1781 ], 1782 }, 1783 {menu => "Obsolete Editierfunktionen", 1784 items => [{Label => M"Radwege", 1785 Type => 'radweg'}, 1786 {Label => M"Label", 1787 Type => 'label'}, 1788 {Label => M"Vorfahrt", 1789 Type => 'vorfahrt'}, 1790 ], 1791 var => \$obsolete_menu, 1792 }) { 1793 my($menu_label, $menu_items, $var_ref) = @{$def}{qw(menu items var)}; 1794 $bpcm->cascade(-label => $menu_label); 1795 my $o_bpcm = $bpcm->Menu(-title => $menu_label); 1796 if ($var_ref) { 1797 $$var_ref = $o_bpcm; 1798 } 1799 $bpcm->entryconfigure("last", -menu => $o_bpcm); 1800 foreach my $def (@$menu_items) { 1801 $o_bpcm->cascade(-label => $def->{Label}); 1802 my $m = $o_bpcm->Menu(-title => $def->{Label}); 1803 $o_bpcm->entryconfigure('last', -menu => $m); 1804 $m->checkbutton(-label => $def->{Label} . M"-Modus", 1805 -variable => \$special_edit, 1806 -onvalue => $def->{Type}, 1807 -offvalue => '', 1808 -command => sub { 1809 require BBBikeEdit; 1810 # XXX move to autouse 1811 eval $def->{Type} . "_edit_toggle()"; 1812 warn $@ if $@; 1813 }); 1814 $m->command(-label => 'Undef all', 1815 -command => sub { 1816 require BBBikeEdit; 1817 # XXX move to autouse 1818 eval $def->{Type} . "_undef_all()"; 1819 warn $@ if $@; 1820 }); 1821 $m->command(-label => M"Speichern als...", 1822 -command => sub { 1823 require BBBikeEdit; 1824 # XXX move to autouse 1825 eval $def->{Type} . "_save_as()"; 1826 warn $@ if $@; 1827 }); 1828 } 1829 } 1830 { 1831 $obsolete_menu->checkbutton 1832 (-label => M"Point-Editor", 1833 -variable => \$special_edit, 1834 -onvalue => "point", 1835 -offvalue => "", 1836 -command => sub { 1837 if ($special_edit eq 'point') { 1838 require PointEdit; 1839 my $p = new MasterPunkte "$FindBin::RealBin/misc/masterpoints-orig"; 1840 $p->read; 1841 if (!$net) { make_net() } 1842 all_crossings(); 1843 $point_editor = new PointEdit 1844 MasterPunkte => $p, 1845 Net => $net, 1846 Crossings => $crossings, 1847 Top => $top; 1848 } elsif ($point_editor) { 1849 $point_editor->delete; 1850 undef $point_editor; 1851 } 1852 }); 1853 $obsolete_menu->command 1854 (-label => M"Beziehungs-Editor", 1855 -command => sub { 1856 require BBBikeEdit; 1857 BBBikeEdit::create_relation_menu($top); 1858 }); 1859 } 1860 $bpcm->separator; 1861 $bpcm->cascade(-label => M"Aus/Eingabe"); 1862 { 1863 my $ausm = $bpcm->Menu(-title => M"Aus/Eingabe"); 1864 $bpcm->entryconfigure('last', -menu => $ausm); 1865 foreach (@Karte::map, qw(canvas)) { 1866 my $name = (ref $Karte::map{$_} && $Karte::map{$_}->can('name') 1867 ? $Karte::map{$_}->name 1868 : $_); 1869 $ausm->radiobutton(-label => $name, 1870 -variable => \$coord_output, 1871 -value => $_, 1872 -command => sub { set_coord_output_sub() }, 1873 ); 1874 if ($_ eq 'polar') { 1875 $ausm->radiobutton(-label => $name . ' (DMS)', 1876 -variable => \$coord_output, 1877 -value => "$_:dms", 1878 -command => sub { set_coord_output_sub() }, 1879 ); 1880 } 1881 my $index = $ausm->index('last'); 1882 if ($_ eq 'canvas') { 1883 push @edit_mode_brb_cmd, sub { $ausm->invoke($index) }; 1884 push @edit_mode_b_cmd, sub { $ausm->invoke($index) }; 1885 } elsif ($_ eq 'standard') { 1886 push @edit_mode_standard_cmd, sub { $ausm->invoke($index) }; 1887 } 1888 } 1889 $ausm->checkbutton(-label => "Integer", 1890 -variable => \$coord_output_int, 1891 ); 1892 $ausm->checkbutton(-label => "Without zoom factor", 1893 -variable => \$without_zoom_factor, 1894 ); 1895 } 1896 1897 $bpcm->cascade(-label => M"Koordinatensystem"); 1898 { 1899 my $csm = $bpcm->Menu(-title => M"Koordinatensystem"); 1900 $bpcm->entryconfigure('last', -menu => $csm); 1901 foreach (@Karte::map, qw(canvas)) { 1902 my $o = $Karte::map{$_}; 1903 my $name = (ref $o && $o->can('name') 1904 ? $o->name 1905 : $_); 1906 $csm->radiobutton(-label => $name, 1907 -value => $_, 1908 -variable => \$coord_system, 1909 -command => sub { set_coord_system($o) }, 1910 ); 1911 if ($_ eq 'brbmap') { 1912 my $index = $csm->index('last'); 1913 push @edit_mode_brb_cmd, sub { $csm->invoke($index) }; 1914 } elsif ($_ eq 'berlinmap') { 1915 my $index = $csm->index('last'); 1916 push @edit_mode_b_cmd, sub { $csm->invoke($index) }; 1917 } elsif ($_ eq 'standard') { 1918 my $index = $csm->index('last'); 1919 push @standard_mode_cmd, sub { $csm->invoke($index) }; 1920 push @edit_mode_standard_cmd, sub { $csm->invoke($index) }; 1921 } 1922 } 1923 } 1924 $bpcm->separator; 1925 $bpcm->command 1926 (-label => M"GPS-Punkte-Editor", 1927 -command => sub { 1928 require BBBikeEdit; 1929 BBBikeEdit::set_edit_gpsman_waypoint(); 1930 }); 1931 $bpcm->command 1932 (-label => M"GPS-Track bearbeiten", 1933 -command => sub { 1934 require BBBikeEdit; 1935 BBBikeEdit::edit_gps_track_mode(); 1936 }); 1937 $bpcm->command 1938 (-label => M"GPS-Track mit Waypoints anzeigen", 1939 -command => sub { 1940 require BBBikeEdit; 1941 $main::global_draw_gpsman_data_p = 1; # XXX don't qualify 1942 $main::global_draw_gpsman_data_s = 1; 1943 BBBikeEdit::show_gps_track_mode(); 1944 }); 1945 $bpcm->command 1946 (-label => M"GPS-Track ohne Waypoints anzeigen", 1947 -command => sub { 1948 require BBBikeEdit; 1949 $main::global_draw_gpsman_data_p = 0; # XXX don't qualify 1950 $main::global_draw_gpsman_data_s = 1; 1951 BBBikeEdit::show_gps_track_mode(); 1952 }); 1953 $bpcm->command 1954 (-label => M"GPS-Track nur mit Waypoints anzeigen", 1955 -command => sub { 1956 require BBBikeEdit; 1957 $main::global_draw_gpsman_data_p = 1; # XXX don't qualify 1958 $main::global_draw_gpsman_data_s = 0; 1959 BBBikeEdit::show_gps_track_mode(); 1960 }); 1961 $bpcm->command 1962 (-label => M"GPS-Track in GPS Data Viewer anzeigen", 1963 -command => sub { 1964 require BBBikeEdit; 1965 BBBikeEdit::show_gps_data_viewer_mode(); 1966 }); 1967 $bpcm->checkbutton 1968 (-label => M"Bahn-Tracks bevorzugen", 1969 -variable => \$BBBikeEdit::prefer_tracks, 1970 -onvalue => 'bahn', 1971 -offvalue => 'street', 1972 ); 1973} 1974 1975sub stderr_menu { 1976 my $opbm = shift; 1977 $opbm->checkbutton(-label => M"Status nach STDERR", 1978 -variable => \$stderr); 1979 $opbm->checkbutton 1980 (-label => M"STDERR in ein Fenster", 1981 -variable => \$stderr_window, 1982 -command => \&stderr_window_command, 1983 ); 1984} 1985 1986sub stderr_window_command { 1987 if ($stderr_window && defined $Devel::Trace::TRACE) { 1988 warn <<EOF; 1989********************************************************************** 1990* NOTE: It seems that -d:Trace is requested. It's a bad idea 1991* to use this together with Tk::Stderr, so the latter 1992* is disabled. 1993********************************************************************** 1994EOF 1995 return; 1996 } 1997 if ($stderr_window) { 1998 if (!eval { require Tk::Stderr; Tk::Stderr->VERSION(1.2); }) { 1999 if (!perlmod_install_advice("Tk::Stderr")) { 2000 $stderr_window = 0; 2001 return; 2002 } 2003 } 2004 if (!$Tk::Stderr::__STDERR_PATCHED__) { 2005 2006 # See https://rt.cpan.org/Ticket/Display.html?id=20718 2007 2008 local $^W = 0; # redefined... 2009 2010 *Tk::Stderr::Handle::TIEHANDLE = sub { 2011 my ($class, $window) = @_; 2012 bless { w => $window, pid => $$ }, $class; 2013 }; 2014 2015 *Tk::Stderr::Handle::PRINT = sub { 2016 my $self = shift; 2017 if ($self->{pid} != $$) { 2018 # child window, use fallback 2019 print STDOUT "@_"; 2020 } else { 2021 my $window = $self->{w}; 2022 my $text = $window->Subwidget('text'); 2023 if ($text) { 2024 $text->insert('end', $_) foreach (@_); 2025 $text->see('end'); 2026 $window->deiconify; 2027 $window->raise; 2028 $window->focus; 2029 } else { 2030 # no window yet, use fallback 2031 print STDOUT "@_"; 2032 } 2033 } 2034 }; 2035 2036 $Tk::Stderr::__STDERR_PATCHED__ = 1; 2037 } 2038 my $errwin = $top->StderrWindow; 2039 if (!$errwin || !Tk::Exists($errwin)) { 2040 $top->InitStderr; 2041 $errwin = $top->StderrWindow; 2042 $errwin->title("BBBike - " . M("STDERR-Fenster")); 2043 } else { 2044 $errwin = $top->RedirectStderr(1); 2045 } 2046 } elsif ($top->can("RedirectStderr")) { 2047 $top->RedirectStderr(0); 2048 } 2049} 2050 2051sub penalty_menu { 2052 my $bpcm = shift; 2053 2054 my @koeffs = (0.25, 0.5, 0.8, 1, 1.2, 1.5, 2, 2.5, 3, 3.5, 4, 6, 8, 10, 12, 15, 20); 2055 2056 $bpcm->cascade(-label => M"Penalty"); 2057 my $pen_m = $bpcm->Menu(-title => M"Penalty"); 2058 $bpcm->entryconfigure('last', -menu => $pen_m); 2059 2060 ###################################################################### 2061 2062 my $penalty_nolighting = 0; 2063 my $penalty_nolighting_koeff = 2; 2064 $pen_m->checkbutton 2065 (-label => M"Penalty f�r unbeleuchtete Stra�en", 2066 -variable => \$penalty_nolighting, 2067 -command => sub { 2068 if ($penalty_nolighting) { 2069 2070 my $s = new Strassen "nolighting"; 2071 die "Can't get nolighting" if !$s; 2072 my $net = new StrassenNetz $s; 2073 $net->make_net; 2074 2075 $penalty_subs{'nolightingpenalty'} = sub { 2076 my($p, $next_node, $last_node) = @_; 2077 if ($net->{Net}{$next_node}{$last_node} || 2078 $net->{Net}{$last_node}{$next_node}) { 2079 $p *= $penalty_nolighting_koeff; 2080 } 2081 $p; 2082 }; 2083 } else { 2084 delete $penalty_subs{'nolightingpenalty'}; 2085 } 2086 }); 2087 $pen_m->cascade(-label => M("Penalty-Koeffizient")." ..."); 2088 { 2089 my $c_bpcm = $pen_m->Menu(-title => M("Penalty-Koeffizient")." ..."); 2090 $pen_m->entryconfigure("last", -menu => $c_bpcm); 2091 foreach my $koeff (@koeffs) { 2092 $c_bpcm->radiobutton(-label => $koeff, 2093 -variable => \$penalty_nolighting_koeff, 2094 -value => $koeff); 2095 } 2096 } 2097 $pen_m->separator; 2098 2099 ###################################################################### 2100 2101 my $penalty_tram = 0; 2102 my $penalty_tram_koeff = 2; 2103 $pen_m->checkbutton 2104 (-label => M"Penalty f�r Stra�enbahn auf Fahrbahn", 2105 -variable => \$penalty_tram, 2106 -command => sub { 2107 if ($penalty_tram) { 2108 2109 my $s = new Strassen "comments_tram"; 2110 die "Can't get comments_tram" if !$s; 2111 my $net = new StrassenNetz $s; 2112 $net->make_net; 2113 2114 $penalty_subs{'trampenalty'} = sub { 2115 my($p, $next_node, $last_node) = @_; 2116 if ($net->{Net}{$next_node}{$last_node} || 2117 $net->{Net}{$last_node}{$next_node}) { 2118 $p *= $penalty_tram_koeff; 2119 } 2120 $p; 2121 }; 2122 } else { 2123 delete $penalty_subs{'trampenalty'}; 2124 } 2125 }); 2126 $pen_m->cascade(-label => M("Penalty-Koeffizient")." ..."); 2127 { 2128 my $c_bpcm = $pen_m->Menu(-title => M("Penalty-Koeffizient")." ..."); 2129 $pen_m->entryconfigure("last", -menu => $c_bpcm); 2130 foreach my $koeff (@koeffs) { 2131 $c_bpcm->radiobutton(-label => $koeff, 2132 -variable => \$penalty_tram_koeff, 2133 -value => $koeff); 2134 } 2135 } 2136 $pen_m->separator; 2137 2138 ###################################################################### 2139 2140 my $penalty_on_current_route = 0; 2141 my $penalty_on_current_route_koeff = 2; 2142 $pen_m->checkbutton 2143 (-label => M"Penalty f�r aktuelle Route", 2144 -variable => \$penalty_on_current_route, 2145 -command => sub { 2146 if ($penalty_on_current_route) { 2147 my %realcoords_hash; 2148 foreach (@realcoords) { 2149 $realcoords_hash{join(",",@$_)}++; 2150 } 2151 2152 $penalty_subs{'currentroutepenalty'} = sub { 2153 my($p, $next_node) = @_; 2154 if ($realcoords_hash{$next_node}) { 2155 $p *= $penalty_on_current_route_koeff; 2156 } 2157 $p; 2158 }; 2159 } else { 2160 delete $penalty_subs{'currentroutepenalty'}; 2161 } 2162 }); 2163 $pen_m->cascade(-label => M("Penalty-Koeffizient")." ..."); 2164 { 2165 my $c_bpcm = $pen_m->Menu(-title => M("Penalty-Koeffizient")." ..."); 2166 $pen_m->entryconfigure("last", -menu => $c_bpcm); 2167 foreach my $koeff (@koeffs) { 2168 $c_bpcm->radiobutton(-label => $koeff, 2169 -variable => \$penalty_on_current_route_koeff, 2170 -value => $koeff); 2171 } 2172 } 2173 $pen_m->separator; 2174 2175 ###################################################################### 2176 2177 use vars qw($bbd_penalty); 2178 $bbd_penalty = 0; 2179 $pen_m->checkbutton 2180 (-label => M"Penalty f�r BBD-Datei", 2181 -variable => \$bbd_penalty, 2182 -command => sub { 2183 if ($bbd_penalty) { 2184 require BBBikeEdit; 2185 BBBikeEdit::build_bbd_penalty_for_search(); 2186 } else { 2187 delete $penalty_subs{'bbdpenalty'}; 2188 } 2189 }); 2190 $pen_m->command 2191 (-label => M"BBD-Datei ausw�hlen", 2192 -command => sub { 2193 require BBBikeEdit; 2194 BBBikeEdit::choose_bbd_file_for_penalty(); 2195 }); 2196# $pen_m->cascade(-label => M("Penalty-Koeffizient")." ..."); 2197 $BBBikeEdit::bbd_penalty_koeff = 2 2198 if !defined $BBBikeEdit::bbd_penalty_koeff; 2199 $pen_m->command 2200 (-label => M("Penalty-Koeffizient")." ...", 2201 -command => sub 2202 { 2203 my $t = redisplay_top($top, "bbd-koeff", -title => M"Penalty-Koeffizient f�r BBD-Datei"); 2204 return if !defined $t; 2205 require Tk::LogScale; 2206 Tk::grid($t->Label(-text => M"Koeffizient"), 2207 $t->Entry(-textvariable => \$BBBikeEdit::bbd_penalty_koeff) 2208 ); 2209 Tk::grid($t->LogScale(-from => 0.25, -to => 20, 2210 -resolution => 0.01, 2211 -showvalue => 0, 2212 -orient => 'horiz', 2213 -variable => \$BBBikeEdit::bbd_penalty_koeff, 2214 -command => sub { 2215 $BBBikeEdit::bbd_penalty_koeff = 2216 sprintf "%.2f", $BBBikeEdit::bbd_penalty_koeff,; 2217 } 2218 ), 2219 -columnspan => 2, -sticky => "we" 2220 ); 2221 Tk::grid($t->Checkbutton(-text => M"Multiplizieren", 2222 -variable => \$BBBikeEdit::bbd_penalty_multiply, 2223 ), 2224 -columnspan => 2, -sticky => "w" 2225 ); 2226 Tk::grid($t->Checkbutton(-text => M"Daten invertieren", 2227 -variable => \$BBBikeEdit::bbd_penalty_invert, 2228 -command => sub { 2229 BBBikeEdit::build_bbd_penalty_for_search(); 2230 }, 2231 ), 2232 -columnspan => 2, -sticky => "w" 2233 ); 2234 Tk::grid($t->Button(Name => "close", 2235 -command => sub { $t->withdraw }), 2236 -columnspan => 2, -sticky => "we" 2237 ); 2238 $t->protocol("WM_DELETE_WINDOW" => sub { $t->withdraw }); 2239 } 2240 ); 2241 $pen_m->separator; 2242 2243 ###################################################################### 2244 2245 use vars qw($st_net_penalty); 2246 $st_net_penalty = 0; 2247 $pen_m->checkbutton 2248 (-label => M"Penalty f�r Net/Storable-Datei", 2249 -variable => \$st_net_penalty, 2250 -command => sub { 2251 if ($st_net_penalty) { 2252 require BBBikeEdit; 2253 BBBikeEdit::build_st_net_penalty_for_search(); 2254 } else { 2255 delete $penalty_subs{'stnetpenalty'}; 2256 } 2257 }); 2258 $pen_m->command 2259 (-label => M"Net/Storable-Datei ausw�hlen", 2260 -command => sub { 2261 require BBBikeEdit; 2262 BBBikeEdit::choose_st_net_file_for_penalty(); 2263 }); 2264 $BBBikeEdit::st_net_koeff = 1 2265 if !defined $BBBikeEdit::st_net_koeff; 2266 $pen_m->command 2267 (-label => M("Penalty-Koeffizient")." ...", 2268 -command => sub 2269 { 2270 my $t = redisplay_top($top, "bbd-koeff", -title => M"Penalty-Koeffizient f�r Net/Storable-Datei"); 2271 return if !defined $t; 2272 Tk::grid($t->Label(-text => M"Koeffizient"), 2273 $t->Entry(-textvariable => \$BBBikeEdit::st_net_koeff) 2274 ); 2275 { 2276 my $f = $t->Frame; 2277 Tk::grid($f, -columnspan => 2, -sticky => "we"); 2278 2279 Tk::grid($f->Label(-text => M"Schw�chen"), 2280 $f->LogScale(-from => 0.25, -to => 4, 2281 -resolution => 0.1, 2282 -showvalue => 0, 2283 -orient => 'horiz', 2284 -variable => \$BBBikeEdit::st_net_koeff, 2285 -command => sub { 2286 $BBBikeEdit::st_net_koeff = 2287 sprintf "%.2f", $BBBikeEdit::st_net_koeff,; 2288 } 2289 ), 2290 $f->Label(-text => M"Verst�rken"), 2291 -sticky => "we", 2292 ); 2293 } 2294 Tk::grid($t->Button(Name => "close", 2295 -command => sub { $t->withdraw }), 2296 -columnspan => 2, -sticky => "we" 2297 ); 2298 $t->protocol("WM_DELETE_WINDOW" => sub { $t->withdraw }); 2299 } 2300 ); 2301 $pen_m->separator; 2302 2303 ###################################################################### 2304 2305 my $gps_search_penalty = 0; 2306 $pen_m->checkbutton 2307 (-label => M"Penalty f�r besuchte GPS-Punkte", 2308 -variable => \$gps_search_penalty, 2309 -command => sub { 2310 if ($gps_search_penalty) { 2311 require BBBikeEdit; 2312 BBBikeEdit::build_gps_penalty_for_search(); 2313 } else { 2314 delete $penalty_subs{'gpspenalty'}; 2315 } 2316 }); 2317 $pen_m->cascade(-label => M("Penalty-Koeffizient")." ..."); 2318 { 2319 $BBBikeEdit::gps_penalty_koeff = 2 2320 if !defined $BBBikeEdit::gps_penalty_koeff; 2321 my $c_bpcm = $pen_m->Menu(-title => M("Penalty-Koeffizient")." ..."); 2322 $pen_m->entryconfigure("last", -menu => $c_bpcm); 2323 foreach my $koeff (@koeffs) { 2324 $c_bpcm->radiobutton(-label => $koeff, 2325 -variable => \$BBBikeEdit::gps_penalty_koeff, 2326 -value => $koeff); 2327 } 2328 $c_bpcm->separator; 2329 $c_bpcm->checkbutton(-label => M"Multiplizieren", 2330 -variable => \$BBBikeEdit::gps_penalty_multiply, 2331 ); 2332 } 2333 2334} 2335 2336# Return true if there was a modification. 2337# Arguments: $oper_name 2338# $oper_name is something like "insert" or "delete" 2339### AutoLoad Sub 2340sub _insert_points_and_co ($) { 2341 my $oper_name = shift; 2342 my $ret = 0; 2343 IncBusy($top); 2344 eval { 2345 require "$FindBin::RealBin/miscsrc/insert_points"; 2346 my @args = (-operation => $oper_name, 2347 (-e "$datadir/.custom_files" ? (-addfilelist => "$datadir/.custom_files") : ()), 2348 "-useint", # XXX but not for polar coordinates 2349 -datadir => $datadir, 2350 -bbbikerootdir => $FindBin::RealBin, 2351 "-tk", 2352 ($verbose ? "-v" : ()), 2353 @inslauf_selection, 2354 ); 2355#XXX: 2356# if (!$SRTShortcuts::force_edit_mode) { 2357# push @args, ( 2358# (!defined $edit_mode || $edit_mode eq '' ? "-noorig" : ()), 2359# ($coord_system_obj->coordsys eq 'B' || !defined $edit_mode || $edit_mode eq '' ? () : (-coordsys => $coord_system_obj->coordsys)), 2360# ); 2361# } 2362 warn "@args\n" if $verbose; 2363 my $modify_ret = BBBikeModify::process(@args); 2364 $ret = $modify_ret == BBBikeModify::RET_MODIFIED(); 2365 2366 # clear the selection (sometimes) 2367 if ($modify_ret != BBBikeModify::RET_ERROR() && $oper_name !~ m{^grep}) { 2368 delete_route(); 2369 } 2370 }; 2371 warn $@ if $@; 2372 DecBusy($top); 2373 $ret; 2374} 2375 2376sub insert_points { _insert_points_and_co("insert") } 2377sub insert_multi_points { _insert_points_and_co("insertmulti") } 2378sub change_points { _insert_points_and_co("change") } 2379sub change_line { _insert_points_and_co("changeline") } 2380sub grep_point { _insert_points_and_co("grep") } 2381sub grep_line { _insert_points_and_co("grepline") } 2382sub delete_point { _insert_points_and_co("delete") } 2383sub delete_lines { _insert_points_and_co("deletelines") } 2384sub smooth_line { 2385 if (@inslauf_selection != 3) { 2386 status_message("Es m�ssen genau drei Punkte selektiert sein. Der mittlere Punkt ist der zu verschiebende Punkt f�r die Gl�ttung.", "err"); 2387 return; 2388 } 2389 require VectorUtil; 2390 require Strassen::Util; 2391 my($x1,$y1,$p1,$p2,$x2,$y2) = map { split /,/, $_ } @inslauf_selection; 2392 my($new_p1,$new_p2) = map { int_round($_) } VectorUtil::project_point_on_line($p1,$p2,$x1,$y1,$x2,$y2); 2393 my($tx1,$ty1,$tx2,$ty2) = (transpose($p1,$p2), transpose($new_p1,$new_p2)); 2394 $c->createLine($tx1,$ty1,$tx2,$ty2, 2395 -arrow => 'last', 2396 -arrowshape => [3,5,3], 2397 -tags => 'smooth_line_movement', 2398 ); 2399 $c->createLine($tx2-3,$ty2-3,$tx2+3,$ty2+3,-tags => 'smooth_line_movement'); 2400 $c->createLine($tx2-3,$ty2+3,$tx2+3,$ty2-3,-tags => 'smooth_line_movement'); 2401 main::status_message("Mittleren Punkt um " . (sprintf "%.1f", Strassen::Util::strecke([$p1,$p2],[$new_p1,$new_p2])) . "m verschieben?", "info"); 2402 @inslauf_selection = ("$p1,$p2", "$new_p1,$new_p2"); 2403 my $done; 2404 eval { 2405 $done = change_points(); 2406 }; 2407 my $err = $@; 2408 $c->delete('smooth_line_movement'); 2409 delete_route(); # to avoid confusion about change of @inslauf_selection 2410 if ($err) { 2411 status_message($err, 'die'); 2412 } 2413 $done; 2414} 2415sub change_poly_points { 2416 # XXX NYI 2417} 2418 2419sub change_points_maybe_reload { 2420 change_points(@_); 2421 $BBBikeEdit::auto_reload = $BBBikeEdit::auto_reload if 0; # peacify -w 2422 if ($BBBikeEdit::auto_reload) { 2423 reload_all(); 2424 } 2425} 2426 2427sub find_canvas_item_file { 2428 my $ev = $_[0]->XEvent; 2429 my($X,$Y) = ($ev->X, $ev->Y); 2430 my $w = $_[0]->containing($X,$Y); 2431 my($abk, $name, $pos); 2432 if ($w || $w eq $c) { 2433 my(@tags) = $c->gettags('current'); 2434 $abk = $tags[0]; 2435 for my $tag_i (4, 3) { 2436 if (defined $tags[$tag_i] && $tags[$tag_i] =~ /-(\d+)$/) { 2437 $pos = $1; 2438 last; 2439 } 2440 } 2441 $name = $tags[2]; 2442 } 2443 if (defined $abk && $abk =~ m{^temp_sperre(?:_s)?$}) { 2444 require BBBikeEdit; 2445 my $e = BBBikeEdit->create; 2446 $e->edit_temp_blockings; 2447 } elsif ($name && $name =~ m{file://(/\S+)}) { 2448 start_emacsclient($1); 2449 } elsif ($name && $name =~ m{gnus:(\S+)}) { 2450 my $group_article = $1; 2451 my($group, $article) = $group_article =~ m{^(.*):(.*)$}; 2452 my $eval = qq{(progn (require 'org) (org-follow-gnus-link "$group" "$article"))}; 2453 start_emacsclient_eval($eval); 2454 } elsif (defined $abk && (exists $str_file{$abk} || 2455 exists $p_file{$abk})) { 2456 my($p_f, $str_f); 2457 if (exists $p_file{$abk}) { 2458 $p_f = (file_name_is_absolute($p_file{$abk}) 2459 ? "$p_file{$abk}-orig" 2460 : "$datadir/$p_file{$abk}-orig" 2461 ); 2462 if (-r $p_f) { 2463 my $linenumber; 2464 if (defined $pos) { 2465 $linenumber = Strassen::get_linenumber($p_f, $pos); 2466 } 2467 start_emacsclient($p_f, $linenumber); 2468 } 2469 } 2470 if (exists $str_file{$abk}) { 2471 $str_f = (file_name_is_absolute($str_file{$abk}) 2472 ? "$str_file{$abk}-orig" 2473 : "$datadir/$str_file{$abk}-orig" 2474 ); 2475 if (exists $str_file{$abk} && -r $str_f && $p_f ne $str_f) { 2476 my $linenumber; 2477 if (defined $pos) { 2478 $linenumber = Strassen::get_linenumber($str_f, $pos); 2479 } 2480 start_emacsclient($str_f, $linenumber); 2481 } 2482 } 2483 } else { 2484 start_emacsclient($datadir); 2485 } 2486} 2487 2488sub start_emacsclient { 2489 my($filename, $linenumber) = @_; 2490 my @cmd = ('emacsclient', '-n', ($linenumber ? '+'.$linenumber : ()), $filename); 2491 system @cmd; 2492 main::status_message("Command @cmd failed: $?", "warn") if $? != 0; 2493} 2494 2495sub start_emacsclient_eval { 2496 my($eval) = @_; 2497 my @cmd = ('emacsclient', '-n', "-e", $eval); 2498 system @cmd; 2499 main::status_message("Command @cmd failed: $?", "warn") if $? != 0; 2500} 2501 2502sub advanced_bindings { 2503 $top->bind("<F2>" => \&insert_points); 2504 $top->bind("<F3>" => \&change_points_maybe_reload); 2505 $top->bind("<F8>" => sub { 2506 my $ev = $_[0]->XEvent; 2507 my($X,$Y) = ($ev->X, $ev->Y); 2508 my $w = $_[0]->containing($X,$Y); 2509 return if !$w || $w ne $c; 2510 2511 require BBBikeEdit; 2512 my $e = BBBikeEdit->create; 2513 $e->click; 2514 }); 2515 $top->bind("<F9>" => sub { find_canvas_item_file(@_) }); 2516} 2517 2518sub destroy_all_toplevels { 2519 while(my($token, $w) = each %toplevel) { 2520 warn "Trying to destroy toplevel $token...\n"; 2521 $w->destroy if Tk::Exists($w); 2522 delete $toplevel{$token}; 2523 } 2524 2525 # Special toplevels: 2526 my $w = $top->Subwidget("Statistics"); 2527 $w->destroy if Tk::Exists($w); 2528} 2529 2530sub recall_some_subs { 2531 my @info; 2532 my $has_errors = 0; 2533 push @info, "Reloading autoused functions"; 2534 while(my($k,$v) = each %autouse_func) { 2535 (my $module = $k) =~ s{::}{/}g; 2536 $module .= ".pm"; 2537 delete $INC{$module}; 2538 eval "use autouse $k => qw(" . join(" ", @$v) . ");"; 2539 if ($@) { 2540 push @info, "Can't autouse $k: $@"; 2541 $has_errors++; 2542 } 2543 } 2544 push @info, "Redefining item attributes"; 2545 define_item_attribs(); 2546 push @info, "Generating plot functions"; 2547 generate_plot_functions(); 2548 push @info, "Reset bindings"; 2549 set_bindings(); 2550 push @info, "Reload message catalog"; 2551 Msg::setup_file(); 2552 if ($has_errors) { 2553 status_message(join("\n",@info), "die"); 2554 } 2555} 2556 2557use vars qw(%module_time %module_check $main_check_time); 2558 2559$main_check_time = -M $0; 2560 2561### AutoLoad Sub 2562sub check_new_modules { 2563 no strict 'refs'; 2564 my $pkg = shift; 2565 $pkg = 'main' if (!defined $pkg); 2566 my $loop = shift || 0; 2567 die "Recursion break on $pkg", return if $loop > 10; 2568 #warn "checking new modules for $pkg..." if $verbose; # nervig 2569 my %inc = %{$pkg."::INC"}; 2570 while(my($k, $v) = each %inc) { 2571 $v = "" if !defined $v; # may happen (in 5.10.x only?), to cease warnings 2572 # only record BBBike-related and own modules 2573 next if $v !~ /bbbike/i && $v !~ /\Q$ENV{HOME}/; 2574 next if exists $module_time{$v}; 2575 my $modtime = (stat($v))[9]; 2576 if (defined $modtime) { # may be undefined for temporary "reload" files 2577 $module_time{$v} = $modtime; 2578 warn "recorded $module_time{$v} for $k\n" if $verbose; 2579 } 2580 } 2581 $module_check{$pkg}++ if defined $pkg; 2582 my @stash_keys = keys %{$pkg."::"}; 2583 foreach my $sym (@stash_keys) { 2584 if ($sym =~ /^(.*)::$/) { 2585 my $subpkg = ($pkg eq 'main' 2586 ? $1 2587 : $pkg . "::" . $1); 2588 if (!exists $module_check{$subpkg}) { 2589 check_new_modules($subpkg, $loop+1); 2590 } 2591 } 2592 } 2593} 2594 2595### AutoLoad Sub 2596sub reload_new_modules { 2597 my @check_c; 2598 while(my($k, $v) = each %module_time) { 2599 my $now = (stat($k))[9]; 2600 next if ($v||0) >= ($now||0); 2601 next if $k =~ /^\Q$tmpdir\/bbbike_reload/; 2602 print STDERR "Reloading $k...\n"; 2603 eval { do $k }; 2604 push @check_c, $k; 2605 warn "*** $@" if $@; 2606 $module_time{$k} = $now; 2607 } 2608 if ($tmpdir && -M $0 < $main_check_time) { 2609 if (open(MAIN, $0)) { 2610 my $tmpfile = "$tmpdir/bbbike_reload_$$.pl"; 2611 $tmpfiles{$tmpfile}++; 2612 if (open(SAVEMAIN, ">$tmpfile")) { 2613 my $found = 0; 2614 while(<MAIN>) { 2615 if ($found) { 2616 print SAVEMAIN $_; 2617 } elsif (/RELOADER_START/) { 2618 $found++; 2619 print SAVEMAIN "# line $. $0\n"; 2620 } 2621 } 2622 close SAVEMAIN; 2623 if (!$found) { 2624 print STDERR "WARNING: RELOADER_START tag not found!\n"; 2625 } 2626 print STDERR "Reloading main...\n"; 2627 eval { do $tmpfile }; 2628 if (!$@) { 2629 unlink $tmpfile; 2630 if ($verbose) { 2631 warn "Re-call some functions in main script...\n"; 2632 } 2633 eval { 2634 generate_plot_functions(); 2635 set_bindings(); 2636 }; 2637 warn $@ if $@; 2638 } else { 2639 warn "*** Found errors: $@"; 2640 } 2641 } else { 2642 warn "Can't write to $tmpfile: $!"; 2643 } 2644 close MAIN; 2645 push @check_c, $0; 2646 } else { 2647 warn "Can't open $0: $!"; 2648 } 2649 $main_check_time = -M $0; 2650 } 2651 2652 # Check reloaded files for compile errors... 2653 if (@check_c && $os eq 'unix') { 2654 my($RDR,$WTR); 2655 pipe($RDR,$WTR); 2656 double_fork { 2657 close $RDR; 2658 my @problems; 2659 for my $f (@check_c) { 2660 my @cmd = ($^X, "-I$FindBin::RealBin/lib", "-I$FindBin::RealBin", "-c", $f); 2661 warn "@cmd\n"; 2662 system @cmd; 2663 if ($? != 0) { 2664 push @problems, $f; 2665 if ($? == -1) { 2666 push @problems, "errno=$!"; 2667 if ($!{ECHILD} && $SIG{CHLD} eq 'IGNORE') { 2668 push @problems, "ECHILD encountered and SIGCHLD=IGNORE --- possible side-effect of some module?"; 2669 } 2670 } 2671 } 2672 } 2673 if (@problems) { 2674 print $WTR join("\n", @problems), "\n"; 2675 } 2676 close $WTR; 2677 CORE::exit(0); 2678 }; 2679 close $WTR; 2680 $top->fileevent 2681 ($RDR, 'readable', 2682 sub { 2683 my $buf = ""; 2684 while(<$RDR>) { 2685 $buf .= $_; 2686 } 2687 if ($buf ne "") { 2688 $top->messageBox 2689 (-icon => "error", 2690 -type => "Ok", 2691 -message => "Compile problems with the following files:\n" . $buf, 2692 ); 2693 } 2694 close $RDR; 2695 $top->fileevent($RDR, 'readable', ''); 2696 } 2697 ); 2698 } 2699} 2700 2701############################################################ 2702# Selection-Kram (Koordinatenliste, buttonpoint et al.) 2703# 2704 2705# Gibt den angew�hlten Punkt auf STDERR aus. 2706# Ausgegeben wird: Name (soweit vorhanden), Canvas-Koordinaten und 2707# die Koordinaten abh�ngig von $coord_output_sub (gew�hnlich berlinmap). 2708# Au�erdem werden die $coord_output_sub-Koordinaten in die Selection 2709# geschrieben. 2710# Return-Value: $x, $y (u.U. an den n�chsten Punkt normalisiert) 2711### AutoLoad Sub 2712sub buttonpoint { 2713 my($x, $y, $current) = @_; 2714 my($rx,$ry) = ($x,$y); 2715 $c->SelectionOwn(-command => sub { 2716 @inslauf_selection = (); 2717 # kein reset_ext_selection, weil dann beim Anklicken 2718 # auf $coordlist_lbox die Selection verschwindet 2719 @ext_selection = (); 2720 }); 2721 my $prefix = (defined $coord_prefix 2722 ? $coord_prefix 2723 : ($use_current_coord_prefix 2724 ? $coord_system_obj->coordsys 2725 : '' 2726 ) 2727 ); 2728 if (defined $x) { 2729 my $coord = sprintf "$prefix%s,%s", $coord_output_sub->($x, $y); 2730 push(@inslauf_selection, $coord); 2731 clipboardAppendToken($coord); 2732 my $ext = prepare_selection_line 2733 (-name => "?", 2734 -coord1 => Route::_coord_as_string([$x,$y]), 2735 -coord2 => $coord); 2736 push_ext_selection($ext); 2737 print STDERR $ext, "\n"; 2738 } else { 2739 $current = 'current' if !defined $current; 2740 my(@tags) = $c->gettags($current); 2741 return if !@tags || !defined $tags[0]; 2742 if ($tags[0] eq 'o' || 2743 $tags[0] eq 'pp' || 2744 $tags[0] =~ /^lsa/ || 2745 $tags[0] =~ /^L\d+/|| 2746 $tags[0] eq 'fz' || 2747 $tags[0] =~ /^kn/ 2748 ) { 2749 my($tag, $s); 2750 $tag = $tags[1]; 2751 if ($tags[0] eq 'pp' || $tags[0] =~ /^lsa/ || 2752 $tags[0] =~ /^L\d+/) { 2753 my $use_prefix = 1; 2754 ($rx,$ry) = @{Strassen::to_koord1($tags[1])}; 2755 my($x, $y) = $coord_output_sub->($rx,$ry); 2756 if ($tags[2] =~ m|^(.*\.wpt)/(\d+)/|) { 2757 my($wpt_file,$wpt_nr) = ($1,$2); 2758 system q{gnuclient -batch -eval '(find-file "~/src/bbbike/misc/gps_data/}.$wpt_file.q{") (goto-char (point-min)) (search-forward-regexp "^}.$wpt_nr.q{\t")'}; 2759 } elsif ($tags[2] =~ /^ORIG:(.*),(.*)$/) { 2760 ($x, $y) = ($1, $2); 2761 $use_prefix = 0; 2762 } 2763 # XXX verallgemeinern!!! 2764 my $crossing = "?"; 2765## XXX crossings were not used for a long time 2766## so may be disabled and deleted forever 2767# if ($edit_mode) { # XXX $edit_normal_mode too? 2768# all_crossings(); 2769# } 2770# if (exists $crossings->{$tags[1]}) { 2771# $crossing = join("/", map { Strassen::strip_bezirk($_) } 2772# @{ $crossings->{$tags[1]} }); 2773# } 2774 $s = prepare_selection_line 2775 (-name => $crossing, 2776 -coord1 => $tags[1], 2777 -coord2 => Route::_coord_as_string([$x,$y])); 2778 my $str = ($use_prefix ? $prefix : "") . Route::_coord_as_string([$x,$y]); 2779 push(@inslauf_selection, $str); 2780 clipboardAppendToken($str); 2781 push_ext_selection($s); 2782 } elsif ($tags[0] eq 'o' || 2783 $tags[0] eq 'fz') { 2784 my($cx, $cy); 2785 if ($tags[0] eq 'o') { 2786 ($cx, $cy) = split /,/, $tags[1]; 2787 } 2788 if (!defined $cx || !defined $cy) { 2789 ($cx, $cy) = anti_transpose($c->coords($current)); 2790 } 2791 ($rx,$ry) = ($cx,$cy); 2792 my($x, $y) = $coord_output_sub->($cx, $cy); 2793 my $name = ($tags[0] eq 'o' 2794 ? substr(Strassen::strip_bezirk($tag), 0, 40) 2795 : $tags[1]); 2796 $s = prepare_selection_line 2797 (-name => $name, 2798 -coord1 => Route::_coord_as_string([$cx,$cy]), 2799 -coord2 => Route::_coord_as_string([$x,$y])); 2800 my $str = $prefix . Route::_coord_as_string([$x,$y]); 2801 push(@inslauf_selection, $str); 2802 clipboardAppendToken($str); 2803 push_ext_selection($s); 2804 } else { 2805 die "Tag $tags[0] wird f�r das Aufzeichnen von Punkten nicht unterst�tzt"; 2806 } 2807 $s .= "\n"; 2808 print STDERR $s; 2809 } 2810 } 2811 ($rx,$ry); 2812} 2813 2814### AutoLoad Sub 2815sub clipboardAppendToken { 2816 if ($use_clipboard) { 2817 my($token) = @_; 2818 if (eval { $c->clipboard('get') } ne '') { 2819 $c->clipboardAppend(" "); 2820 } 2821 $c->clipboardAppend($token); 2822 } 2823} 2824 2825### AutoLoad Sub 2826sub prepare_selection_line { 2827 my(%args) = @_; 2828 if ($os eq 'win') { # XXX 2829 if (0) { # XXX 2830 $args{-coord1} . " "; 2831 } else { 2832 sprintf("%-13s %-33s\n", 2833 $args{-coord1}, 2834 substr($args{-name}, 0, 33)); 2835 } 2836 } else { # XXX old 2837 sprintf("%-40s %-15s %-15s", 2838 $args{-name}, $args{-coord1}, $args{-coord2}) 2839 . (exists $args{-tag} ? " $args{-tag}" : ""); 2840 } 2841} 2842 2843### AutoLoad Sub 2844sub push_ext_selection { 2845 my(@a) = @_; 2846 push @ext_selection, @a; 2847 if (defined $coordlist_lbox && Tk::Exists($coordlist_lbox)) { 2848 if (subw_isa($coordlist_lbox, 'Tk::Text')) { 2849 $coordlist_lbox->insert('end', join($coordlist_lbox_nl, 2850 @a) . $coordlist_lbox_nl); 2851 } else { 2852 $coordlist_lbox->insert('end', @a); 2853 } 2854 $coordlist_lbox->see('end'); 2855 } 2856} 2857 2858### AutoLoad Sub 2859sub reset_ext_selection { 2860 @ext_selection = (); 2861 if (defined $coordlist_lbox && Tk::Exists($coordlist_lbox)) { 2862 if (subw_isa($coordlist_lbox, 'Tk::Text')) { 2863 $coordlist_lbox->delete("1.0", 'end'); 2864 } else { 2865 $coordlist_lbox->delete(0, 'end'); 2866 } 2867 } 2868} 2869 2870### AutoLoad Sub 2871sub reset_selection { 2872 @inslauf_selection = (); 2873 $c->clipboardClear() if $use_clipboard; 2874 reset_ext_selection(); 2875} 2876 2877### AutoLoad Sub 2878sub show_coord_list { 2879 my $coordlist_top = redisplay_top($top, 'coordlist', 2880 -title => M"Koordinatenliste"); 2881 return if !defined $coordlist_top; 2882 if (1 || $os eq 'win') { # XXX (1) # unter Win32 funktionieren Selections anders 2883 require Tk::ROText; 2884 $coordlist_lbox = $coordlist_top->Scrolled 2885 ('ROText', -font => $font{'fixed'}, 2886 -width => 80, 2887 -scrollbars => 'osoe')->pack; 2888 $coordlist_lbox_nl = ""; 2889 } else { 2890 $coordlist_lbox = $coordlist_top->Scrolled 2891 ('Listbox', -font => $font{'fixed'}, 2892 -width => 80, 2893 -selectmode => 'extended', 2894 -scrollbars => 'osoe')->pack; 2895 } 2896 if (@ext_selection) { 2897 $coordlist_lbox->insert('end', 2898 (subw_isa($coordlist_lbox, 'Tk::Text') 2899 ? join($coordlist_lbox_nl, @ext_selection) 2900 : @ext_selection)); 2901 } 2902 $coordlist_top->Button 2903 (Name => 'end', 2904 -command => sub { $coordlist_top->destroy }, 2905 )->pack; 2906 $coordlist_top->Popup(@popup_style); 2907} 2908 2909###################################################################### 2910# 2911# Edit/Standard-Modus 2912# 2913 2914# L�scht die aktiven Stra�en und Punkte und merkt sie sich in 2915# f�r das sp�tere Wiederzeichnen in set_remember_plot. 2916### AutoLoad Sub 2917sub remove_plot { 2918 undef @remember_plot_str; 2919 my $abk; 2920 foreach $abk (keys %str_draw) { 2921 if ($str_draw{$abk}) { 2922 $str_draw{$abk} = 0; 2923 plot('str',$abk); 2924 push @remember_plot_str, $abk; 2925 } 2926 if (defined $str_obj{$abk}) { 2927 undef $str_obj{$abk}; 2928 } 2929 } 2930 undef @remember_plot_p; 2931 foreach $abk (keys %p_draw) { 2932 next if $abk =~ /^pp/; 2933 if ($p_draw{$abk}) { 2934 $p_draw{$abk} = 0; 2935 plot('p',$abk); 2936 push @remember_plot_p, $abk; 2937 } 2938 } 2939 delete_map(); 2940 $map_draw = 0; # XXX 2941} 2942 2943# Zeichnet die Strecken und Punkte neu, die in remove_plot() gel�scht wurden. 2944### AutoLoad Sub 2945sub set_remember_plot { 2946 my $abk; 2947 $progress->InitGroup; 2948 foreach $abk (@remember_plot_str) { 2949 if (!$str_draw{$abk}) { 2950 $str_draw{$abk} = 1; 2951 plot('str',$abk); 2952 } 2953 } 2954 foreach $abk (@remember_plot_p) { 2955 if (!$p_draw{$abk}) { 2956 $p_draw{$abk} = 1; 2957 plot('p',$abk); 2958 } 2959 } 2960 $progress->FinishGroup; 2961} 2962 2963# Schaltet in einen der folgenden Modi um. 2964### AutoLoad Sub 2965sub switch_mode { 2966 my $mode = shift; 2967 if ($mode eq 'std') { 2968 switch_standard_mode(@_); 2969 } elsif ($mode eq 'std-no-orig') { 2970 switch_edit_standard_mode(@_); 2971 } elsif ($mode eq 'b') { 2972 switch_edit_berlin_mode(@_); 2973 } elsif ($mode eq 'brb') { 2974 switch_edit_brb_mode(@_); 2975 } else { 2976 die "Unknown mode for switch_mode: $mode"; 2977 } 2978} 2979 2980# Schaltet in den Standard-Modus um. 2981### AutoLoad Sub 2982sub switch_standard_mode { 2983 my $init = shift; 2984 IncBusy($top) unless $init; 2985 eval { 2986 my($oldx, $oldy) = 2987 $coord_system_obj->map2standard 2988 (anti_transpose($c->get_center)); 2989 remove_plot() unless $init; 2990 foreach (@standard_mode_cmd) { $_->() } 2991 2992 # Special handling for hoehe (here also needed?) 2993 delete $p_obj{hoehe}; 2994 %hoehe = (); 2995 # ... and for ampeln 2996 delete $p_obj{lsa}; 2997 2998 $map_mode = MM_SEARCH(); 2999 gui_set_edit_mode(0); 3000 $do_flag{'start'} = $do_flag{'ziel'} = 1; # XXX better solution 3001 set_remember_plot() unless $init; 3002 $ampelstatus_label_text = ""; 3003 $c->center_view 3004 (transpose($coord_system_obj->standard2map($oldx, $oldy)), 3005 NoSmoothScroll => 1); 3006 }; 3007 my $err = $@; 3008 DecBusy($top) unless $init; 3009 status_message($err, "die") if $err; 3010} 3011 3012sub set_edit_mode { 3013 my($flag) = @_; 3014 $edit_mode_flag = $flag if defined $flag; 3015 if ($edit_mode_flag) { 3016 #XXX del switch_edit_berlin_mode(); 3017 switch_edit_standard_mode(); 3018 } else { 3019 switch_standard_mode(); 3020 } 3021 set_map_mode(); 3022} 3023 3024# Schaltet in den Edit-Standard-Modus um. 3025### AutoLoad Sub 3026sub switch_edit_standard_mode { 3027 my $init = shift; 3028 IncBusy($top) unless $init; 3029 eval { 3030 my($oldx, $oldy) = 3031 $coord_system_obj->map2standard 3032 (anti_transpose($c->get_center)); 3033 remove_plot() unless $init; 3034 foreach (@edit_mode_cmd) { $_->() } 3035 foreach (@edit_mode_standard_cmd) { $_->() } 3036 3037 # Special handling for hoehe, because it's preloaded 3038 delete $p_obj{hoehe}; 3039 %hoehe = (); 3040 # ... and for ampeln 3041 delete $p_obj{lsa}; 3042 3043 $map_mode = MM_BUTTONPOINT(); 3044 $use_current_coord_prefix = 0; 3045 $coord_prefix = ""; 3046 gui_set_edit_mode('std-no-orig'); 3047 $do_flag{'start'} = $do_flag{'ziel'} = 1; # XXX better solution 3048 local $lazy_plot = 1; 3049 set_remember_plot() unless $init; 3050 3051 $c->center_view 3052 (transpose($coord_system_obj->standard2map($oldx, $oldy)), 3053 NoSmoothScroll => 1); 3054 if ($unit_s eq 'km') { 3055 change_unit('m'); 3056 } 3057 }; 3058 my $err = $@; 3059 DecBusy($top) unless $init; 3060 status_message($err, "die") if $err; 3061 3062 # Better when editing: 3063 while(my($type, $cats) = each %str_restrict) { 3064 while(my($cat, $v) = each %$cats) { 3065 $cats->{$cat} = 1 if !$cats->{$cat}; 3066 } 3067 } 3068# $str_restrict{qs}->{Q0} = 1; 3069# $str_restrict{ql}->{Q0} = 1; 3070# $str_restrict{hs}->{q0} = 1; 3071# $str_restrict{hl}->{q0} = 1; 3072 # This is not switched back when changing to normal mode. 3073} 3074 3075# Schaltet in den Edit-Mode f�r Berlin um. 3076### AutoLoad Sub 3077sub switch_edit_berlin_mode { 3078 my $init = shift; 3079 my($oldx, $oldy) = 3080 $coord_system_obj->map2standard 3081 (anti_transpose($c->get_center)); 3082 remove_plot() unless $init; 3083 foreach (@edit_mode_cmd) { $_->() } 3084 foreach (@edit_mode_b_cmd) { $_->() } 3085 $map_mode = MM_BUTTONPOINT(); 3086 $use_current_coord_prefix = 0; 3087 $coord_prefix = undef; 3088 $wasserstadt = 1; 3089 $wasserumland = 0; 3090 $str_far_away{'w'} = 0; 3091 gui_set_edit_mode('b'); 3092 $do_flag{'start'} = $do_flag{'ziel'} = 0; 3093 set_remember_plot() unless $init; 3094 $c->center_view 3095 (transpose($coord_system_obj->standard2map($oldx, $oldy)), 3096 NoSmoothScroll => 1); 3097} 3098 3099# Schaltet in den Edit-Mode f�r das Umland (Brandenburg) um. 3100### AutoLoad Sub 3101sub switch_edit_brb_mode { 3102 my $init = shift; 3103 my($oldx, $oldy) = 3104 $coord_system_obj->map2standard 3105 (anti_transpose($c->get_center)); 3106 remove_plot() unless $init; 3107 foreach (@edit_mode_cmd) { $_->() } 3108 foreach (@edit_mode_brb_cmd) { $_->() } 3109 $map_mode = MM_BUTTONPOINT(); 3110 $use_current_coord_prefix = 1; 3111 $coord_prefix = undef; 3112 $wasserstadt = 0; 3113 $wasserumland = 1; 3114 $place_category = 0; 3115 gui_set_edit_mode('brb'); 3116 $do_flag{'start'} = $do_flag{'ziel'} = 0; 3117 set_remember_plot() unless $init; 3118 $c->center_view 3119 (transpose($coord_system_obj->standard2map($oldx, $oldy)), 3120 NoSmoothScroll => 1); 3121} 3122 3123# Schaltet in den Edit-Mode f�r beliebige Karten um. 3124### AutoLoad Sub 3125sub switch_edit_any_mode { 3126 my($map, $init) = @_; 3127 my($oldx, $oldy) = 3128 $coord_system_obj->map2standard 3129 (anti_transpose($c->get_center)); 3130 remove_plot() unless $init; 3131 foreach (@edit_mode_cmd) { $_->() } 3132 foreach (@edit_mode_any_cmd) { $_->() } 3133 $map_mode = MM_BUTTONPOINT(); 3134 $map_default_type = $coord_system; 3135 $use_current_coord_prefix = 1; 3136 $coord_prefix = undef; 3137 gui_set_edit_mode($map); 3138 $do_flag{'start'} = $do_flag{'ziel'} = 0; 3139 set_remember_plot() unless $init; 3140 $c->center_view 3141 (transpose($coord_system_obj->standard2map($oldx, $oldy)), 3142 NoSmoothScroll => 1); 3143} 3144 3145# Schaltet in den Edit-Mode f�r beliebige Karten um. 3146### AutoLoad Sub 3147sub choose_edit_any_mode { 3148 my $t = $top->Toplevel(-title => M"Editmodus w�hlen"); 3149 $t->transient($top) if $transient; 3150 my $choose_coord_system; 3151 foreach (@Karte::map, qw(canvas)) { 3152 my $o = $Karte::map{$_}; 3153 my $name = (ref $o && $o->can('name') 3154 ? $o->name 3155 : $_); 3156 $t->Radiobutton(-text => $name, 3157 -value => $_, 3158 -variable => \$choose_coord_system, 3159 )->pack(-anchor => "w"); 3160 } 3161 { 3162 my $f = $t->Frame->pack; 3163 my $okb = $f->Button 3164 (Name => "ok", 3165 -command => sub { 3166 if (!defined $choose_coord_system) { 3167 $t->messageBox(-message => "Bitte Editmodus ausw�hlen"); 3168 return; 3169 } 3170 $coord_system = $choose_coord_system; 3171 set_coord_system($Karte::map{$coord_system}); 3172 switch_edit_any_mode($coord_system, 0); 3173 $t->destroy; 3174 })->pack(-side => "left"); 3175 $t->bind("<Return>" => sub { $okb->invoke }); 3176 my $cb = $f->Button 3177 (Name => "cancel", 3178 -command => sub { $t->destroy })->pack(-side => "left"); 3179 $t->bind("<Escape>" => sub { $cb->invoke }); 3180 } 3181 $t->Popup(@popup_style); 3182} 3183 3184use vars qw(@search_anything_history); 3185 3186# Full text search 3187### AutoLoad Sub 3188sub search_anything { 3189 my($s) = @_; 3190 3191 my $token = "search-anything"; 3192 my $t = redisplay_top($top, $token, 3193 -title => M"Suchen", 3194 ); 3195 if (!defined $t) { 3196 my $t = $toplevel{$token}; 3197 $t->Subwidget("Entry")->tabFocus; 3198 return; 3199 } 3200 3201 require File::Basename; 3202 3203 require Tk::LabFrame; 3204 3205 require PLZ; 3206 my @plz = PLZ->new; 3207 my @plz_labels = "PLZ-Datenbank (Berlin)"; 3208 eval { 3209 my $plz = PLZ->new("$datadir/Potsdam.coords.data"); 3210 die "Can't get Potsdam data" if (!$plz); 3211 push @plz, $plz; 3212 push @plz_labels, "PLZ-Datenbank (Potsdam)"; 3213 }; 3214 warn $@ if $@; 3215 3216 # XXX do a dump, blocking, unix-only search in datadir 3217 my @search_files = (@str_file{qw/s l u b r w f v e/}, 3218 @p_file {qw/u b r o pl/}, 3219 # additional scoped files XXX 3220 "brunnels", 3221 "wasserumland", "wasserumland2", "landstrassen2", 3222 "orte2", 3223 ); 3224 if ($advanced) { 3225 push @search_files, $str_file{fz}; 3226 # kn(eipen) is outdated, do it only here 3227 push @search_files, $p_file{kn}; 3228 } 3229 if ($devel_host) { 3230 push @search_files, map { defined } @p_file{qw(/ki rest/)}; 3231 } 3232 3233 @search_files = map { 3234 file_name_is_absolute($_) && -r $_ ? $_ : 3235 "$datadir/$_" ? "$datadir/$_" : () 3236 } @search_files; 3237 my %file_to_abbrev; 3238 while(my($k,$v) = each %str_file) { 3239 $file_to_abbrev{$v} = ['s', $k]; 3240 } 3241 while(my($k,$v) = each %p_file) { 3242 $file_to_abbrev{$v} = ['p', $k]; 3243 } 3244 # additional scoped files 3245 $file_to_abbrev{"wasserumland"} = ['s', 'w']; 3246 $file_to_abbrev{"wasserumland2"} = ['s', 'w']; 3247 $file_to_abbrev{"landstrassen2"} = ['s', 'l']; 3248 $file_to_abbrev{"orte2"} = ['p', 'o']; 3249 3250 my $lb; 3251 my $e; 3252 my @inx2match; 3253 3254 my $sort = "alpha"; # XXX make global and/or configurable 3255 my $search_type = "rx"; # XXX make global and/or configurable 3256 my $focus_transfer = 0; # XXX dito 3257 3258 my $probably_can_string_similarity = module_exists("String::Similarity"); 3259 use constant STRING_SIMILARITY_LEVEL => 0.75; 3260 my $probably_can_string_approx = module_exists("String::Approx"); 3261 use constant STRING_APPROX_ERRORS => 2; 3262 3263 my $do_search = sub { 3264 return if $s eq ''; 3265 3266 if ($search_type eq 'similarity' && !eval { require String::Similarity; 1 }) { 3267 perlmod_install_advice("String::Similarity"); 3268 $search_type = 'substr'; 3269 return; 3270 } elsif ($search_type eq 'approx' && !eval { require String::Approx; 1 }) { 3271 perlmod_install_advice("String::Approx"); 3272 $search_type = 'approx'; 3273 return; 3274 } 3275 3276 my $s_rx; 3277 my $s_munged; 3278 if ($search_type eq 'substr') { 3279 $s_rx = quotemeta($s); 3280 } elsif ($search_type eq '^substr') { 3281 $s_rx = "^" . quotemeta($s); 3282 } elsif ($search_type eq 'similarity') { 3283 $s_munged = lc $s; 3284 } elsif ($search_type eq 'approx') { 3285 $s_munged = lc $s; 3286 } else { 3287 $s_rx = $s; 3288 $s_rx =~ s{([sS])tra�e}{($1tra�e|$1tr\\.)}; 3289 } 3290 my $need_utf8_upgrade = $] >= 5.008 && ((defined $s_munged && eval { require Encode; Encode::is_utf8($s_munged) }) || 3291 (defined $s_rx && eval { require Encode; Encode::is_utf8($s_rx) })); 3292 my $may_utf8_downgrade = $] >= 5.008 && $need_utf8_upgrade && eval { require Encode; Encode::encode("iso-8859-1", Encode::FB_CROAK()); 1 }; 3293 3294### fork in eval is evil ??? (check it, it seems to work for 5.8.0 + FreeBSD) 3295 IncBusy($t); 3296 eval { 3297 my %found_in; 3298 my %title; 3299 my $has_egrep = is_in_path("egrep"); 3300 foreach my $search_file (@search_files) { 3301 my @matches; 3302 my $pid; 3303 #XXX grep is now completely disabled because: 3304 # * better testing of the public release (non $devel_host) 3305 # * no support for alias matching 3306 # Restrictions because of: 3307 # possible fork problems 3308 # no String::Similarity support 3309 # direct grep cannot handle utf-8 3310 # do we have grep at all? 3311 if (0 && $devel_host && !defined $s_munged && (!$need_utf8_upgrade || $may_utf8_downgrade) && $has_egrep) { 3312 my $s_rx = $s_rx; 3313 if ($may_utf8_downgrade) { 3314 $s_rx = Encode::encode("iso-8859-1", $s_rx); 3315 } 3316 $pid = open(GREP, "-|"); 3317 if (!$pid) { 3318 require POSIX; 3319 exec("egrep", "-i", $s_rx, $search_file) || warn "Can't exec program grep with $search_file: $!"; 3320 POSIX::_exit(); 3321 } 3322 } else { 3323 open(GREP, $search_file) || do { 3324 warn "Can't open $search_file: $!"; 3325 next; 3326 } 3327 } 3328 binmode GREP; 3329 BBD_LINE: 3330 while(<GREP>) { 3331 chomp; 3332 utf8::upgrade($_) if $need_utf8_upgrade; 3333 if (defined $s_munged) { 3334 if (/^#:\s*encoding:\s*(.*)/) { 3335 Strassen::switch_encoding(\*GREP, $1); 3336 } 3337 next if /^\#/; 3338 my($rec) = Strassen::parse($_); 3339 my $name = lc $rec->[Strassen::NAME()]; 3340 if ($search_type eq 'similarity') { 3341 next if String::Similarity::similarity($name, $s_munged, STRING_SIMILARITY_LEVEL) < STRING_SIMILARITY_LEVEL; 3342 } else { # $search_type eq 'approx' 3343 next if !String::Approx::amatch($s_munged, ['i', STRING_APPROX_ERRORS], $name); 3344 } 3345 push @matches, $rec; 3346 $matches[-1]->[3] = []; 3347 } else { 3348 if (!defined $pid) { # we have to do the grep ourselves 3349 if (/^#:\s*encoding:\s*(.*)/) { 3350 Strassen::switch_encoding(\*GREP, $1); 3351 } 3352 if (/^#:\s*alias(?:_wide)?:?\s*($s_rx.*)$/i) { 3353 my $alias = $1; 3354 while(<GREP>) { 3355 next if /^#/; 3356 my $non_aliased_rec = Strassen::parse($_); 3357 $non_aliased_rec->[Strassen::NAME()] .= " ($alias)"; 3358 $non_aliased_rec->[3] = []; 3359 push @matches, $non_aliased_rec; 3360 next BBD_LINE; 3361 } 3362 } elsif (/^#:\s*oldname:\s+\S+\s+($s_rx.*)$/i) { # don't need to check for age, this is already done in the strassen-orig -> strassen creation (-keep-old-name) 3363 # XXX unfortunately osm2bbd currently dumps *all* oldname, also too old ones 3364 # XXX almost duplicated code, see above... 3365 my $oldname = $1; 3366 while(<GREP>) { 3367 next if /^#/; 3368 my $non_aliased_rec = Strassen::parse($_); 3369 $non_aliased_rec->[Strassen::NAME()] .= " (" . M("alt") . ": $oldname)"; 3370 $non_aliased_rec->[3] = []; 3371 push @matches, $non_aliased_rec; 3372 next BBD_LINE; 3373 } 3374 } else { 3375 next unless /$s_rx.*\t/i; 3376 } 3377 } 3378 next if /^\#/; 3379 push @matches, Strassen::parse($_); 3380 $matches[-1]->[3] = []; 3381 } 3382 } 3383 close GREP; 3384 if (@matches) { 3385 my $file = File::Basename::basename($search_file); 3386 $found_in{$file} = \@matches; 3387 my $glob_dir = Strassen->get_global_directives($search_file); 3388 eval { 3389 my $lang = $Msg::lang || "de"; # XXX get from $var or func 3390 $title{$file} = ($glob_dir->{"title.$Msg::lang"} || $glob_dir->{"title.de"})->[0]; 3391 $title{$file} .= " ($file)"; 3392 }; 3393 if ($@ || !$title{$file}) { 3394 require Safe; 3395 my $s = Safe->new('BBBike::Search'); 3396 undef $BBBike::Search::title; 3397 $s->rdo($search_file.".desc"); 3398 if (defined $BBBike::Search::title) { 3399 if (ref $BBBike::Search::title eq 'HASH') { 3400 my $lang = $Msg::lang || "de"; 3401 $title{$file} = $BBBike::Search::title->{$lang} || 3402 $BBBike::Search::title->{"de"}; 3403 } else { 3404 $title{$file} = $BBBike::Search::title; 3405 } 3406 $title{$file} .= " ($file)"; 3407 } else { 3408 $title{$file} = $file; 3409 } 3410 } 3411 } 3412 } 3413 3414 # special case: PLZ files 3415 my %plz_search_args; 3416 if ($search_type eq 'similarity') { 3417 $plz_search_args{Agrep} = 1; 3418 } elsif ($search_type eq 'substr' || $search_type eq 'rx') { 3419 # f�r rx: Notl�sung XXX 3420 $plz_search_args{GrepType} = "grep-substr"; 3421 } 3422 3423 for my $i (0 .. $#plz) { 3424 my @plz_matches = $plz[$i]->look($s, %plz_search_args); 3425 if (@plz_matches) { 3426 # in Strassen-Format umwandeln 3427 my @matches; 3428 foreach (@plz_matches) { 3429 push @matches, [$_->[&PLZ::LOOK_NAME] . " (".$_->[&PLZ::LOOK_CITYPART] . 3430 ($_->[&PLZ::LOOK_ZIP] ne "" ? ", $_->[&PLZ::LOOK_ZIP]" : "") . 3431 ")", [$_->[&PLZ::LOOK_COORD]], "X", []]; 3432 } 3433 $found_in{$plz_labels[$i]} = \@matches; 3434 } 3435 } 3436 3437 $lb->delete(0, "end"); 3438 die M("Nichts gefunden")."\n" if !keys %found_in; 3439 3440 $lb->focus; 3441 if ($e->can('historyAdd') && $e->can('history')) { 3442 $e->historyAdd; 3443 @search_anything_history = $e->history; 3444 } 3445 3446 @inx2match = (); 3447 3448 my %sort_order = ('strassen' => 100, 3449 'PLZ-Datenbank (Berlin)' => 90, 3450 'PLZ-Datenbank (Potsdam)' => 89, 3451 'orte' => 80, 3452 'orte2' => 79, 3453 'landstrassen' => 70, 3454 'landstrassen2' => 69, 3455 'brunnels' => 60, 3456 ); 3457 3458 foreach my $file (sort { 3459 my $base_a = File::Basename::basename($a); 3460 my $base_b = File::Basename::basename($b); 3461 my $order_a = $sort_order{$base_a} || 0; 3462 my $order_b = $sort_order{$base_b} || 0; 3463 if ($order_a == $order_b) { 3464 $base_a cmp $base_b; 3465 } else { 3466 $order_b <=> $order_a; 3467 } 3468 } keys %found_in) { 3469 my $matches = $found_in{$file}; 3470 $lb->insert("end", ($title{$file} || $file).":"); 3471 $lb->itemconfigure("end", -foreground => "#0000a0") 3472 if $lb->Subwidget("scrolled")->can("itemconfigure"); 3473 push @inx2match, undef; 3474 my @sorted_matches; 3475 my $indent = " "x2; 3476 if ($sort eq 'dist') { 3477 my($center) = join(",",anti_transpose($c->get_center)); 3478 @sorted_matches = map { 3479 $_->[1]; 3480 } sort { 3481 $a->[0] <=> $b->[0]; 3482 } map { 3483 my $match = $_; 3484 my $nearest = min(map { 3485 Strassen::Util::strecke_s($center, $_); 3486 } @{$match->[Strassen::COORDS()]}); 3487 [$nearest, $match]; 3488 } @$matches; 3489 } elsif ($sort eq 'cat') { 3490 my $cat_stack_mapping = Strassen->default_cat_stack_mapping(); 3491 @sorted_matches = sort { 3492 my $cmp = $cat_stack_mapping->{$b->[Strassen::CAT()]} <=> $cat_stack_mapping->{$a->[Strassen::CAT()]}; 3493 if ($cmp == 0) { 3494 $a->[Strassen::NAME()] cmp $b->[Strassen::NAME()]; 3495 } else { 3496 $cmp; 3497 } 3498 } @$matches; 3499 $indent = " "x4; 3500 } else { # $sort eq 'alpha' 3501 @sorted_matches = 3502 map { $_->[1] } 3503 sort { $a->[0] cmp $b->[0] } 3504 map { 3505 (my $sortname = $_->[0]) =~ s{^\(}{}; 3506 [$sortname, $_]; 3507 } @$matches; 3508 } 3509 3510 my $last_name; 3511 my $last_cat; 3512 foreach my $match (@sorted_matches) { 3513 if (defined $last_name && $last_name eq $match->[0]) { 3514 push @{ $inx2match[-1]->[3] }, $match->[1]; 3515 } else { 3516 my $this_cat = $match->[Strassen::CAT()]; 3517 if ($sort eq 'cat' && 3518 $file !~ /^PLZ-Datenbank/ && 3519 (!defined $last_cat || $last_cat ne $this_cat)) { 3520 my $cat_name = $category_attrib{$this_cat}->[ATTRIB_PLURAL]; 3521 if (!defined $cat_name) { 3522 $cat_name = $this_cat; 3523 } 3524 $lb->insert("end", " " . $cat_name); 3525 $lb->itemconfigure("end", -foreground => "#000060") 3526 if $lb->Subwidget("scrolled")->can("itemconfigure"); 3527 $last_cat = $this_cat; 3528 push @inx2match, ""; 3529 } 3530 $lb->insert("end", $indent . $match->[0]); 3531 push @inx2match, $match; 3532 $last_name = $match->[0]; 3533 } 3534 } 3535 } 3536 $lb->activate(1); # first entry is a headline, so use 2nd one 3537 $lb->selectionSet(1); 3538 }; 3539 my $err = $@; 3540 DecBusy($t); 3541 if ($err) { 3542 status_message($err, 'err'); 3543 } 3544 }; 3545 3546 $t->transient($top) if $transient; 3547 my $f1 = $t->Frame->pack(-fill => 'x'); 3548 $f1->Label(-text => M("Nach").":", -padx => 0, -pady => 0, 3549 -underline => 0, 3550 )->pack(-side => "left"); 3551 my $Entry = 'Entry'; 3552 my @Entry_args; 3553 eval { 3554 require Tk::HistEntry; 3555 Tk::HistEntry->VERSION(0.37); 3556 @Entry_args = (-match => 1, -dup => 0); 3557 $Entry = 'SimpleHistEntry'; 3558 }; 3559 $e = $f1->$Entry(-textvariable => \$s, @Entry_args)->pack(-side => "left", -fill => "x"); 3560 if ($e->can('history')) { 3561 $e->history(\@search_anything_history); 3562 } 3563 $t->Advertise(Entry => $e); 3564 $e->focus; 3565 $e->bind("<Return>" => $do_search); 3566 $t->bind("<Alt-Key-n>" => sub { $e->focus }); 3567 3568 $f1->Button(Name => 'search', 3569 -command => $do_search, 3570 -padx => 4, 3571 -pady => 2, 3572 )->pack(-side => "left"); 3573 3574 3575 { 3576 package Tk::ListboxSearchAnything; 3577 use base qw(Tk::Listbox); 3578 Construct Tk::Widget 'ListboxSearchAnything'; 3579 *UpDown = sub { 3580 my($w, $amount) = @_; 3581 my $new_amount = $amount; 3582 my $new_inx = $w->index('active')+$amount; 3583 my $inc = ($amount > 0 ? 1 : -1); 3584 if (${ $w->{SortTypeRef} } eq 'cat') { 3585 while($w->get($new_inx) =~ /^(\S| \S)/) { # headline or category line 3586 $new_inx+=$inc; 3587 $new_amount+=$inc; 3588 last if ($w->index("end") <= $new_inx); 3589 } 3590 } else { 3591 if ($w->get($new_inx) =~ /^\S/) { # is a headline? 3592 $new_amount+=$inc; 3593 } 3594 } 3595 $w->SUPER::UpDown($new_amount); 3596 }; 3597 } 3598 3599 $lb = $t->Scrolled("ListboxSearchAnything", -scrollbars => "osoe", 3600 -width => 32, 3601 -height => 12, 3602 )->pack(-fill => "both", -expand => 1); 3603 { 3604 my $f = $t->LabFrame(-label => M("Suchart"), 3605 -labelside => "acrosstop", 3606 )->pack(-fill => "x"); 3607 for my $cb_def (["Regul�rer Ausdruck", "rx"], 3608 ["Teilstring", "substr"], 3609 ["Teilstring am Anfang", "^substr"], 3610 ($devel_host ? 3611 ( 3612 ($probably_can_string_similarity ? ["Ungenaue Suche (String::Similarity)", "similarity"] : ()), 3613 ($probably_can_string_approx ? ["Ungenaue Suche (String::Approx)", "approx"] : ()), 3614 ) : 3615 ( 3616 # XXX check which one will be used 3617 $probably_can_string_similarity ? ["Ungenaue Suche", "similarity"] : () 3618 #($probably_can_string_approx ? ["Ungenaue Suche", "approx"] : ()), 3619 ) 3620 ) 3621 ) { 3622 my($text, $search_type_value) = @$cb_def; 3623 $f->Radiobutton(-text => M($text), 3624 -variable => \$search_type, 3625 -value => $search_type_value, 3626 )->pack(-anchor => "w"); 3627 } 3628 } 3629 $lb->Subwidget("scrolled")->{SortTypeRef} = \$sort; 3630 { 3631 my $f = $t->LabFrame(-label => M("Suchergebnis sortieren"), 3632 -labelside => "acrosstop", 3633 )->pack(-fill => "x"); 3634 for my $cb_def (["Alphabetisch", "alpha"], 3635 ["nach Entfernung", "dist"], 3636 ["nach Kategorie", "cat"], 3637 ) { 3638 my($text, $sort_value) = @$cb_def; 3639 $f->Radiobutton(-text => M($text), 3640 -variable => \$sort, 3641 -value => $sort_value, 3642 -command => $do_search, 3643 )->pack(-anchor => "w"); 3644 } 3645 } 3646 { 3647 my $f = $t->LabFrame(-label => M("Fokus nach Auswahl"), 3648 -labelside => "acrosstop", 3649 )->pack(-fill => "x"); 3650 $f->Radiobutton(-text => M("Suchfenster"), 3651 -variable => \$focus_transfer, 3652 -value => 0, 3653 )->pack(-anchor => "w"); 3654 $f->Radiobutton(-text => M("Karte"), 3655 -variable => \$focus_transfer, 3656 -value => 1, 3657 )->pack(-anchor => "w"); 3658 } 3659 3660 my $cb; 3661 { 3662 my $f = $t->Frame->pack(-fill => "x"); 3663 $cb = $f->Button(Name => 'close', 3664 -command => sub { 3665 $t->withdraw; 3666 #$t->destroy; 3667 })->pack(-side => "right"); 3668 } 3669 $t->protocol(WM_DELETE_WINDOW => sub { $cb->invoke }); 3670 3671 my $_select = sub { 3672 my($inx) = ($lb->curselection)[0]; 3673 return unless defined $inx; 3674 my $match = $inx2match[$inx]; 3675 3676 if (!defined $match) { 3677 my $f = $lb->get($inx); 3678 return if !$f; 3679 my $abbrev = $file_to_abbrev{$f}; 3680 return if !$abbrev; 3681 choose_ort(@$abbrev); 3682 return; 3683 } 3684 3685 my $transpose; 3686 if ($coord_system ne "standard") { 3687 $transpose = sub { 3688 my($x,$y) = @_; 3689 transpose($coord_system_obj->standard2map($x, $y)); 3690 }; 3691 } else { 3692 $transpose = \&transpose; 3693 } 3694 3695 if (@{$match->[1]} == 1) { 3696 return if !defined $match->[1][0]; 3697 my($xy) = $match->[1][0]; 3698 mark_point(-coords => [[[ $transpose->(split /,/, $xy) ]]], 3699 -clever_center => 1); 3700 return 1; 3701 } elsif (@{$match->[1]} > 1) { 3702 my @line_coords_array; 3703 foreach my $polyline ($match->[1], @{ $match->[3] }) { 3704 my @line_coords; 3705 foreach (@$polyline) { 3706 push @line_coords, [ $transpose->(split /,/, $_) ]; 3707 } 3708 push @line_coords_array, \@line_coords; 3709 } 3710 mark_street(-coords => [@line_coords_array], 3711 -clever_center => 1); 3712 return 1; 3713 } else { 3714 return 0; 3715 } 3716 }; 3717 my $select = sub { 3718 my $ret = $_select->(@_); 3719 if ($ret && $focus_transfer) { 3720 $top->focusForce; 3721 } 3722 $ret; 3723 }; 3724 3725 $lb->bind("<Double-1>" => $select); 3726 $lb->bind("<Return>" => $select); 3727 3728 $t->bind('<<CloseWin>>' => sub { $cb->invoke }); 3729 3730 if ($t->can('UnderlineAll')) { $t->UnderlineAll(-radiobutton => 1, -donotuse => ['N']) } 3731 3732 $t->Popup(@popup_style); 3733 3734 if (defined $s) { 3735 $do_search->(); 3736 } 3737} 3738 3739use vars qw($gps_animation_om $gps_animation_om2); 3740 3741### AutoLoad Sub 3742sub gps_animation_update_optionmenu { 3743 for my $om ($gps_animation_om, $gps_animation_om2) { 3744 if (defined $om && Tk::Exists($om)) { 3745 $om->configure(-options => []); # empty old 3746 for my $i (0 .. MAX_LAYERS) { 3747 my $abk = "L$i"; 3748 if ($str_draw{$abk} && $str_file{$abk} =~ /gpsspeed/) { 3749 $om->addOptions([$str_file{$abk} => $i]); 3750 } 3751 } 3752 if ($om eq $gps_animation_om2) { 3753 $om->addOptions(["" => ""]); 3754 } 3755 } 3756 } 3757} 3758 3759### AutoLoad Sub 3760sub gps_animation { 3761 my $top = shift; 3762 my $t = redisplay_top($top, "gps-track-animation", 3763 -title => M"GPS-Track-Animation"); 3764 return if !defined $t; 3765 $t->transient($top) if $transient; 3766 $t->gridColumnconfigure(0, -weight => 0); 3767 $t->gridColumnconfigure($_, -weight => 1) for (1..2); 3768 my $can_2nd_track = eval { require DB_File; 1 }; 3769 my %track2_cache; 3770 if ($can_2nd_track) { 3771 tie %track2_cache, 'DB_File', undef, undef, undef, $DB_File::DB_BTREE 3772 or warn $!, undef $can_2nd_track; 3773 } 3774 my($trackfile, $trackfile2); 3775 my($track_abk, $track_abk2); 3776 my $track_i = 0; 3777 my $anim_timer; 3778 my($start_b, $skip_b); 3779 my $row = 0; 3780 my $is_first_om = 1; 3781 for my $def ([\$trackfile, \$track_abk, \$gps_animation_om], 3782 [\$trackfile2, \$track_abk2, \$gps_animation_om2], 3783 ) { 3784 my($trackfile_ref, $track_abk_ref, $om_ref) = @$def; 3785 my $om = $t->Optionmenu(-textvariable => $trackfile_ref, 3786 -variable => $track_abk_ref, 3787 -command => sub { 3788 $t->afterCancel($anim_timer) 3789 if defined $anim_timer; 3790 undef $anim_timer; 3791 if (!$is_first_om) { 3792 %track2_cache = (); 3793 } 3794 $track_i = 0; 3795 $start_b->configure(-text => M"Start") 3796 if $start_b && $is_first_om; 3797 })->grid(-row => $row++, -column => 0, -columnspan => 3, -sticky => "w"); 3798 $$om_ref = $om; 3799 $is_first_om = 0; 3800 last if !$can_2nd_track; 3801 } 3802 gps_animation_update_optionmenu(); 3803 3804 # Hooks 3805 my $tpath = $t->PathName; 3806 for my $hook (qw(after_new_layer after_delete_layer)) { 3807 Hooks::get_hooks($hook)->add(\&gps_animation_update_optionmenu, $tpath); 3808 } 3809 $t->OnDestroy 3810 (sub { 3811 for my $hook (qw(after_new_layer after_delete_layer)) { 3812 Hooks::get_hooks($hook)->del($tpath); 3813 } 3814 }); 3815 3816 my $speed; 3817 my $Scale = "Scale"; 3818 my %scaleargs = (-bigincrement => 20, 3819 -resolution => 1, # a -resolution of 10 would make 0 the lowest possible value! 3820 -showvalue => 1, 3821 -variable => \$speed, 3822 ); 3823 # XXX ist LogScale hier eine gute Idee? 3824 eval { 3825 # XXX LogScale und -variable sollte wieder gehen, check! 3826 die "Ich kriege LogScale und -variable hier nicht zum Laufen XXX"; 3827 require Tk::LogScale; 3828 require Tie::Watch; 3829 $Scale = "LogScale"; 3830 my $_speed; 3831 %scaleargs = (-resolution => 0.01, 3832 -variable => \$_speed, 3833 -command => sub { warn $_speed; $speed = int $_speed }, 3834 -showvalue => 0); 3835 }; 3836 $t->Label(-text => M"Zeitraffer-Faktor")->grid(-row => $row, -column => 0, -sticky => "w"); 3837 $t->$Scale(-from => 1, 3838 -to => 500, -orient => "horiz", 3839 %scaleargs)->grid(-row => $row, -column => 1, -columnspan => 2, -sticky => "ew"); 3840 $row++; 3841 3842 for (1 .. 2) { 3843 $c->createRectangle(0,0,0,0,-width=>2,-outline => $_ eq 1 ? "#c08000" : "#80c000", -tags => ["gpsanimrect$_", "gpsanimrect"]); 3844 } 3845 3846 my $dir = +1; 3847 my($curr_speed, $curr_time, $curr_dist, $curr_abs_time); 3848 3849 my $next_track_point; 3850 $next_track_point = sub { 3851 my($tag1,$tag0) = ("L${track_abk}-" . ($track_i+$dir), 3852 "L${track_abk}-" . ($track_i)); 3853 my($name1, $name0) = 3854 (($c->gettags($tag1))[1], ($c->gettags($tag0))[1]); 3855 my($time1min,$time1sec) = $name1 =~ /time=(\d+):(\d+)min/; 3856 my($time0min,$time0sec) = $name0 =~ /time=(\d+):(\d+)min/; 3857 if (!defined $time1min || !defined $time0min) { 3858 # XXX set buttons 3859 warn "Stopped track..."; 3860 return; 3861 } 3862 my $time1 = $time1min*60+$time1sec; 3863 my $time0 = $time0min*60+$time0sec; 3864 3865 $curr_time = "$time1min:$time1sec"; 3866 ($curr_speed) = $name1 =~ m|(\d+)\s*km/h|; 3867 ($curr_dist) = $name1 =~ m|dist=([\d\.]+)|; 3868 3869 my @abstime = $name1 =~ /abstime=(\d+):(\d+):(\d+)/; 3870 $curr_abs_time = sprintf "%02d:%02d:%02d", @abstime; 3871 3872 my $other_tag1; 3873 if ($track_abk2 ne "" && $track_abk2 ne $track_abk) { 3874 if (!%track2_cache) { 3875 my $track_i2 = 0; 3876 while(1) { 3877 my($other_name) = ($c->gettags("L${track_abk2}-".$track_i2))[1]; 3878 last if !$other_name; 3879 my @other_abstime = $other_name =~ /abstime=(\d+):(\d+):(\d+)/; 3880 my $other_abstime = $other_abstime[0]*3600 + $other_abstime[1]*60 + $other_abstime[2]; 3881 $other_abstime = sprintf "%05d", $other_abstime; # leading zeros necessary for string comparison 3882 $track2_cache{$other_abstime} = $track_i2; 3883 $track_i2++; 3884 } 3885 } 3886 3887 my $abstime = $abstime[0]*3600 + $abstime[1]*60 + $abstime[2]; 3888 my $key = sprintf "%0d", $abstime; 3889 my $val; 3890 (tied %track2_cache)->seq($key, $val, DB_File::R_CURSOR()); 3891 my $nearest_i = $val; 3892 if (defined $nearest_i) { 3893 $other_tag1 = "L${track_abk2}-".$nearest_i; 3894 } 3895 } 3896 3897 $anim_timer = 3898 $t->after(1000*abs($time1-$time0)/$speed, sub { 3899 my $item = $c->find(withtag => $tag1); 3900 my($x,$y) = $c->coords($item); 3901 my $pad = 5; 3902 $c->coords("gpsanimrect1", $x-$pad,$y-$pad,$x+$pad,$y+$pad); 3903 $c->center_view($x,$y); 3904 if (defined $other_tag1) { 3905 my $item = $c->find(withtag => $other_tag1); 3906 my($x,$y) = $c->coords($item); 3907 $c->coords("gpsanimrect2", $x-$pad,$y-$pad,$x+$pad,$y+$pad); 3908 } 3909 $track_i+=$dir; 3910 if ($track_i < 0) { 3911 # XXX set start button 3912 warn "Stopped track..."; 3913 return; 3914 } 3915 $next_track_point->(); 3916 }); 3917 }; 3918 3919 $t->Label(-text => M"Geschwindigkeit: ")->grid(-row => $row, -column => 0, -sticky => "w"); 3920 $t->Label(-textvariable => \$curr_speed)->grid(-row => $row, -column => 1, -sticky => "w"); 3921 $t->Label(-text => M"km/h")->grid(-row => $row, -column => 2, -sticky => "w"); 3922 $row++; 3923 3924 $t->Label(-text => M"Distanz: ")->grid(-row => $row, -column => 0, -sticky => "w"); 3925 $t->Label(-textvariable => \$curr_dist)->grid(-row => $row, -column => 1, -sticky => "w"); 3926 $t->Label(-text => M"km")->grid(-row => $row, -column => 2, -sticky => "w"); 3927 $row++; 3928 3929 $t->Label(-text => M"Fahrzeit: ")->grid(-row => $row, -column => 0, -sticky => "w"); 3930 $t->Label(-textvariable => \$curr_time)->grid(-row => $row, -column => 1, -sticky => "w"); 3931 $row++; 3932 3933 $t->Label(-text => M"Zeit: ")->grid(-row => $row, -column => 0, -sticky => "w"); 3934 $t->Label(-textvariable => \$curr_abs_time)->grid(-row => $row, -column => 1, -sticky => "w"); 3935 $row++; 3936 3937 my $before_close_window = sub { 3938 $t->afterCancel($anim_timer) if defined $anim_timer; 3939 $c->delete("gpsanimrect"); 3940 }; 3941 3942 { 3943 my $f = $t->Frame->grid(-row => $row, -column => 0, -columnspan => 3); 3944 $start_b = $f->Button(-text => M"Start", 3945 -command => sub { 3946 if ($start_b->cget(-text) eq M"Start") { 3947 $skip_b->configure(-state => "normal"); 3948 $start_b->configure(-text => M"Pause"); 3949 $track_i = 0; 3950 $next_track_point->(); 3951 } elsif ($start_b->cget(-text) eq M"Fortsetzen") { 3952 $start_b->configure(-text => M"Pause"); 3953 $next_track_point->(); 3954 } else { 3955 $start_b->configure(-text => M"Fortsetzen"); 3956 $t->afterCancel($anim_timer) 3957 if defined $anim_timer; 3958 } 3959 })->pack(-side => "left"); 3960 $f->Button(-text => "<=>", 3961 -command => sub { 3962 $dir = $dir == 1 ? -1 : +1; 3963 })->pack(-side => "left"); 3964 $skip_b = $f->Button(-text => M"�berspringen", 3965 -state => 'disabled', 3966 -command => sub { 3967 $t->afterCancel($anim_timer) 3968 if defined $anim_timer; 3969 $track_i++; 3970 $next_track_point->(); 3971 })->pack(-side => "left"); 3972 $f->Button(-text => M"Schlie�en", 3973 -command => sub { 3974 $before_close_window->(); 3975 $t->destroy; 3976 })->pack(-side => "left"); 3977 } 3978 $t->OnDestroy($before_close_window); 3979 $t->Popup(@popup_style); 3980} 3981 3982use vars qw(%xbase); 3983 3984sub get_dbf_info { 3985 my($dbf_file, $index) = @_; 3986 if (!$xbase{$dbf_file}) { 3987 if (!eval { require XBase; 1 }) { 3988 perlmod_install_advice("XBase"); 3989 return; 3990 } 3991 $xbase{$dbf_file} = XBase->new($dbf_file) or do { 3992 warn XBase->errstr; 3993 return undef; 3994 }; 3995 } 3996 join(":", $xbase{$dbf_file}->get_record($index)); 3997} 3998 3999sub build_text_cursor { 4000 my $text = shift; 4001 if (length($text) > 8) { 4002 warn "`$text' may be too long for cursor"; 4003 } 4004 (my $file_frag = $text) =~ s/[^A-Za-z0-9_-]/_/g; 4005 my $cursor_file = "$tmpdir/cursor_" . $file_frag . ".xbm"; 4006 my $cursor_spec = ['@' . $cursor_file, $cursor_file, "black", "white"]; 4007 if (-r $cursor_file) { 4008 return $cursor_spec; 4009 } 4010 4011 my $ptr = Tk::findINC("images/ptr.xbm"); 4012 if (!$ptr) { 4013 warn "Cannot find ptr.xbm in @INC"; 4014 return undef; 4015 } 4016 4017 if (!is_in_path("pbmtext") || 4018 !is_in_path("pnmcat") || 4019 !is_in_path("xbmtopbm") || 4020 !is_in_path("pbmtoxbm") || 4021 !is_in_path("pnmcrop") 4022 ) { 4023 warn "Netpbm seems to be missing"; 4024 return undef; 4025 } 4026 4027 my $tmp1file = "/tmp/cursortext.$$.pbm"; 4028 my $tmp2file = "/tmp/cursorptr.$$.pbm"; 4029 system("pbmtext \"$text\" | pnmcrop > $tmp1file"); 4030 system("xbmtopbm $ptr > $tmp2file"); 4031 system("pnmcat -white -lr -jbottom $tmp2file $tmp1file | pbmtoxbm | $^X -nle 's/(#define.*height.*)/\$1\\n#define noname_x_hot 1\\n#define noname_y_hot 1\\n/; print' > $cursor_file"); 4032 4033 unlink $tmp1file; 4034 unlink $tmp2file; 4035 4036 if (-s $cursor_file) { 4037 return $cursor_spec; 4038 } else { 4039 warn "Errors while building $cursor_file"; 4040 return undef; 4041 } 4042} 4043 4044sub path_to_selection { 4045 @inslauf_selection = map { 4046 join ",", $coord_system_obj->trim_accuracy(@$_) 4047 } @realcoords; 4048 $c->SelectionOwn; 4049 standard_selection_handle(); 4050} 4051 4052sub marks_to_path { 4053 my @mark_items = $c->find(withtag => "show"); 4054 delete_route(); 4055 for my $item (@mark_items) { 4056 my @coords = $c->coords($item); 4057 for(my $xy_i = 0; $xy_i < $#coords; $xy_i+=2) { 4058 my($xx,$yy) = @coords[$xy_i, $xy_i+1]; 4059 my($x,$y) = anti_transpose($xx,$yy); 4060 addpoint_xy($x,$y,$xx,$yy); 4061 } 4062 } 4063} 4064 4065sub marks_to_selection { 4066 marks_to_path(); 4067 path_to_selection(); 4068} 4069 4070sub active_temp_blockings_for_date_dialog { 4071 $show_active_temp_blockings = 1; 4072 require Tk::DateEntry; 4073 Tk::DateEntry->VERSION("1.38"); 4074 require POSIX; 4075 require Time::Local; 4076 require Data::Dumper; 4077 eval { 4078 require "$FindBin::RealBin/miscsrc/check_bbbike_temp_blockings"; 4079 }; warn $@ if $@; 4080 4081 my @future; 4082 if (BBBike::check_bbbike_temp_blockings->can("process")) { 4083 BBBike::check_bbbike_temp_blockings::process(-f => $BBBike::check_bbbike_temp_blockings::temp_blockings_pl); 4084 BBBike::check_bbbike_temp_blockings::load_file(); 4085 @future = BBBike::check_bbbike_temp_blockings::return_future(); 4086 } 4087 use Data::Dumper;warn Dumper \@future; 4088 4089 my $t = $top->Toplevel(-title => "Datum"); 4090 $t->transient($top) if $transient; 4091 my $date = POSIX::strftime("%Y/%m/%d", localtime); 4092 { 4093 my $f = $t->Frame->pack(-fill => "x"); 4094 Tk::grid($f->Label(-text => "Sperrungen f�r Datum: "), 4095 $f->DateEntry 4096 (-dateformat => 2, 4097 -textvariable => \$date, 4098 -configcmd => sub { 4099 my(%args) = @_; 4100 if (@future && $args{-date}) { 4101 my($d,$m,$y) = @{ $args{-date} }; 4102 my $t1 = Time::Local::timelocal(0,0,0,$d,$m-1,$y-1900); 4103 my $t2 = Time::Local::timelocal(59,59,23,$d,$m-1,$y-1900); 4104 for my $rec (@future) { 4105 next if (defined $rec->{from} && $t1 < $rec->{from}); 4106 next if (defined $rec->{until} && $t2 > $rec->{until}); 4107 $args{-datewidget}->configure(-bg => "red"); 4108 } 4109 } 4110 }, 4111 ) 4112 ); 4113 } 4114 4115 { 4116 my $f = $t->Frame->pack; 4117 Tk::grid($f->Button 4118 (Name => 'ok', 4119 -command => sub { 4120 $t->destroy; 4121 my($y,$m,$d) = split m{/}, $date; 4122 my $now = Time::Local::timelocal(0,0,0,$d,$m-1,$y-1900); 4123 activate_temp_blockings($show_active_temp_blockings, -now => $now); 4124 }), 4125 $f->Button(Name => 'cancel', 4126 -command => sub { 4127 $t->destroy; 4128 })); 4129 } 4130 4131 if (@future) { 4132 my $txt = $t->Scrolled("ROText", -scrollbars => "osoe", 4133 -font => "Courier 9", 4134 -width => 40, -height => 5)->pack(-fill => "both", -expand => 1); 4135 for my $rec (@future) { 4136 $rec->{fromdate} = scalar localtime $rec->{from} 4137 if $rec->{from}; 4138 $rec->{untildate} = scalar localtime $rec->{until} 4139 if $rec->{until}; 4140 } 4141 my $dump; 4142 if (eval { require YAML; 1 }) { 4143 $dump = YAML::Dump(\@future); 4144 } else { 4145 $dump = Data::Dumper->new([@future], [])->Indent(1)->Dump; 4146 } 4147 $txt->insert("end", $dump); 4148 } 4149} 4150 4151sub adjust_map_by_delta { 4152 if (@coords != 2) { 4153 status_message(M"Genau zwei Koordinaten erwartet!", "error"); 4154 return; 4155 } 4156 my $dx = $coords[1]->[0] - $coords[0]->[0]; 4157 my $dy = $coords[1]->[1] - $coords[0]->[1]; 4158 MAPITEMS: 4159 for my $i ($c->find("withtag" => "map")) { 4160 my @t = $c->gettags($i); 4161 for (@t) { 4162 next MAPITEMS if ($_ eq 'map_adjusted'); 4163 } 4164 $c->move($i, $dx, $dy); 4165 $c->addtag("map_adjusted", withtag => $i); 4166 } 4167} 4168 4169sub reset_map_adjusted_tag { 4170 $c->dtag("map_adjusted"); 4171} 4172 4173sub map_button { 4174 my($misc_frame, $curr_row, $col_ref) = @_; 4175 4176 my $map_photo = load_photo($misc_frame, 'map'); 4177 my $karte_check = $misc_frame->$Checkbutton 4178 (image_or_text($map_photo, 'Map'), 4179 -variable => \$map_draw, 4180 -command => sub { getmap($c->get_center, undef, -from_check => 1) }, 4181 )->grid(-row => $curr_row, -column => $$col_ref, -sticky => 's'); 4182 $balloon->attach($karte_check, -msg => M"reale Karte"); 4183 $ch->attach($karte_check, -pod => "^\\s*Karten-Symbol"); 4184 4185 my $kcmb = $misc_frame->Menubutton; 4186 my $kcm = get_map_button_menu($kcmb); 4187 menuright($karte_check, $kcm); 4188 menuarrow($kcmb, $kcm, $$col_ref++, 4189 -menulabel => M"Karte", -special => 'LAYER'); 4190} 4191 4192sub get_map_button_menu { 4193 my($kcmb) = @_; 4194 4195 my $kcm = $kcmb->Menu(-title => M"reale Karte"); 4196 my $set_default_type; 4197 4198 $kcm->checkbutton(-label => M"Karte einblenden", 4199 -variable => \$map_draw, 4200 -command => sub { 4201 getmap($c->get_center, undef, -from_check => 1); 4202 } 4203 ); 4204 4205 $kcm->cascade(-label => M"Kartentypen"); 4206 { 4207 my $kcms = $kcm->Menu(-title => M"Automatische Anpassung"); 4208 $kcm->entryconfigure('last', -menu => $kcms); 4209 foreach (@Karte::map) { 4210 my $o = $Karte::map{$_}; 4211 if ($o->can('coord')) { # check auf Karten-Funktion 4212 $kcms->radiobutton(-label => $o->name, 4213 -variable => \$map_default_type, 4214 -value => $o->token, 4215 ); 4216 } 4217 if ($_ eq 'brbmap') { 4218 my $index = $kcm->index('last'); 4219 push @edit_mode_brb_cmd, sub { $kcm->invoke($index) }; 4220 } elsif ($_ eq 'berlinmap') { 4221 my $index = $kcm->index('last'); 4222 push @edit_mode_b_cmd, sub { $kcm->invoke($index) }; 4223 } 4224 } 4225 } 4226 4227 $kcm->separator; 4228 $kcm->checkbutton(-label => M"WWW", 4229 -variable => \$do_wwwmap, 4230 ); 4231 $kcm->checkbutton(-label => M"WWW-Cache", 4232 -variable => \$use_wwwcache, 4233 ); 4234 $kcm->separator; 4235 $kcm->checkbutton(-label => M"Fallback", 4236 -variable => \$use_map_fallback, 4237 ); 4238 $kcm->checkbutton(-label => M"mit Umgebung", 4239 -variable => \$map_surround, 4240 ); 4241 $kcm->checkbutton(-label => M"mehrere Karten", 4242 -variable => \$dont_delete_map, 4243 ); 4244 $kcm->command(-label => M"Karten l�schen", 4245 -command => \&delete_map, 4246 ); 4247 if ($advanced) { 4248 $kcm->command(-label => M"Karten um Delta verschieben", 4249 -command => \&adjust_map_by_delta, 4250 ); 4251 $kcm->command(-label => M"Reset map_adjusted-Tag", 4252 -command => \&reset_map_adjusted_tag, 4253 ); 4254 } 4255 $kcm->separator; 4256 foreach my $color ([M"Farbe (Photo)", 'color'], 4257 [M"Farbe (Pixmap)", 'pixmap'], 4258 [M"Graustufen", 'gray'], 4259 [M"Schwarz/Wei�", 'mono'], 4260 ) { 4261 $kcm->radiobutton(-label => $color->[0], 4262 -variable => \$map_color, 4263 -value => $color->[1], 4264 ); 4265 } 4266 menu_entry_up_down($kcm, $tag_group{'map'}); 4267 4268 $kcm; 4269} 4270 4271sub special_raise_taggroup { 4272 my($tags, $delay) = @_; 4273 for my $tag (@$tags) { special_raise($tag, 1) } 4274 restack() unless $delay; 4275} 4276 4277sub special_lower_taggroup { 4278 my($tags, $delay) = @_; 4279 for my $tag (reverse @$tags) { special_lower($tag, 1) } 4280 restack() unless $delay; 4281} 4282 4283 4284# REPO BEGIN 4285# REPO NAME module_exists /home/e/eserte/work/srezic-repository 4286# REPO MD5 c80b6d60e318450d245a0f78d516153b 4287 4288=head2 module_exists($module) 4289 4290Return true if the module exists in @INC 4291 4292=cut 4293 4294sub module_exists { 4295 my($filename) = @_; 4296 $filename =~ s{::}{/}g; 4297 $filename .= ".pm"; 4298 return 1 if $INC{$filename}; 4299 foreach my $prefix (@INC) { 4300 my $realfilename = "$prefix/$filename"; 4301 if (-r $realfilename) { 4302 return 1; 4303 } 4304 } 4305 return 0; 4306} 4307# REPO END 4308 43091; 4310 4311__END__ 4312