1# -*- perl -*- 2 3# 4# Copyright (c) 1995-2003,2012 Slaven Rezic. All rights reserved. 5# This is free software; you can redistribute it and/or modify it under the 6# terms of the GNU General Public License, see the file COPYING. 7# 8# Mail: slaven@rezic.de 9# WWW: http://bbbike.sourceforge.net 10# 11 12package Strassen::Core; 13 14package Strassen; 15use strict; 16use BBBikeUtil; 17#require StrassenNetz; # AUTOLOAD: activate 18#require MultiStrassen; # AUTOLOAD: activate 19#require Strassen::Util; # AUTOLOAD: activate 20#require Strasse; # AUTOLOAD: activate 21#use AutoLoader 'AUTOLOAD'; 22use vars qw(@datadirs $OLD_AGREP $VERBOSE $STRICT $VERSION $can_strassen_storable 23 %directive_aliases 24 ); 25 26use enum qw(NAME COORDS CAT); 27use constant LAST => CAT; 28 29$VERSION = '1.96'; 30 31if (defined $ENV{BBBIKE_DATADIR}) { 32 require Config; 33 push @datadirs, split /$Config::Config{'path_sep'}/o, $ENV{BBBIKE_DATADIR}; 34} else { 35 # XXX use BBBikeUtil::bbbike_root().'/data'! 36 push @datadirs, BBBikeUtil::bbbike_root() . '/data'; 37 push @datadirs, ("$FindBin::RealBin/data", './data') 38 if defined $FindBin::RealBin; 39 foreach (@INC) { 40 push @datadirs, "$_/data"; 41 } 42 # XXX push @datadirs, "http://www/~eserte/bbbike/root/data"; 43} 44 45$OLD_AGREP = 0 if !defined $OLD_AGREP; 46 47%directive_aliases = (attrs => "attributes"); 48 49#eval 'require Strassen::Storable; $can_strassen_storable = 1';warn $@ if $@; 50 51# static method to set the datadirs variable according to the used geography 52# object 53sub set_geography { 54 my $geo = shift; 55 @datadirs = $geo->datadir; 56} 57 58# XXX The Autoloader does not work for inherited methods... see 59# MultiStrassen.pm for a non-comprehensive list of problematic methods. 60use vars qw($AUTOLOAD); 61sub AUTOLOAD { 62 warn "Loading Strassen::CoreHeavy for $AUTOLOAD ...\n" 63 if $VERBOSE; 64 require Strassen::CoreHeavy; 65 if (defined &$AUTOLOAD) { 66 goto &$AUTOLOAD; 67 } else { 68 die "Cannot find $AUTOLOAD in ". __PACKAGE__; 69 } 70} 71 72# Arguments: 73# NoRead 74# PreserveLineInfo 75# PreserveComments (currently broken, do not use) 76# UseLocalDirectives 77# CustomPush (only for MapInfo) 78# Strict 79sub new { 80 my($class, $filename, %args) = @_; 81 if (defined $filename) { 82 if ($filename =~ /\.(dbf|sbn|sbx|shp|shx)$/) { 83 require Strassen::ESRI; 84 return Strassen::ESRI->new($filename, %args); 85 } elsif ($filename =~ /\.(mif|mid)$/i) { 86 require Strassen::MapInfo; 87 return Strassen::MapInfo->new($filename, %args); 88 } elsif ($filename =~ /\.e00$/i) { 89 require Strassen::E00; 90 return Strassen::E00->new($filename, %args); 91 } elsif ($filename =~ /\.(wpt|trk|rte)$/) { 92 require Strassen::Gpsman; 93 return Strassen::Gpsman->new($filename, %args); 94 } elsif ($filename =~ /waypoint\.txt$/) { 95 require Strassen::WaypointPlus; 96 return Strassen::WaypointPlus->new($filename, %args); 97 } elsif ($filename =~ /\.ovl$/i) { 98 require Strassen::Gpsman; 99 require GPS::Ovl; 100 my $ovl = GPS::Ovl->new; 101 $ovl->check($filename); 102 my $gpsman_data = $ovl->convert_to_gpsman; 103 return Strassen::Gpsman->new_from_string($gpsman_data, File => $filename, %args); 104 } elsif ($filename =~ /\.(mps|gpx|g7t)$/i) { 105 if ($filename =~ /\.gpx$/ && eval { require Strassen::GPX; 1 }) { 106 return Strassen::GPX->new($filename, %args); 107 } else { 108 require Strassen::FromRoute; 109 return Strassen::FromRoute->new($filename, %args); 110 } 111 } elsif ($filename =~ /\.km[lz]$/i) { 112 if (eval { require Strassen::KML; 1 }) { 113 return Strassen::KML->new($filename, %args); 114 } 115 } elsif ($filename =~ /\.xml$/ && eval { require Strassen::Touratech; 1 }) { 116 # XXX Maybe really check for touratech files 117 return Strassen::Touratech->new($filename, %args); 118 } 119 } 120 121 $class->new_bbd($filename, %args); 122} 123 124sub new_by_magic_or_suffix { 125 my($class, $filename, %args) = @_; 126 my $ret = $class->new_by_magic($filename, %args); 127 return $ret if $ret; 128 $class->new($filename, %args); 129} 130 131sub new_by_magic { 132 my($class, $filename, %args) = @_; 133 if (defined $filename) { 134 open my $fh, $filename 135 or die "Can't open $filename: $!"; 136 read($fh, my($buf), 1024); 137 if ($buf =~ m{<gpx\b}) { 138 require Strassen::GPX; 139 return Strassen::GPX->new($filename, %args); 140 } elsif ($buf =~ m{<kml\b}) { 141 require Strassen::KML; 142 return Strassen::KML->new($filename, %args); 143 } elsif ($buf =~ m{<ttqv\b}) { 144 require Strassen::Touratech; 145 return Strassen::Touratech->new($filename, %args); 146 } elsif ($buf =~ m{^!Format:\s*(DMS|DMM|DDD)}m) { 147 require Strassen::Gpsman; 148 return Strassen::Gpsman->new($filename, %args); 149 } 150 } 151 undef; 152} 153 154sub new_bbd { 155 my($class, $filename, %args) = @_; 156 157 my(@filenames); 158 if (defined $filename) { 159 if (!file_name_is_absolute($filename)) { 160 push @filenames, map { $_ . "/$filename" } @datadirs; 161 } 162 # relative filenames to end 163 push @filenames, $filename; 164 } 165 my $self = { Data => [], 166 Directives => [], 167 GlobalDirectives => {}, 168 }; 169 bless $self, $class; 170 171 if (@filenames) { 172 TRY: { 173 if ($filename eq '-') { 174 $self->{File} = "-"; 175 last TRY; 176 } 177 178 my $file; 179 foreach $file (@filenames) { 180# if (!$args{NoStorable} and $can_strassen_storable and -f "$file.st" and -r _) { 181# my $obj = Strassen::Storable->new("$file.st"); 182# return $obj if $obj; 183# } 184 if (-f $file and -r _) { 185 $self->{File} = $file; 186 if ($file =~ /\.gz$/) { 187 $self->{IsGzipped} = 1; 188 } 189 last TRY; 190 } 191 my $gzfile = "$file.gz"; 192 if (-f $gzfile and -r _) { 193 $self->{File} = $gzfile; 194 $self->{IsGzipped} = 1; 195 last TRY; 196 } 197 } 198 199 require Carp; 200 Carp::confess("Can't open ", join(", ", @filenames)); 201 } 202 unless ($args{NoRead}) { 203 $self->read_data(PreserveLineInfo => $args{PreserveLineInfo}, 204 UseLocalDirectives => $args{UseLocalDirectives}, 205 PreserveComments => $args{PreserveComments}, 206 Strict => $args{Strict}, 207 ); 208 } 209 } 210 211 $self->{Pos} = -1; 212 213 $self; 214} 215 216sub new_stream { 217 my($class, $filename, %args) = @_; 218 $args{NoRead} = 1; 219 $class->new($filename, %args); 220} 221 222sub read_stream { 223 my($self, $callback, %args) = @_; 224 my $fh = $self->open_file(%args); 225 $args{Callback} = $callback; 226 $args{UseLocalDirectives} = 1 if !exists $args{UseLocalDirectives}; 227 $self->read_from_fh($fh, %args); 228} 229 230sub open_file { 231 my($self, %args) = @_; 232 233 my $file = $self->{File}; 234 my $fh; 235 if ($self->{IsGzipped}) { 236 die "Can't execute zcat $file" if !open($fh, "gzip -dc $file |"); 237 } else { 238 if (!open($fh, $file)) { 239 require Carp; 240 Carp::confess("Can't open $file"); 241 } 242 } 243 warn "Read Strassen file $file...\n" if ($VERBOSE && $VERBOSE > 1); 244 $self->{Modtime} = (stat($file))[STAT_MODTIME]; 245 binmode $fh; 246 247 $fh; 248} 249 250sub read_data { 251 my($self, %args) = @_; 252 my $fh = $self->open_file(%args); 253 $self->read_from_fh($fh, %args); 254} 255 256sub read_from_fh { 257 my($self, $fh, %args) = @_; 258 259 my @data; 260 my @directives; 261 262 my $read_only_global_directives = $args{ReadOnlyGlobalDirectives}; 263 my $use_local_directives = $args{UseLocalDirectives}; 264 my $callback = $args{Callback}; 265 my $has_tie_ixhash = eval { 266 require Tie::IxHash; 267 # See http://rt.cpan.org/Ticket/Display.html?id=39619 268 if (!defined &Tie::IxHash::SCALAR) { 269 *Tie::IxHash::SCALAR = sub { 270 scalar @{ $_[0]->[1] }; 271 }; 272 } 273 1; 274 }; 275 276 use constant DIR_STAGE_LOCAL => 0; 277 use constant DIR_STAGE_GLOBAL => 1; 278 my $directives_stage = DIR_STAGE_LOCAL; 279 280 my %global_directives; 281 my %line_directive; 282 if ($has_tie_ixhash) { 283 tie %line_directive, "Tie::IxHash"; 284 tie %global_directives, "Tie::IxHash"; 285 } 286 my @block_directives; 287 my @block_directives_line; 288 my $preserve_line_info = $args{PreserveLineInfo} || 0; 289 my $preserve_comments = $args{PreserveComments} || 0; 290 my @errors; 291 292 local $_; 293 while (<$fh>) { 294 if (/^\#:\s*([^\s:]+):?\s*(.*)$/) { 295 my($directive, $value_and_marker) = ($1, $2); 296 $directive = $directive_aliases{$directive} 297 if exists $directive_aliases{$directive}; 298 my($value, $is_block_begin, $is_block_end); 299 if ($value_and_marker =~ /^\^+\s*$/) { 300 $is_block_end = 1; 301 $value = ""; 302 } else { 303 $value_and_marker =~ /(.*?)(\s*vvv+\s*)?$/; 304 if ($2) { 305 $is_block_begin = 1; 306 } 307 $value = $1; 308 } 309 310 if ($. == 1) { 311 $directives_stage = DIR_STAGE_GLOBAL; 312 } elsif ($directives_stage eq DIR_STAGE_GLOBAL && $_ =~ /^\#:$/) { 313 $directives_stage = DIR_STAGE_LOCAL; 314 } 315 if ($directives_stage == DIR_STAGE_GLOBAL) { 316 push @{ $global_directives{$directive} }, $value; 317 if ($directive eq 'encoding') { 318 switch_encoding($fh, $value); 319 } 320 } elsif ($use_local_directives) { 321 if ($is_block_begin) { 322 push @block_directives, [$directive => $value]; 323 push @block_directives_line, $.; 324 } elsif ($is_block_end) { 325 SEARCH_DIRECTIVE: { 326 for(my $i = $#block_directives; $i >= 0; $i--) { 327 if ($block_directives[$i]->[0] eq $directive) { 328 splice @block_directives, $i, 1; 329 splice @block_directives_line, $i, 1; 330 last SEARCH_DIRECTIVE; 331 } 332 } 333 push @errors, "Unexpected closed directive '$directive' at line $." 334 . ($self->{File} ? " in file " . $self->{File} : "") 335 . ", but expected one of: " 336 . join(", ", map { "$block_directives[$_]->[0] (line $block_directives_line[$_])" } (0 .. $#block_directives)); 337 } 338 } else { 339 push @{ $line_directive{$directive} }, $value; 340 } 341 } 342 next; 343 } 344 $directives_stage = DIR_STAGE_LOCAL if $directives_stage == DIR_STAGE_GLOBAL; 345 last if ($read_only_global_directives); 346 if ($preserve_comments) { 347 next if m{^\#:}; # directives already handled 348 } else { 349 next if m{^(\#|\s*$)}; 350 } 351 352 my $data_pos = $#data + 1; 353 354 my $this_directives; 355 if ($use_local_directives && (@block_directives || %line_directive)) { # Note: %line_directive is a tied hash and slower to check! 356 if (!$callback) { 357 if ($has_tie_ixhash && !$directives[$data_pos]) { 358 tie %{ $directives[$data_pos] }, 'Tie::IxHash'; 359 } 360 $this_directives = $directives[$data_pos]; 361 } else { 362 if ($has_tie_ixhash) { 363 tie %$this_directives, 'Tie::IxHash'; 364 } else { 365 $this_directives = {}; 366 } 367 } 368 369 while(my($directive,$values) = each %line_directive) { 370 push @{ $this_directives->{$directive} }, @$values; 371 } 372 for (@block_directives) { 373 my($directive, $value) = @$_; 374 push @{ $this_directives->{$directive} }, $value; 375 } 376 if (%line_directive) { 377 %line_directive = (); 378 } 379 } 380 381 if (!$callback) { 382 push @data, $_; 383 if ($preserve_line_info) { 384 $self->{LineInfo}[$data_pos] = $.; 385 } 386 } else { 387 $callback->(parse($_), $this_directives, $.); 388 } 389 390 } 391 if (@block_directives) { 392 my $msg = "The following block directives were not closed:"; 393 for my $i (0 .. $#block_directives) { 394 $msg .= " '@{$block_directives[$i]}' (start at line $block_directives_line[$i])"; 395 } 396 die $msg, "\n"; 397 } 398 if (%line_directive) { 399 die "Stray line directive `@{[ keys %line_directive ]}' at end of file\n"; 400 } 401 if (@errors) { 402 warn_or_die("ERROR: found following errors:\n" . join("\n", @errors) . "\n"); 403 } 404 warn "... done\n" if ($VERBOSE && $VERBOSE > 1); 405 close $fh; 406 407 $self->{Data} = \@data; 408 $self->{Directives} = \@directives; 409 $self->{GlobalDirectives} = \%global_directives; 410} 411 412# Return true if there is no data loaded. 413### AutoLoad Sub 414sub has_data { $_[0]->{Data} && @{$_[0]->{Data}} } 415 416# new_from_data can't handle directives: 417### AutoLoad Sub 418sub new_from_data { 419 my($class, @data) = @_; 420 $class->new_from_data_ref(\@data); 421} 422 423# new_from_data_ref can't handle directives: 424### AutoLoad Sub 425sub new_from_data_ref { 426 my($class, $data_ref) = @_; 427 my $self = {}; 428 $self->{Data} = $data_ref; 429 $self->{Pos} = -1; 430 bless $self, $class; 431} 432 433# Note that this constructor expects binary data i.e. *octets* 434# not character data! 435### AutoLoad Sub 436sub new_from_data_string { 437 my($class, $string, %args) = @_; 438 my $self = { Pos => -1 }; 439 bless $self, $class; 440 my $fh; 441 if ($] >= 5.008) { 442 # Make sure we have raw octets. Encoding is controlled 443 # through an "encoding" bbd directive 444 require Encode; 445 if (Encode::is_utf8($string)) { 446 $string = Encode::encode("iso-8859-1", $string); 447 } 448 # string eval because for older perl's this is invalid syntax 449 eval 'open($fh, "<", \$string)'; 450 } else { 451 require IO::String; # XXX add as prereq_pm for <5.008 452 $fh = IO::String->new($string); 453 } 454 $self->read_from_fh($fh, %args); 455 $self; 456} 457 458# Erzeugt ein neues Strassen-Objekt mit Restriktionen 459# -restrictions => \@cats: do not copy records with these categories 460# -grep => \@cats: do only copy records with these categories (only if set) 461# -callback => sub { my($record) = shift; ... }: copy only if the callback 462# returns a true value for the given record 463### AutoLoad Sub 464sub new_copy_restricted { 465 my($class, $old_s, %args) = @_; 466 my %restrictions; 467 my %grep; 468 my $callback; 469 if ($args{-restrictions}) { 470 %restrictions = map { ($_ => 1) } @{ $args{-restrictions} }; 471 } 472 if ($args{-grep}) { 473 %grep = map { ($_ => 1) } @{ $args{-grep} }; 474 } 475 $callback = delete $args{-callback}; 476 477 my $res = $class->new; 478 $old_s->init; 479 while(1) { 480 my $ret = $old_s->next; 481 last if !@{$ret->[COORDS]}; 482 next if (%grep && !exists $grep{$ret->[CAT]}); 483 next if exists $restrictions{$ret->[CAT]}; 484 next if ($callback && !$callback->($ret)); 485 $res->push($ret); 486 } 487 488 $res->{File} = $old_s->file; 489 $res->{DependentFiles} = $old_s->{DependentFiles}; 490 $res->{Id} = $old_s->id . "_restr_" . join("_", keys %restrictions); 491 492 $res; 493} 494 495# Erzeugt aus dem Objekt eine Hash-Referenz mit erster Koordinate als Key 496# und dem Namen als Value. Ist nur f�r ein-Punkt-Daten geeignet. 497# init()/next() wird verwendet! 498### AutoLoad Sub 499sub get_hashref { 500 my($self) = @_; 501 my $hash = {}; 502 503 $self->init; 504 while(1) { 505 my $ret = $self->next; 506 last if !@{$ret->[COORDS]}; 507 $hash->{$ret->[COORDS][0]} = $ret->[NAME]; 508 } 509 510 $hash; 511} 512 513# Wie get_hashref, nur ist hier die Kategorie der Value. 514# init()/next() wird verwendet! 515### AutoLoad Sub 516sub get_hashref_by_cat { 517 my($self) = @_; 518 my $hash = {}; 519 520 $self->init; 521 while(1) { 522 my $ret = $self->next; 523 last if !@{$ret->[COORDS]}; 524 $hash->{$ret->[COORDS][0]} = $ret->[CAT]; 525 } 526 527 $hash; 528} 529 530# Erzeugt ein Hash Name => [Positions] im Data-Array. Optional kann ein 531# CODE ref angegeben werden, um den Hash-Key zu �ndern. 532# init()/next() wird verwendet! 533### AutoLoad Sub 534sub get_hashref_name_to_pos { 535 my($self, $sub) = @_; 536 my $hash = {}; 537 538 $self->init; 539 while(1) { 540 my $ret = $self->next; 541 last if !@{$ret->[COORDS]}; 542 my $name = $sub ? $sub->($ret->[NAME]) : $ret->[NAME]; 543 push @{$hash->{$name}}, $self->pos; 544 } 545 546 $hash; 547} 548 549# Ausgabe des Source-Files 550sub file { shift->{File} } 551 552sub dependent_files { 553 my $self = shift; 554 if ($self->{DependentFiles}) { 555 @{ $self->{DependentFiles} }; 556 } else { 557 defined $self->file ? $self->file : (); 558 } 559} 560 561# ID (f�r Caching) 562sub id { 563 my $self = shift; 564 if (defined $self->{Id}) { 565 return $self->{Id}; 566 } 567 my @depfiles = $self->dependent_files; 568 if (@depfiles) { 569 require File::Basename; 570 my $basedir = File::Basename::basename(File::Basename::dirname($depfiles[0])); 571 $basedir = ($basedir eq "data" ? "" : $basedir . "_"); 572 $basedir . join("_", map { File::Basename::basename($_) } @depfiles); 573 } else { 574 undef; 575 } 576} 577 578### AutoLoad Sub 579sub as_string { 580 my($self, %args) = @_; 581 my $s = ""; 582 my $maybe_need_directive_separator = 1; 583 if (!$args{IgnoreDirectives}) { 584 $s = $self->global_directives_as_string; # force at beginning of $s 585 if ($s ne '') { 586 $maybe_need_directive_separator = 0; 587 } 588 } 589 if (!$args{IgnoreDirectives} && $self->{Directives}) { 590 if ($maybe_need_directive_separator && $self->{Directives}[0] && keys %{ $self->{Directives}[0] }) { 591 $s .= "#:\n"; 592 } 593 my %current_block_directives; 594 my $current_block_directives_i = 1; 595 for my $pos (0 .. $#{$self->{Data}}) { 596 my @close_blocks; 597 if ($self->{Directives}[$pos]) { 598 while(my($directive,$values) = each %{ $self->{Directives}[$pos] }) { 599 for my $value (@$values) { 600 my $continuing_to_next_line = 0; 601 if ($pos < $#{$self->{Data}}) { 602 if ($self->{Directives}[$pos+1] && 603 exists $self->{Directives}[$pos+1]{$directive} && 604 grep { $_ eq $value } @{ $self->{Directives}[$pos+1]{$directive} }) { 605 $continuing_to_next_line = 1; 606 } 607 } 608 if ($continuing_to_next_line && !$current_block_directives{$directive}{$value}) { 609 $s .= "#: $directive: $value vvv\n"; 610 $current_block_directives{$directive}{$value} = $current_block_directives_i++; 611 } elsif ($continuing_to_next_line && $current_block_directives{$directive}{$value}) { 612 # do nothing 613 } elsif (!$continuing_to_next_line && $current_block_directives{$directive}{$value}) { 614 push @close_blocks, { content => "#: $directive: ^^^\n", line => $current_block_directives{$directive}{$value} }; 615 delete $current_block_directives{$directive}{$value}; 616 } else { 617 $s .= "#: $directive: $value\n"; 618 } 619 } 620 } 621 } 622 $s .= $self->{Data}[$pos]; 623 $s .= join "", map { $_->{content} } sort { $b->{line} <=> $a->{line} } @close_blocks; 624 } 625 $s; 626 } else { 627 $s . join "", @{ $self->{Data} }; 628 } 629} 630 631### AutoLoad Sub 632sub global_directives_as_string { 633 my($self) = @_; 634 return "" if (!$self->{GlobalDirectives} || !keys %{$self->{GlobalDirectives}}); 635 my $s = ""; 636 while(my($k,$v) = each %{ $self->{GlobalDirectives} }) { 637 $s .= join("\n", map { "#: $k: $_" } @$v) . "\n"; 638 } 639 $s .= "#:\n"; # end global directives 640 $s; 641} 642 643### AutoLoad Sub 644sub _write { 645 my($self, $filename, %args) = @_; 646 if (!defined $filename) { 647 $filename = $self->file; 648 } 649 if (!defined $filename) { 650 warn "No filename specified"; 651 return 0; 652 } 653 my $mode = delete $args{mode}; 654 if (open(my $COPY, "$mode $filename")) { 655 my $global_dirs = $self->get_global_directives; 656 binmode $COPY; 657 if ($global_dirs->{encoding}) { 658 binmode $COPY, ":encoding(". $global_dirs->{encoding}->[0] . ")"; 659 } 660 print $COPY $self->as_string(%args); 661 close $COPY; 662 1; 663 } else { 664 warn "Can't write/append to $filename: $!" if $VERBOSE; 665 0; 666 } 667} 668 669### AutoLoad Sub 670sub write { 671 my($self, $filename, %args) = @_; 672 $self->_write($filename, mode => ">", %args); 673} 674 675### AutoLoad Sub 676sub append { 677 my($self, $filename, %args) = @_; 678 $self->_write($filename, mode => ">>", %args); 679} 680 681sub get { 682 my($self, $pos) = @_; 683 return [undef, [], undef] if $pos < 0; 684 my $line = $self->{Data}->[$pos]; 685 parse($line); 686} 687 688sub get_directives { 689 my($self, $pos) = @_; 690 $pos = $self->{Pos} if !defined $pos; 691 return {} if !$self->{Directives}; 692 $self->{Directives}[$pos] || {}; 693} 694 695sub set_directives_for_current { 696 my($self, $directives) = @_; 697 my $pos = $#{ $self->{Data} }; 698 $self->{Directives}[$pos] = $directives; 699} 700 701sub get_directives_for_iterator { 702 my($self, $iterator) = @_; 703 my $pos = $self->{"Pos_Iterator_$iterator"}; 704 $self->get_directives($pos); 705} 706 707BEGIN { 708 # These are misnomers (singular vs. plural), but kept for 709 # backward compatibility. 710 *get_directive = \&get_directives; 711 *set_directive_for_current = \&set_directives_for_current; 712 *get_directive_for_iterator = \&get_directives_for_iterator; 713} 714 715# Returns a list of all elements in the streets database 716# Warning: this method resets the iterator! 717### AutoLoad Sub 718sub get_all { 719 my $self = shift; 720 my @res; 721 $self->init; 722 while(1) { 723 my $r = $self->next; 724 return @res if !@{ $r->[COORDS] }; 725 push @res, $r; 726 } 727} 728 729# F�r den angegebenen Namen wird die erste gefundene Zeile im selben Format 730# wie bei get(), next() und parse() zur�ckgegeben. 731# Achtung: da mit init() und next() gearbeitet wird, wird durch diese Methode 732# eine laufende Schleife aus dem Konzept gebracht! 733# If $rxcmp is true, then a regexp match is done. 734### AutoLoad Sub 735sub get_by_name { 736 my($self, $name, $rxcmp) = @_; 737 $self->init; 738 while(1) { 739 my $ret = $self->next; 740 return undef if !@{$ret->[COORDS]}; 741 return $ret if ((!$rxcmp && $ret->[NAME] eq $name) || 742 ( $rxcmp && $ret->[NAME] =~ /$name/)); 743 } 744} 745 746# Like get_by_name, but return all matching streets in a list. 747sub get_all_by_name { 748 my($self, $name, $rxcmp) = @_; 749 my @res; 750 $self->init; 751 while(1) { 752 my $ret = $self->next; 753 last if !@{$ret->[COORDS]}; 754 push @res, $ret if ((!$rxcmp && $ret->[NAME] eq $name) || 755 ( $rxcmp && $ret->[NAME] =~ /$name/)); 756 } 757 @res; 758} 759 760# Like get_all_by_name, but specify street name and citypart 761sub get_by_strname_and_citypart { 762 my($self, $strname, $citypart) = @_; 763 require Strassen::Strasse; 764 my @res; 765 $self->init; 766 while(1) { 767 my $ret = $self->next; 768 last if !@{$ret->[COORDS]}; 769 my($strname2,@cityparts2) = Strasse::split_street_citypart($ret->[NAME]); 770 if ($strname eq $strname2) { 771 if (!defined $citypart || !@cityparts2) { 772 push @res, $ret; 773 } else { 774 for my $citypart2 (@cityparts2) { 775 if ($citypart eq $citypart2) { 776 push @res, $ret; 777 last; 778 } 779 } 780 } 781 } 782 } 783 @res; 784} 785 786# XXX Die zwei verschiedenen Aufrufarten f�r das Koordinatenargument in 787# set und push ist unbefriedigend. 788### AutoLoad Sub 789sub set { 790 my($self, $index, $arg) = @_; 791 $self->{Data}[$index] = arr2line($arg); 792} 793sub set_current { 794 my($self, $arg) = @_; 795 $self->set($self->{Pos}, $arg); 796} 797 798sub set2 { 799 my($self, $index, $arg) = @_; 800 $self->{Data}[$index] = arr2line2($arg) . "\n"; 801} 802sub set_current2 { # preferred for usage in init/next loops 803 my($self, $arg) = @_; 804 $self->set2($self->{Pos}, $arg); 805} 806 807# Arguments: [name, [xy1, xy2, ...], cat], 808# which is the same as the return value of next(). 809sub push { 810 my($self, $arg) = @_; 811 my $x = [$arg->[NAME], join(" ", @{$arg->[COORDS]}), $arg->[CAT]]; 812 push @{$self->{Data}}, arr2line($x); 813} 814 815# Push with directives 816sub push_ext { 817 my($self, $arg, $dir) = @_; 818 if ($dir) { 819 my $pos = @{$self->{Data}} || 0; 820 $self->{Directives}[$pos] = $dir; 821 } 822 $self->push($arg); 823} 824 825sub push_unparsed { 826 my($self, $comment) = @_; 827 CORE::push(@{$self->{Data}}, $comment); 828} 829 830sub delete_current { # funktioniert in init/next-Schleifen 831 my($self) = @_; 832 return if $self->{Pos} < 0; 833 splice @{ $self->{Data} }, $self->{Pos}, 1; 834 for my $member (qw(Directives LineInfo)) { 835 if ($self->{$member}) { 836 splice @{ $self->{$member} }, $self->{Pos}, 1; 837 } 838 } 839 $self->{Pos}--; 840 # XXX invalidate get_hashref_name_to_pos result 841 # XXX invalidate all_crossings result 842} 843 844# wandelt eine Array-Referenz ["name", $Koordinaten, "cat"] in 845# einen String zum Abspeichern um 846# Achtung: das Koordinaten-Argument ist hier anders als beim R�ckgabewert von 847# parse()! Siehe arr2line2(). 848# Tabs und Newlines werden aus dem Namen entfernt 849# Achtung: ein "\n" wird angeh�ngt 850### AutoLoad Sub 851sub arr2line { 852 my $arg = shift; 853 (my $name = $arg->[NAME]) =~ s/[\t\n]/ /; 854 "$name\t$arg->[CAT] $arg->[COORDS]\n" 855} 856 857# wie arr2line, aber ohne Newline 858# Tabs und Newlines werden aus dem Namen entfernt 859### AutoLoad Sub 860sub _arr2line { 861 my $arg = shift; 862 (my $name = $arg->[NAME]) =~ s/[\t\n]/ /; 863 "$name\t$arg->[CAT] $arg->[COORDS]" 864} 865 866# Wie _arr2line, aber das COORDS-Argument ist eine Array-Referenz wie 867# beim R�ckgabewert von parse(). 868# Tabs und Newlines werden aus dem Namen entfernt. 869# Ein Newline fehlt hier und muss manuell angef�gt werden, falls der Datensatz 870# in $self->{Data} geschrieben werden soll. 871### AutoLoad Sub 872sub arr2line2 { 873 my $arg = shift; 874 (my $name = $arg->[NAME]) =~ s/[\t\n]/ /; 875 "$name\t$arg->[CAT] " . join(" ", @{ $arg->[COORDS] }); 876} 877 878# This is a static method 879sub parse { 880 # $_[0] is $line 881 # my $_[0] = shift; 882 return [undef, [], undef] if !$_[0]; 883 my $tab_inx = index($_[0], "\t"); 884 if ($tab_inx < 0) { 885 if ($_[0] !~ m{^#}) { # do not warn on comments 886 warn_or_die("*** ERROR: Probably tab character is missing (line <$_[0]>)\n"); 887 } 888 [$_[0]]; 889 } else { 890 my @s = split /\s+/, substr($_[0], $tab_inx+1); 891 my $category = shift @s; 892 if (!@s && $s[0] !~ m{^#}) { # do not warn on comments 893 warn_or_die("*** ERROR: Probably wrong formatted bbd line (line <$_[0]>)\n"); 894 } 895 [substr($_[0], 0, $tab_inx), \@s, $category]; 896 } 897} 898 899### AutoLoad Sub 900sub get_obj { 901 my($self, $pos) = @_; 902 Strasse->new($self->get($pos)); 903} 904 905# initialisiert f�r next() und gibt *keinen* Wert zur�ck 906sub init { 907 my $self = shift; 908 $self->{Pos} = -1; 909} 910 911# Like init(), but use a private iterator 912sub init_for_iterator { 913 my($self, $iterator) = @_; 914 $self->{"Pos_Iterator_$iterator"} = -1; 915} 916 917# Setzt den Index auf den angegeben Wert (jedenfalls so, dass ein 918# anschlie�endes next() das richtige zur�ckgibt). 919sub set_index { 920 $_[0]->{Pos} = $_[1] - 1; 921} 922 923sub set_last { 924 $_[0]->{Pos} = scalar @{$_[0]->{Data}} - 1; 925} 926 927# initialisiert f�r next() und gibt den ersten Wert zur�ck 928### AutoLoad Sub 929sub first { 930 my $self = shift; 931 $self->{Pos} = 0; 932 $self->get(0); 933} 934 935# Return the next record and increment the iterator 936sub next { 937 my $self = shift; 938 $self->get(++($self->{Pos})); 939} 940 941# Return the next record without incrementing the iterator 942sub peek { 943 my $self = shift; 944 $self->get($self->{Pos}+1); 945} 946 947# Like next(), but use a private iterator 948sub next_for_iterator { 949 my($self, $iterator) = @_; 950 $self->get(++($self->{"Pos_Iterator_$iterator"})); 951} 952 953sub prev { 954 my $self = shift; 955 $self->get(--($self->{Pos})); 956} 957 958sub next_obj { 959 my $self = shift; 960 $self->get_obj(++($self->{Pos})); 961} 962 963# Return next comment or undef, if it's not a comment 964sub next_comment { 965 my $self = shift; 966 return undef if $self->{Pos}+1 > $#{$self->{Data}}; 967 return undef if $self->{Data}[$self->{Pos}+1] !~ /^#/; 968 return $self->{Data}[$self->{Pos}++]; 969} 970 971sub count { 972 my $self = shift; 973 scalar @{$self->{Data}}; 974} 975 976# gibt die aktuelle Position zur�ck 977sub pos { shift->{Pos} } 978 979sub line { 980 my $self = shift; 981 $self->{LineInfo}[$self->{Pos}]; 982} 983 984# Accessor for Data (but it's OK to use {Data}) 985sub data { shift->{Data} } 986 987# Gibt die Positionen (als Array) f�r einen bestimmten Namen zur�ck 988# Achtung: eine laufende init/next-Schleife wird hiermit zur�ckgesetzt! 989### AutoLoad Sub 990sub pos_from_name { 991 my($self, $name) = @_; 992 my @res; 993 my $found = 0; 994 $self->init; 995 while(1) { 996 my $ret = $self->next; 997 last if !@{$ret->[COORDS]}; 998 if ($ret->[NAME] eq $name) { 999 CORE::push(@res, $self->pos); 1000 $found++; 1001 } elsif ($found) { 1002 last; 1003 } 1004 } 1005 @res; 1006} 1007 1008# for Object::Iterate 1009*__init__ = \&init; 1010sub __more__ { $_[0]->{Pos} < $#{$_[0]->{Data}} } 1011*__next__ = \&next; 1012 1013# Statische Methode. 1014# Wandelt die Indices aus dem Ergebnis von get() (2. Element) in 1015# Koordinaten um (Format des Arguments: ["x1,y1", "x2,y2", ...]) 1016# Gibt eine Referenz auf ein Array zur�ck: [[x1,y1], [x2,y2] ...] 1017sub to_koord_slow { 1018 my($resref) = @_; 1019 my @res; 1020 foreach (@$resref) { 1021 if (/^(-?\d+),(-?\d+)$/) { 1022 CORE::push(@res, [$1, $2]); 1023 } elsif (/(-?\d+),(-?\d+)$/) { # ignore prefix XXX 1024 CORE::push(@res, [$1, $2]); 1025 } elsif ($_ eq '*') { 1026 CORE::push(@res, $_); 1027 } elsif (/(-?\d+(?:\.\d*)?),(-?\d+(?:\.\d*)?)$/) { # float numbers 1028 CORE::push(@res, [$1, $2]); 1029 } else { 1030 warn "Unrecognized reference in <@$resref>: <$_>"; 1031 return []; 1032 } 1033 } 1034 \@res; 1035} 1036 1037# Statische Methode. 1038# wie to_koord, nur f�r einen Punkt 1039# XXX Koordinaten der Form prefix(x,y) bearbeiten 1040sub to_koord1_slow { 1041 my($s) = @_; 1042 if ($s =~ /^(-?\d+),(-?\d+)$/) { 1043 [$1, $2]; 1044 } elsif ($s =~ /^((:[^:]*:)?([A-Za-z])?)?(-?\d+),(-?\d+)$/) { 1045 # Ausgabe: x, y, coordsystem, bahnhof 1046 [$4, $5, $3, $2]; 1047 } elsif ($s =~ /(-?\d+(?:\.\d*)?),(-?\d+(?:\.\d*)?)$/) { # float numbers 1048 [$1, $2]; 1049 } else { 1050 warn "Unrecognized string: $s..."; 1051 [undef, undef]; # XXX 1052 } 1053} 1054 1055*to_koord = \&to_koord_slow; 1056*to_koord1 = \&to_koord1_slow; 1057*to_koord_f = \&to_koord_slow; 1058*to_koord_f1 = \&to_koord1_slow; 1059 1060# Return crossings as an array or hash reference. 1061# Argumente: 1062# RetType: hash, hashpos, array (default) oder arraypos 1063# Bei den ...pos-Varianten wird statt des Stra�ennamens die 1064# Position im Strassen-Objekt zur�ckgegeben. 1065# UseCache: gibt an, ob vom Cache gelesen und ein Cache geschrieben werden 1066# soll 1067# Kurvenpunkte: bei TRUE werden auch die Kurvenpunkte zur�ckgegeben 1068# AllPoints: synonym for KurvenPunkte 1069# 1070# See below for the output forms. 1071### AutoLoad Sub 1072sub all_crossings { 1073 my($self, %args) = @_; 1074 my $rettype = $args{RetType}; 1075 my $use_cache = $args{UseCache}; 1076 my $all_points = $args{AllPoints} || $args{Kurvenpunkte}; 1077 my $min_strassen = ($all_points ? 1 : 2); 1078 1079 if (!defined $rettype) { $rettype = 'array' } 1080 if ($rettype !~ /^(array|hash)(pos)?$/) { 1081 die "Wrong RetType $rettype"; 1082 } 1083 my $cachefile; 1084 if ($use_cache) { 1085 my $basename = $self->id; 1086 $cachefile = "all_crossings_${basename}_$rettype"; 1087 if ($all_points) { 1088 $cachefile .= "_kurvenp"; 1089 } 1090 if ($self->{Inaccessible}) { 1091 $cachefile .= "_inacc"; 1092 } 1093 } 1094 if ($use_cache && $rettype =~ /^hash/) { 1095 require Strassen::Util; 1096 my $hashref = Strassen::Util::get_from_cache($cachefile, [$self->dependent_files]); 1097 if (defined $hashref) { 1098 warn "Using cache for $cachefile\n" if $VERBOSE; 1099 return $hashref; 1100 } 1101 } 1102 1103 my $inacc; 1104 if ($self->{Inaccessible}) { 1105 require Strassen::Kreuzungen; 1106 my $cr = Kreuzungen->new_from_strassen 1107 (WantPos => 1, 1108 Strassen => $self->{Inaccessible}, 1109 ); 1110 $inacc = $cr->{Hash}; 1111 } 1112 1113 # RetType ...pos: Positionen statt Stra�ennamen speichern 1114 my $store_pos = ($rettype =~ /pos$/); 1115 my %crossings; 1116 my %crossing_name; 1117 $self->init(); 1118 while(1) { 1119 my $ret = $self->next(); 1120 my @kreuzungen = @{$ret->[COORDS]}; 1121 last if @kreuzungen == 0; 1122 my $store = ($store_pos ? $self->pos : $ret->[NAME]); 1123 for my $xy (@kreuzungen) { 1124 next if $inacc && exists $inacc->{$xy}; 1125 $crossings{$xy}++; 1126 TEST: { 1127 for my $test (@{$crossing_name{$xy}}) { 1128 last TEST if ($test eq $store); 1129 } 1130 CORE::push(@{$crossing_name{$xy}}, $store); 1131 } 1132 } 1133 } 1134 if ($rettype =~ /^hash/) { # R�ckgabewert: "x,y" => [name1,name2 ...] 1135 my @to_del; 1136 while(my($k, $v) = each %crossings) { 1137 if ($v < $min_strassen) { 1138 CORE::push(@to_del, $k); 1139 } else { 1140 $crossings{$k} = $crossing_name{$k}; 1141 } 1142 } 1143 foreach (@to_del) { 1144 delete $crossings{$_}; 1145 } 1146 if ($use_cache) { 1147 require Strassen::Util; 1148 if (Strassen::Util::write_cache(\%crossings, $cachefile)) { 1149 warn "Wrote cache ($cachefile)\n" if $VERBOSE; 1150 } 1151 } 1152 \%crossings; 1153 } else { # R�ckgabewert: [x, y, "name1/name2/..."] 1154 my @crossings; 1155 while(my($k, $v) = each %crossings) { 1156 if ($v >= $min_strassen) { 1157 my($x, $y) = split(/,/, $k); 1158 CORE::push(@crossings, [$x, $y, join("/", @{$crossing_name{$k}})]); 1159 } 1160 } 1161 \@crossings; 1162 } 1163} 1164 1165### AutoLoad Sub 1166sub strip_bezirk { require Strassen::Strasse; Strasse::strip_bezirk(@_) } 1167 1168# F�r Orte: trennt den Namen vom Zusatz (z.B. ("Frankfurt", "Oder") 1169### AutoLoad Sub 1170sub split_ort { 1171 split /\|/, $_[0], 2; 1172} 1173 1174# Arguments (hash-style): 1175# UseCache: use cache 1176# Exact: use "exact" algorithm 1177# GridHeight, GridWidth: grid extents (by default 1000, for WGS84 data 0.01 degrees) 1178# With -rebuild => 1 the grid will be build again. 1179# Uses the private Strassen::Core iterator "make_grid". 1180# Specify another coordinate system with -tomap (like in get_conversion) 1181### AutoLoad Sub 1182sub make_grid { 1183 my($self, %args) = @_; 1184 if ($args{-rebuild} && $self->{Grid}) { 1185 %args = (GridWidth => $self->{GridWidth}, 1186 GridHeight => $self->{GridHeight}, 1187 Exact => $self->{GridIsExact}, 1188 UseCache => $self->{GridUseCache}, 1189 ); 1190 } 1191 my $use_cache = $args{UseCache}; 1192 my $use_exact = $args{Exact}||0; 1193 my $get_default_grid_width = sub { 1194 if (!$args{-tomap}) { 1195 my $map = $self->get_global_directive('map'); 1196 if ($map && $map eq 'polar') { 1197 return 0.01; 1198 } 1199 } 1200 1000; 1201 }; 1202 $self->{GridWidth} = (defined $args{GridWidth} 1203 ? $args{GridWidth} : $get_default_grid_width->()); 1204 $self->{GridHeight} = (defined $args{GridHeight} 1205 ? $args{GridHeight} : $self->{GridWidth}); 1206 my $conv; 1207 if ($args{-tomap}) { 1208 $conv = $self->get_conversion(-tomap => $args{-tomap}); 1209 } 1210 my $cachefile = "grid" . ($use_exact ? "x" : "") . "_" . $self->id . 1211 "_" . $self->{GridWidth}."x".$self->{GridHeight}; 1212 if ($conv) { 1213 $cachefile .= "_" . $args{-tomap}; 1214 } 1215 if ($use_cache) { 1216 require Strassen::Util; 1217 my $hashref = Strassen::Util::get_from_cache($cachefile, [$self->dependent_files]); 1218 if (defined $hashref) { 1219 warn "Using grid cache for $cachefile\n" if $VERBOSE; 1220 $self->{Grid} = $hashref; 1221 return; 1222 } 1223 } 1224 $self->{Grid} = {}; 1225 $self->{GridIsExact} = $use_exact; 1226 $self->{GridUseCache} = $use_cache; 1227 $self->{GridConv} = $conv; 1228 my $grid_build = ($use_exact 1229 ? $self->_make_grid_exact 1230 : $self->_make_grid_fast); 1231 while(my($g, $v) = each %$grid_build) { 1232 $self->{Grid}{$g} = [keys %$v]; 1233 } 1234 if ($use_cache) { 1235 require Strassen::Util; 1236 if (Strassen::Util::write_cache($self->{Grid}, $cachefile)) { 1237 warn "Wrote cache ($cachefile)\n" if $VERBOSE; 1238 } 1239 } 1240} 1241 1242### AutoLoad Sub 1243sub _make_grid_fast { 1244 my $self = shift; 1245 my %grid_build; 1246 $self->init_for_iterator("make_grid"); 1247 my $conv = $self->{GridConv}; 1248 my $strpos = 0; 1249 while(1) { 1250 my $r = $self->next_for_iterator("make_grid"); 1251 last if !@{$r->[COORDS]}; 1252 foreach my $c (@{$r->[COORDS]}) { 1253 $c = $conv->($c) if $conv; 1254 $grid_build{join(",",$self->grid(split(/,/, $c)))}->{$strpos}++; 1255 } 1256 $strpos++; 1257 } 1258 \%grid_build; 1259} 1260 1261### AutoLoad Sub 1262sub _make_grid_exact { 1263 my $self = shift; 1264 1265 if (!eval { require VectorUtil; 1 }) { 1266 warn "Can't load VectorUtil.pm, fallback to _make_grid_fast"; 1267 return $self->_make_grid_fast; 1268 } 1269 eval { 1270 require VectorUtil::InlineDist; 1271 }; 1272 if ($@ && $VERBOSE) { warn $@ } 1273 1274 my %grid_build; 1275 $self->init_for_iterator("make_grid"); 1276 my $conv = $self->{GridConv}; 1277 my $strpos = 0; 1278 while(1) { 1279 my $r = $self->next_for_iterator("make_grid"); 1280 last if !@{$r->[COORDS]}; 1281 my @c; 1282 if ($conv) { 1283 @c = map { $conv->($_) } @{ $r->[COORDS] }; 1284 } else { 1285 @c = @{ $r->[COORDS] }; 1286 } 1287 if (@c == 1) { 1288 $grid_build{join(",",$self->grid(split(/,/, $c[0])))}->{$strpos}++; 1289 } else { 1290 for my $i (0 .. $#c-1) { 1291 my($x1, $y1) = split(',', $c[$i]); 1292 my($x2, $y2) = split(',', $c[$i+1]); 1293 my($from_grid_x, $from_grid_y) = $self->grid($x1,$y1); 1294 my($to_grid_x, $to_grid_y) = $self->grid($x2,$y2); 1295 ($from_grid_x, $to_grid_x) = ($to_grid_x, $from_grid_x) 1296 if $to_grid_x < $from_grid_x; 1297 ($from_grid_y, $to_grid_y) = ($to_grid_y, $from_grid_y) 1298 if $to_grid_y < $from_grid_y; 1299 for my $grid_x ($from_grid_x .. $to_grid_x) { 1300 for my $grid_y ($from_grid_y .. $to_grid_y) { 1301 my $grid_xy = join(",", $grid_x, $grid_y); 1302 next if $grid_build{$grid_xy}->{$strpos}; 1303 $grid_build{$grid_xy}->{$strpos}++ 1304 if VectorUtil::vector_in_grid($x1,$y1,$x2,$y2, 1305 $grid_x*$self->{GridWidth}, $grid_y*$self->{GridHeight}, ($grid_x+1)*$self->{GridWidth}, ($grid_y+1)*$self->{GridHeight}); 1306 } 1307 } 1308 } 1309 } 1310 $strpos++; 1311 } 1312 \%grid_build; 1313} 1314 1315### AutoLoad Sub 1316sub grid { 1317 my($self, $x, $y) = @_; 1318 my($gx,$gy) = (int($x/$self->{GridWidth}), int($y/$self->{GridHeight})); 1319 $gx-- if $x < 0; 1320 $gy-- if $y < 0; 1321 ($gx,$gy); 1322} 1323 1324# Gibt eine Liste mit den neuen Gitterquadranten f�r die 1325# Koordinateneckpunte aus. Mit dem Argument KnownGrids k�nnen bereits 1326# bekannte Quadranten aus der Liste ausgeschlossen werden. 1327### AutoLoad Sub 1328sub get_new_grids { 1329 my($self, $x1, $y1, $x2, $y2, %args) = @_; 1330 if ($x2 < $x1) { ($x2, $x1) = ($x1, $x2) } 1331 if ($y2 < $y1) { ($y2, $y1) = ($y1, $y2) } 1332 my $known_grids = {}; 1333 if (exists $args{'KnownGrids'} and ref $args{'KnownGrids'} eq 'HASH') { 1334 $known_grids = $args{'KnownGrids'}; 1335 } 1336 my @new_grids; 1337 my($x,$ybeg) = $self->grid($x1,$y1); 1338 my($xend,$yend) = $self->grid($x2,$y2); 1339 while ($x <= $xend) { 1340 my $y = $ybeg; 1341 while ($y <= $yend) { 1342 my $xy = "$x,$y"; 1343 if (!$known_grids->{$xy}) { 1344 CORE::push(@new_grids, $xy); 1345 $known_grids->{$xy}++; 1346 } 1347 $y++; 1348 } 1349 $x++; 1350 } 1351 1352 @new_grids; 1353} 1354 1355# Checks if the coordinate is present in the Strassen data, so there is no 1356# need to create a $net. The coord is in the form "$x,$y". 1357# Warning: Initializes the iterator! 1358sub reachable { 1359 my($self, $coord) = @_; 1360 $self->init; 1361 while(1) { 1362 my $ret = $self->next; 1363 return 0 if !@{ $ret->[Strassen::COORDS] }; 1364 foreach my $c (@{ $ret->[Strassen::COORDS] }) { 1365 return 1 if ($c eq $coord); 1366 } 1367 } 1368} 1369 1370# Get the nearest point "$x,$y" at a street for the given point. 1371# Further arguments: 1372# FullReturn: return all information instead only the returned point 1373# AllReturn: return an array reference with the data for all nearest points, 1374# not just the first one 1375# The returned object contains: 1376# StreetObj: the street object (result of Strassen::get) 1377# N: the index of the street object in Strassen->{Data} 1378# CoordIndex: the index of Coord in the Strassen::COORDS array 1379# Dist: the distance from the given point to Coord 1380# Coord: the nearest coordinate to the given point 1381# Uses the private iterator "make_grid" 1382sub nearest_point { 1383 my($s, $xy, %args) = @_; 1384 my($x,$y) = split /,/, $xy; 1385 require Strassen::Util; 1386 my $mindist = Strassen::Util::infinity(); 1387 my @line; 1388 1389 if (!defined &VectorUtil::distance_point_line) { 1390 require VectorUtil; 1391 eval { 1392 require VectorUtil::InlineDist; 1393 }; 1394 if ($@ && $VERBOSE) { warn $@ } 1395 } 1396 1397 $s->make_grid(UseCache => 1, 1398 Exact => 1) unless $s->{Grid}; 1399 my($grx,$gry) = $s->grid($x,$y); 1400 1401 my %seen; 1402 for my $xx ($grx-1 .. $grx+1) { 1403 for my $yy ($gry-1 .. $gry+1) { 1404 # prevent autovivify (bad for CDB_File) 1405 next unless (exists $s->{Grid}{"$xx,$yy"}); 1406 foreach my $n (@{ $s->{Grid}{"$xx,$yy"} }) { 1407 next if $seen{$n}; 1408 $seen{$n}++; 1409 my $r = $s->get($n); 1410 1411 my @p; 1412 foreach (@{ $r->[Strassen::COORDS] }) { 1413 CORE::push(@p, split /,/, $_); 1414 } 1415 1416 if (@p == 2) { # point 1417 my $new_mindist = sqrt(sqr($x-$p[0])+sqr($y-$p[1])); 1418 if ($mindist >= $new_mindist) { 1419 my $line = {StreetObj => $r, 1420 N => $n, 1421 CoordIndex => 0, 1422 Dist => $new_mindist, 1423 Coords => \@p, 1424 }; 1425 if ($mindist == $new_mindist) { 1426 CORE::push(@line, $line); 1427 } else { 1428 @line = $line; 1429 } 1430 $mindist = $new_mindist; 1431 } 1432 } else { # line 1433 for(my $i=0; $i<$#p-1; $i+=2) { 1434 my $new_mindist = VectorUtil::distance_point_line($x,$y,@p[$i..$i+3]); 1435 if ($mindist >= $new_mindist) { 1436 my $line = {StreetObj => $r, 1437 N => $n, 1438 CoordIndex => $i/2, 1439 Dist => $new_mindist, 1440 Coords => [@p[$i..$i+3]], 1441 }; 1442 if ($mindist == $new_mindist) { 1443 CORE::push(@line, $line); 1444 } else { 1445 @line = $line; 1446 } 1447 $mindist = $new_mindist; 1448 } 1449 } 1450 } 1451 1452 } 1453 } 1454 } 1455 1456 if (@line) { 1457 for my $line (@line) { 1458 my($s0x,$s0y,$s1x,$s1y) = @{$line->{Coords}}; 1459 if (!defined $s1x) { # point 1460 $line->{Coord} = "$s0x,$s0y"; 1461 } else { 1462 my $dist0 = sqrt(sqr($s0x-$x)+sqr($s0y-$y)); 1463 my $dist1 = sqrt(sqr($s1x-$x)+sqr($s1y-$y)); 1464 if ($dist0 < $dist1) { 1465 $line->{Coord} = "$s0x,$s0y"; 1466 } else { 1467 $line->{Coord} = "$s1x,$s1y"; 1468 } 1469 } 1470 } 1471 if ($args{FullReturn}) { 1472 $args{AllReturn} ? \@line : $line[0]; 1473 } else { 1474 $args{AllReturn} ? [map { $_->{Coord} } @line] : $line[0]->{Coord}; 1475 } 1476 } else { 1477 undef; 1478 } 1479} 1480 1481# See also get_anti_conversion 1482sub get_conversion { 1483 my($self, %args) = @_; 1484 my $convsub; 1485 my $frommap = $self->{GlobalDirectives}{map} || $args{Map} || ['standard']; 1486 $frommap = $frommap->[0]; 1487 my $tomap = $args{-tomap} || "standard"; 1488 for ($frommap, $tomap) { $_ = 'standard' if $_ eq 'bbbike' } # normalize 1489 return if $frommap eq $tomap; # no conversion needed 1490 require Karte; 1491 Karte::preload(":all"); # Can't preload specific maps, because $map is a token, not a map module name 1492 if ($tomap ne "standard") { 1493 $convsub = sub { 1494 join ",", $Karte::map{$frommap}->map2map($Karte::map{$tomap}, 1495 split /,/, $_[0]); 1496 }; 1497 } else { 1498 $convsub = sub { 1499 join ",", $Karte::map{$frommap}->map2standard(split /,/, $_[0]); 1500 }; 1501 } 1502 $convsub; 1503} 1504 1505# set all $VERBOSE vars in this file 1506sub set_verbose { 1507 my $verbose = shift; 1508 $StrassenNetz::VERBOSE = $verbose; 1509 $Strassen::VERBOSE = $verbose; 1510 $Strassen::Util::VERBOSE = $verbose; 1511 $Kreuzungen::VERBOSE = $verbose; 1512 $StrassenNetz::CNetFile::VERBOSE = $verbose; 1513} 1514 1515sub get_global_directives { 1516 my $self = shift; 1517 if (ref $self && UNIVERSAL::isa($self, "Strassen")) { 1518 $self->{GlobalDirectives}; 1519 } else { 1520 my $file = shift; 1521 my $tmp_s = $self->new($file, NoRead => 1); 1522 $tmp_s->read_data(ReadOnlyGlobalDirectives => 1); 1523 $tmp_s->{GlobalDirectives}; 1524 } 1525} 1526 1527# If existing, get the *first* global directive with the given name, 1528# otherwise undef 1529sub get_global_directive { 1530 my($self, $directive) = @_; 1531 my $global_dir = $self->get_global_directives; 1532 if ($global_dir && exists $global_dir->{$directive}) { 1533 $global_dir->{$directive}[0]; 1534 } else { 1535 undef; 1536 } 1537} 1538 1539sub set_global_directive { 1540 my($self, $key, @val) = @_; 1541 $self->{GlobalDirectives}->{$key} = [@val]; 1542} 1543 1544# Note that this sets only the reference; if you want a copy, then 1545# use Storable::dclone before! 1546sub set_global_directives { 1547 my($self, $global_directives) = @_; 1548 $self->{GlobalDirectives} = $global_directives; 1549} 1550 1551sub switch_encoding { 1552 my($fh, $value) = @_; 1553 # The encoding directive is executed immediately 1554 eval q{ 1555 die "No UTF-8 support with this perl version ($])" if $] < 5.008; 1556 die "UTF-8 bugs with perl 5.8.0" if $] < 5.008001; 1557 binmode($fh, ":encoding($value)") 1558 }; 1559 if ($@) { 1560 if ($value ne 'iso-8859-1') { # this is perl's default, so do not warn 1561 warn "Cannot execute encoding <$value> directive: $@"; 1562 } 1563 } 1564} 1565 1566sub warn_or_die { 1567 my $msg = shift; 1568 require Carp; 1569 if ($STRICT) { 1570 Carp::croak($msg); 1571 } else { 1572 Carp::carp($msg); 1573 } 1574} 1575 1576sub DESTROY { } 1577 1578if (0) { # peacify -w 1579 $Kreuzungen::VERBOSE = $Kreuzungen::VERBOSE; 1580 $StrassenNetz::VERBOSE = $StrassenNetz::VERBOSE; 1581 $StrassenNetz::CNetFile::VERBOSE = $StrassenNetz::CNetFile::VERBOSE; 1582 $Strassen::Util::VERBOSE = $Strassen::Util::VERBOSE; 1583 *to_koord = *to_koord; 1584 *to_koord1 = *to_koord1; 1585 *to_koord_f = *to_koord_f; 1586 *to_koord_f1 = *to_koord_f1; 1587} 1588 15891; 1590 1591__END__ 1592 1593=head1 NAME 1594 1595Strassen::Core - the main Strassen class for bbd data 1596 1597=head1 SYNOPSIS 1598 1599 use Strassen::Core; 1600 1601 # Pull parser 1602 $s = Strassen->new($bbdfile); 1603 $s->init; 1604 while(1) { 1605 my $ret = $s->next; 1606 last if !@{ $ret->[Strassen::COORDS] }; 1607 print "Name: $ret->[Strassen::NAME]\n"; 1608 print "Category: $ret->[Strassen::CAT]\n"; 1609 print "Coordinates: " . join(" ", @{ $ret->[Strassen::COORDS] }) . "\n"; 1610 } 1611 1612 # Push parser 1613 $s = Strassen->new_stream($bbdfile); 1614 $s->read_stream( 1615 sub { 1616 my($rec, $directives, $linenumber) = @_; 1617 print "Name: $rec->[Strassen::NAME]\n"; 1618 print "Category: $rec->[Strassen::CAT]\n"; 1619 print "Coordinates: " . join(" ", @{ $rec->[Strassen::COORDS] }) . "\n"; 1620 } 1621 ); 1622 1623=head1 DESCRIPTION 1624 1625See L</SYNOPSIS>. 1626 1627Also see the comments in the source code. 1628 1629=head1 SEE ALSO 1630 1631L<BBBikeRouting>, L<bbd>. 1632