1# -*- perl -*- 2 3# 4# Author: Slaven Rezic 5# 6# Copyright (C) 1998-2010 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 BBBikeUtil; 15 16$VERSION = 1.33; 17 18use strict; 19use vars qw(@ISA @EXPORT @EXPORT_OK); 20 21require Exporter; 22@ISA = qw(Exporter); 23 24@EXPORT = qw(is_in_path catfile file_name_is_absolute 25 int_round sqr s2hm s2ms h2hm m2km 26 pi deg2rad rad2deg schnittwinkel float_prec 27 cp850_iso iso_cp850 nil 28 kmh2ms 29 STAT_MODTIME); 30@EXPORT_OK = qw(min max first sum ms2kmh clone bbbike_root 31 s2hms s2hm_or_s save_pwd); 32 33use constant STAT_MODTIME => 9; 34 35# REPO BEGIN 36# REPO NAME is_in_path /home/e/eserte/src/repository 37# REPO MD5 ccab6618d5af7a1e314eb8e0e448ff2c 38sub is_in_path { 39 my($prog) = @_; 40 if (file_name_is_absolute($prog)) { 41 if ($^O eq 'MSWin32') { 42 return $prog if (-f $prog && -x $prog); 43 return "$prog.bat" if (-f "$prog.bat" && -x "$prog.bat"); 44 return "$prog.com" if (-f "$prog.com" && -x "$prog.com"); 45 return "$prog.exe" if (-f "$prog.exe" && -x "$prog.exe"); 46 return "$prog.cmd" if (-f "$prog.cmd" && -x "$prog.cmd"); 47 } else { 48 return $prog if -f $prog and -x $prog; 49 } 50 } 51 require Config; 52 %Config::Config = %Config::Config if 0; # cease -w 53 my $sep = $Config::Config{'path_sep'} || ':'; 54 foreach (split(/$sep/o, $ENV{PATH})) { 55 if ($^O eq 'MSWin32') { 56 # maybe use $ENV{PATHEXT} like maybe_command in ExtUtils/MM_Win32.pm? 57 return "$_\\$prog" if (-f "$_\\$prog" && -x "$_\\$prog"); 58 return "$_\\$prog.bat" if (-f "$_\\$prog.bat" && -x "$_\\$prog.bat"); 59 return "$_\\$prog.com" if (-f "$_\\$prog.com" && -x "$_\\$prog.com"); 60 return "$_\\$prog.exe" if (-f "$_\\$prog.exe" && -x "$_\\$prog.exe"); 61 return "$_\\$prog.cmd" if (-f "$_\\$prog.cmd" && -x "$_\\$prog.cmd"); 62 } else { 63 return "$_/$prog" if (-x "$_/$prog" && !-d "$_/$prog"); 64 } 65 } 66 undef; 67} 68# REPO END 69 70sub catfile { 71 my(@args) = @_; 72 my $path; 73 eval { 74 require File::Spec; 75 $path = File::Spec->catfile(@args); 76 }; 77 if ($@) { 78 $path = join("/", @args); 79 } 80 $path; 81} 82 83# REPO BEGIN 84# REPO NAME file_name_is_absolute /home/e/eserte/src/repository 85# REPO MD5 47355e35bcf03edac9ea12c6f8fff9a3 86 87sub file_name_is_absolute { 88 my $file = shift; 89 my $r; 90 eval { 91 require File::Spec; 92 $r = File::Spec->file_name_is_absolute($file); 93 }; 94 if ($@) { 95 if ($^O eq 'MSWin32') { 96 $r = ($file =~ m;^([a-z]:(/|\\)|\\\\|//);i); 97 } else { 98 $r = ($file =~ m|^/|); 99 } 100 } 101 $r; 102} 103# REPO END 104 105sub int_round { int($_[0]+0.5) } 106 107# Quadrat 108sub sqr { 109 $_[0] * $_[0]; 110} 111 112# Sekunden in HH:MM-Schreibweise 113sub s2hm { 114 my $s = shift; 115 sprintf "%d:%02d", $s/3600, ($s%3600)/60; 116} 117 118# Sekunden in HH:MM:SS-Schreibweise 119sub s2hms { 120 my $s = shift; 121 sprintf "%d:%02d:%02d", $s/3600, ($s%3600)/60, $s%60; 122} 123 124# Sekunden in MM:SS-Schreibweise 125sub s2ms { 126 my $s = shift; 127 sprintf "%d:%02d", $s/60, int($s%60); 128} 129 130# seconds as "HH:MM h" or "SS sec" 131sub s2hm_or_s { 132 my $s = shift; 133 if ($s < 1 || $s >= 60) { 134 s2hm($s) . ' h'; 135 } else { 136 int($s%60) . ' sec'; 137 } 138} 139 140# gebrochene Stunden in HH:MM-Schreibweise 141sub h2hm { 142 my $s = shift; 143 sprintf "%d:%02d", $s, 60*($s - int($s)); 144} 145 146# Meter in Kilometer umwandeln. $dig gibt die Anzahl der 147# Nachkommastellen (Default: 1) an. Mit $sigdig (optional) kann die 148# Anzahl der signifikaten Nachkommastellen angegeben werden (um 149# Scheingenauigkeiten zu vermeiden): Beispiel m2km(1234,3,2) => 1.230. 150# Dabei wird nicht gerundet. $sigdig wird nicht verwendet, wenn 151# dadurch 0.000 als Ergebnis herauskommen w�rde. 152sub m2km { 153 my($s, $dig, $sigdig) = @_; 154 return 0 unless $s =~ /\d/; 155 $dig = 1 unless defined $dig; 156 my $r = sprintf "%." . $dig . "f", $s/1000; 157 if (defined $sigdig) { 158 if ($sigdig == 2 && $s < 10) { 159 # do nothing 160 } elsif ($sigdig == 1 && $s < 100) { 161 # do nothing 162 } else { 163 $r =~ s/\.(\d{$sigdig})(.*)/".$1" . ("0"x length($2))/e; 164 } 165 } 166 $r . " km"; 167} 168 169sub kmh2ms { $_[0]/3.6 } 170sub ms2kmh { $_[0]*3.6 } 171 172# damit ich nicht Math::Trig und Math::Complex laden mu� 173sub pi () { 4 * atan2(1, 1) } # 3.141592653 174sub deg2rad { ($_[0]*pi)/180 } 175sub rad2deg { ($_[0]*180)/pi } 176 177# Calculate intersecting angle 178# In: $p1(x|y) and $p2(x|y): exterior points 179# $pm(x|y): middle point (intersection point) 180# Out: (angle in radians, direction l or r) 181# may return (undef, undef) in case there's no angle available (e.g. 182# if $p1==$pm or $p2==$pm) 183# See also Strassen::Util::abbiegen for a very similar function. 184sub schnittwinkel { 185 my($p1x, $p1y, $pmx, $pmy, $p2x, $p2y) = @_; 186 return (pi,'l') if $p1x==$p2x && $p1y==$p2y; # avoid nan 187 my $acos; 188 # XXX do not duplicate code (Strassen::Util) 189 if (!eval { require POSIX }) { 190 # from Math::Complex 191 $acos = sub { 192 my $z = $_[0]; 193 return CORE::atan2(CORE::sqrt(1-$z*$z), $z) if (! ref $z) && CORE::abs($z) <= 1; 194 warn "Fallback to Math::Trig::acos because of $z\n"; 195 require Math::Trig; 196 Math::Trig::acos($z); 197 }; 198 } else { 199 $acos = \&POSIX::acos; 200 } 201 my $x1 = $pmx-$p1x; 202 my $y1 = $pmy-$p1y; 203 my $x2 = $p2x-$pmx; 204 my $y2 = $p2y-$pmy; 205 my $richtung = ($x1*$y2-$y1*$x2 > 0 ? 'l' : 'r'); 206 my $winkel = 0; 207 my $acos_arg = eval { 208 ($x1*$x2+$y1*$y2) / 209 (sqrt(sqr($x1)+sqr($y1)) * 210 sqrt(sqr($x2)+sqr($y2))); 211 }; 212 if ($@) { 213 return (undef, undef); 214 } 215 # protect from floating point inaccuracies 216 if ($acos_arg > 1) { $acos_arg = 1 } 217 elsif ($acos_arg < -1) { $acos_arg = -1 } 218 eval { 219 $winkel = &$acos($acos_arg); 220 }; 221 ($winkel, $richtung); 222} 223 224sub float_prec { 225 my($float, $prec) = @_; 226 no locale; 227 sprintf "%.${prec}f", $float; 228} 229 230# F�hrt ein co auf die angegebene Datei $file aus. 231# R�ckgabewert: 1: OK, 0: bei "co" ist ein Fehler aufgetreten 232# Exceptions: bei chdir 233sub rcs_co { 234 my $file = shift; 235 require File::Basename; 236 require Cwd; 237 my $cwd = Cwd::cwd(); 238 my($f, $dir) = File::Basename::fileparse($file); 239 chdir $dir or die "Kann kein chdir zum Verzeichnis $dir durchf�hren: $!"; 240 # Avoid interactive questions � la "writable ... exists; remove 241 # it" by using /dev/null 242 system("co -l $f < /dev/null"); 243 my $ok = 1; 244 if ($? != 0) { 245 $ok = 0; 246 } 247 chdir $cwd; 248 $ok; 249} 250 251# Zeichensatz-Konvertierungen 252 253sub cp850_iso { 254 my $s = shift; 255 $s =~ tr/\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377/\307\374\351\342\344\340\345\347\352\353\350\357\356\354\304\305\311\346\306\364\366\362\373\371\377\326\334\370\243\330\327F\341\355\363\372\361\321\252\272\277\256\254\275\274\241\253\273\.\:\?\|\+\301\302\300\251\+\|\+\+\242\245\+\+\+\+\+\-\+\343\303\+\+\+\+\+\=\+\244\360\320\312\313\310i\315\316\317\+\+FL\246\314T\323\337\324\322\365\325\265\336\376\332\333\331\375\335\-\264\255\261\=\276\266\247\367\270\260\250\'\271\263\262f\240/; 256 $s; 257} 258 259sub iso_cp850 { 260 my $s = shift; 261 $s =~ tr/\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377/\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \377\255\275\234\317\276\335\365\371\270\246\256\252\360\251\47\370\361\375\374\357\346\364\56\47\373\247\257\254\253\363\250\267\265\266\307\216\217\222\200\324\220\322\323\336\326\327\330\321\245\343\340\342\345\231\236\235\353\351\352\232\355\347\341\205\240\203\306\204\206\221\207\212\202\210\211\215\241\214\213\320\244\225\242\223\344\224\366\233\227\243\226\201\354\350\230/; 262 $s; 263} 264 265# keine Zeichensatz-Konvertierung 266sub nil { $_[0] } 267 268{ 269 my $BBBIKE_ROOT; 270 sub bbbike_root { 271 if (!defined $BBBIKE_ROOT) { 272 require File::Basename; 273 require Cwd; 274 $BBBIKE_ROOT = Cwd::realpath(File::Basename::dirname(__FILE__)); 275 } 276 $BBBIKE_ROOT; 277 } 278} 279 280BEGIN { 281 if (eval { require List::Util; 1 }) { 282 *min = \&List::Util::min; 283 *max = \&List::Util::max; 284 *first = \&List::Util::first; 285 *sum = \&List::Util::sum; 286 } else { 287 *min = sub { 288 my $min; 289 for (@_) { 290 $min = $_ if (!defined $min || $min > $_); 291 } 292 $min; 293 }; 294 *max = sub { 295 my $max; 296 for (@_) { 297 $max = $_ if (!defined $max || $max < $_); 298 } 299 $max; 300 }; 301 *first = sub (&@) { 302 my $code = shift; 303 for (@_) { 304 return $_ if &{$code}(); 305 } 306 undef; 307 }; 308 *sum = sub (@) { 309 my $sum = shift; 310 for (1..$#_) { $sum += $_[$_] } 311 $sum; 312 }; 313 } 314} 315 316use vars qw(%uml $uml_keys $uml_keys_rx 317 %uml_german_locale $uml_german_locale_keys $uml_german_locale_keys_rx 318 ); 319BEGIN { 320 %uml = ('�' => 'ae', '�' => 'oe', '�' => 'ue', '�' => 'ss', 321 '�' => 'Ae', '�' => 'Oe', '�' => 'Ue', 322 '�' => 'e', '�' => 'e', '�' => 'e', '�' => 'a', 323 ); 324 $uml_keys = join("",keys %uml); 325 $uml_keys_rx = qr{[$uml_keys]}; 326 327 %uml_german_locale = ('�' => 'a', '�' => 'o', '�' => 'u', '�' => 'ss', 328 '�' => 'A', '�' => 'O', '�' => 'U', 329 '�' => 'e', '�' => 'e', '�' => 'e', '�' => 'a', 330 ); 331 $uml_german_locale_keys = join("",keys %uml_german_locale); 332 $uml_german_locale_keys_rx = qr{[$uml_german_locale_keys]}; 333} 334 335# Convert umlauts so that sorting with german locale is correct, i.e. 336# � => a, � => ss, ... 337# Also used for shortening labels for GPS devices, where converting 338# a => ae is wasteful 339sub umlauts_for_german_locale { 340 my $s = shift; 341 $s =~ s/($uml_german_locale_keys_rx)/$uml_german_locale{$1}/go; 342 $s; 343} 344 345# Convert according to german rules e.g. � => ae 346sub umlauts_to_german { 347 my $s = shift; 348 $s =~ s/($uml_keys_rx)/$uml{$1}/go; 349 $s; 350} 351 352BEGIN { 353 if (eval { require Storable; $Storable::VERSION >= 2 }) { # need the ability to clone CODE items XXX determine correct Storable version 354 *clone = sub ($) { 355 my $o = shift; 356 local $Storable::Deparse = $Storable::Deparse = 1; 357 local $Storable::Eval = $Storable::Eval = 1; 358 Storable::dclone($o); 359 }; 360 } else { 361 *clone = sub ($) { 362 my $o = shift; 363 require Data::Dumper; 364 # Seems to segfault with Sieperl 5.6.1 when cloning in show_overview_populate 365 eval Data::Dumper::Dumper($o); 366 }; 367 } 368} 369 370# REPO BEGIN 371# REPO NAME save_pwd /home/e/eserte/work/srezic-repository 372# REPO MD5 0f7791cf8e3b62744d7d5cfbd9ddcb07 373sub save_pwd (&) { 374 my $code = shift; 375 require Cwd; 376 my $pwd = Cwd::cwd(); 377 eval { 378 $code->(); 379 }; 380 my $err = $@; 381 chdir $pwd or die "Can't chdir back to $pwd: $!"; 382 die $err if $err; 383} 384# REPO END 385 3861; 387 388