1#!/usr/bin/perl 2# 3# Display outbound summary for every link 4# for which there is anything in the outbound 5# Created by Pavel Gulchouck 2:463/68@fidonet 6# Fixed by Stas Degteff 2:5080/102@fidonet 7# Modified by Michael Dukelsky 2:5020/1042@fidonet 8# version 2.1 9# It is free software and license is the same as for Perl, 10# see http://dev.perl.org/licenses/ 11# 12 13##### There is nothing to change below this line ##### 14use File::Spec; 15use File::Find; 16use Config; 17use strict; 18use warnings; 19 20my ($fidoconfig, $OS, $module, $defZone, 21 $defOutbound, @dirs, @boxesDirs, @asoFiles, 22 %minmtime, %netmail, %echomail, %files); 23my $commentChar = '#'; 24my $Mb = 1024 * 1024; 25my $Gb = $Mb * 1024; 26 27sub usage 28{ 29 print <<USAGE; 30 31 The script showold.pl prints out to STDOUT how much netmail, echomail 32 and files are stored for every link in the outbound and fileboxes and 33 how long they are stored. 34 35 If FIDOCONFIG environment variable is defined, you may use the script 36 without arguments, otherwise you have to supply the path to fidoconfig 37 as an argument. 38 39 Usage: 40 perl showold.pl 41 perl showold.pl <path to fidoconfig> 42 43 Example: 44 perl showold.pl M:\\mail\\Husky\\config\\config 45USAGE 46 exit 1; 47} 48 49sub nodesort 50{ my ($az, $an, $af, $ap, $bz, $bn, $bf, $bp); 51 if ($a =~ /(\d+):(\d+)\/(\d+)(?:\.(\d+))?$/) 52 { 53 ($az, $an, $af, $ap) = ($1, $2, $3, $4); 54 } 55 if ($b =~ /(\d+):(\d+)\/(\d+)(?:\.(\d+))?$/) 56 { 57 ($bz, $bn, $bf, $bp) = ($1, $2, $3, $4); 58 } 59 return ($az<=>$bz) || ($an<=>$bn) || ($af<=>$bf) || ($ap<=>$bp); 60} 61 62sub unbso 63{ 64 my ($file, $dir) = @_; 65 my $zone; 66 if($dir =~ /\.([0-9a-f])([0-9a-f])([0-9a-f])$/i) 67 { 68 $zone = hex("$1")*256 + hex($2)*16 + hex($3); 69 } 70 else 71 { 72 $zone = $defZone; 73 } 74 if ($file =~ /([0-9a-f]{4})([0-9a-f]{4})\.pnt\/([0-9a-f]{8})/i) 75 { 76 return sprintf "%u:%u/%d.%d", $zone, hex("$1"), hex("$2"), hex("$3"); 77 } 78 elsif ($file =~ /([0-9a-f]{4})([0-9a-f]{4})/i) 79 { 80 return sprintf "%u:%u/%d", $zone, hex("$1"), hex("$2"); 81 } 82 else 83 { 84 return ""; 85 } 86} 87 88sub unaso 89{ 90 my ($file) = @_; 91 if($file =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) 92 { 93 if($4 == 0) 94 { 95 return "$1:$2\/$3"; 96 } 97 else 98 { 99 return "$1:$2\/$3\.$4"; 100 } 101 } 102 else 103 { 104 return ""; 105 } 106} 107 108sub unbox 109{ 110 my ($dir) = @_; 111 if($dir =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)(?:\.h)?$/i) 112 { 113 return $4 == 0 ? "$1:$2\/$3" : "$1:$2\/$3\.$4"; 114 } 115 else 116 { 117 return ""; 118 } 119} 120 121sub niceNumber 122{ 123 my ($num) = @_; 124 return ($num < $Mb ? $num : ($num >= $Mb && $num < $Gb ? $num/$Mb : $num/$Gb)); 125} 126 127sub niceNumberFormat 128{ 129 my ($num) = @_; 130 return "%9u " if ($num < $Mb); 131 132 my $len = length(sprintf "%4.4f", niceNumber($num)); 133 return ($len < 9 ? " " x (9 - $len) . "%4.4f" : "%4.4f") . 134 ($num < $Gb ? "M" : "G"); 135} 136 137sub normalize 138{ 139 my ($path) = @_; 140 return $path if($OS eq 'UNIX'); 141 my ($vol, $d, $f) = File::Spec->splitpath($path); 142 my @d = File::Spec->splitdir($d); 143 $d = File::Spec->catdir(@d); 144 return File::Spec->catpath($vol, $d, $f); 145} 146 147sub selectOutbound 148{ 149 if (-d $File::Find::name && $File::Find::name =~ /\.[0-9a-f]{3}$/i) 150 { 151 push(@dirs, normalize($File::Find::name)); 152 } 153} 154 155sub listOutbounds 156{ 157 my ($dir) = @_; 158 my ($volume, $directories, $file) = File::Spec->splitpath(normalize($dir)); 159 if($file eq "") 160 { 161 my @dirs = File::Spec->splitdir($directories); 162 $file = pop @dirs; 163 $directories = File::Spec->catdir(@dirs); 164 } 165 my $updir=File::Spec->catpath($volume, $directories, ""); 166 @dirs=($dir); 167 168 find(\&selectOutbound, $updir); 169 return @dirs; 170} 171 172sub selectFileInASO 173{ 174 if (-f $File::Find::name && -s $File::Find::name && 175 ($File::Find::name =~ /\d+\.\d+\.\d+\.\d+\.[icdoh]ut$/i || 176 $File::Find::name =~ /\d+\.\d+\.\d+\.\d+\.(su|mo|tu|we|th|fr|sa)[0-9a-z]$/i)) 177 { 178 push(@asoFiles, normalize($File::Find::name)); 179 } 180} 181 182sub listFilesInASO 183{ 184 @asoFiles = (); 185 find(\&selectFileInASO, $defOutbound); 186 return @asoFiles; 187} 188 189sub selectFileBoxes 190{ 191 if (-d $File::Find::name && $File::Find::name =~ /\d+\.\d+\.\d+\.\d+(?:\.h)?$/i) 192 { 193 push(@boxesDirs, normalize($File::Find::name)); 194 } 195} 196 197sub listFileBoxes 198{ 199 my ($dir) = @_; 200 find(\&selectFileBoxes, $dir); 201 return @boxesDirs; 202} 203 204sub allFilesInBSO 205{ 206 my ($dir) = @_; 207 chdir($dir); 208 my @files = <*.[IiCcDdFfHh][Ll][Oo]>; 209 push @files, <*.[IiCcDdOoHh][Uu][Tt]>; 210 push @files, <*.[Pp][Nn][Tt]/*.[IiCcDdFfHh][Ll][Oo]>; 211 push @files, <*.[Pp][Nn][Tt]/*.[IiCcDdOoHh][Uu][Tt]>; 212 return if(@files == 0); 213 214 foreach my $file (@files) 215 { 216 my $node=unbso($file, $dir); 217 next if($node eq ""); 218 my ($size, $mtime) = (stat($file))[7, 9]; 219 next if($size == 0); 220 if (!defined($minmtime{$node}) || $mtime < $minmtime{$node}) 221 { 222 $minmtime{$node} = $mtime if $mtime; 223 } 224 if ($file =~ /ut$/i) 225 { 226 $netmail{$node} += $size; 227 next; 228 } 229 # unix, read only -> ignore *.bsy 230 next unless open(F, "<$file"); 231 while (<F>) 232 { 233 s/\r?\n$//s; 234 s/^[#~^]//; 235 next unless(($size, $mtime) = (stat($_))[7, 9]); 236 next if($size == 0); 237 if (/[0-9a-f]{8}\.(su|mo|tu|we|th|fr|sa)[0-9a-z]$/i) 238 { 239 if (!defined($minmtime{$node}) || $mtime < $minmtime{$node}) 240 { 241 $minmtime{$node} = $mtime; 242 } 243 $echomail{$node} += $size; 244 } 245 elsif (/\.tic$/i) 246 { 247 if (!defined($minmtime{$node}) || $mtime < $minmtime{$node}) 248 { 249 $minmtime{$node} = $mtime; 250 } 251 $files{$node} += $size; 252 } 253 else 254 { 255 $files{$node} += $size; 256 } 257 } 258 close(F); 259 } 260} 261 262sub allFilesInASO 263{ 264 chdir($defOutbound); 265 my @files = listFilesInASO(); 266 return if(@files == 0); 267 268 foreach my $file (@files) 269 { 270 my $node=unaso($file); 271 next if($node eq ""); 272 my ($size, $mtime) = (stat($file))[7, 9]; 273 next if($size == 0); 274 if (!defined($minmtime{$node}) || $mtime < $minmtime{$node}) 275 { 276 $minmtime{$node} = $mtime if $mtime; 277 } 278 if ($file =~ /ut$/i) 279 { 280 $netmail{$node} += $size; 281 } 282 else 283 { 284 $echomail{$node} += $size; 285 } 286 } 287} 288 289sub allFilesInFileBoxes 290{ 291 my ($dir) = @_; 292 my $node = unbox($dir); 293 next if($node eq ""); 294 chdir($dir); 295 my @files = <*.[IiCcDdOoHh][Uu][Tt]>; 296 push @files, <*.[Ss][Uu][0-9a-zA-Z]>; 297 push @files, <*.[Mm][Oo][0-9a-zA-Z]>; 298 push @files, <*.[Tt][Uu][0-9a-zA-Z]>; 299 push @files, <*.[Ww][Ee][0-9a-zA-Z]>; 300 push @files, <*.[Tt][Hh][0-9a-zA-Z]>; 301 push @files, <*.[Ff][Rr][0-9a-zA-Z]>; 302 push @files, <*.[Ss][Aa][0-9a-zA-Z]>; 303 return if(@files == 0); 304 305 foreach my $file (@files) 306 { 307 my ($size, $mtime) = (stat($file))[7, 9]; 308 next if($size == 0); 309 if (!defined($minmtime{$node}) || $mtime < $minmtime{$node}) 310 { 311 $minmtime{$node} = $mtime if $mtime; 312 } 313 314 if ($file =~ /ut$/i) 315 { 316 $netmail{$node} += $size; 317 next; 318 } 319 elsif ($file =~ /\.(su|mo|tu|we|th|fr|sa)[0-9a-z]$/i) 320 { 321 # Both BSO and ASO style echomail bundles are handled here 322 if (!defined($minmtime{$node}) || $mtime < $minmtime{$node}) 323 { 324 $minmtime{$node} = $mtime; 325 } 326 $echomail{$node} += $size; 327 } 328 else 329 { 330 $files{$node} += $size; 331 } 332 } 333} 334 335 336# stripSpaces(@array) returns the array, every element of which 337# is stripped of heading and trailing white spaces. 338sub stripSpaces 339{ 340 my @arr = @_; 341 foreach (@arr) 342 { 343 next unless $_; 344 s/^\s+//; 345 s/\s+$//; 346 } 347 return @arr; 348} 349 350# stripQuotes(@array) returns the array, every element of which 351# is stripped of heading and trailing double quote character. 352sub stripQuotes 353{ 354 my @arr = @_; 355 foreach (@arr) 356 { 357 next unless $_; 358 s/^\"(.+)\"$/$1/; 359 } 360 return @arr; 361} 362 363# expandVars($expression) executes commands in backticks 364# found in the $expression, substitutes environment 365# variables by their values and returns the resulting string 366sub expandVars 367{ 368 my ($expr) = stripSpaces(@_); 369 my ($result, $left, $cmd, $var, $remainder); 370 371 # check whether number of backticks (\x60) is even 372 my $number = $expr =~ tr/\x60//; 373 if (($OS eq 'UNIX' or $OS eq 'OS/2') && 374 $number != 0 && 375 int($number / 2) * 2 == $number) 376 { 377 # execute commands in backticks 378 $cmd = 1; 379 $result = ""; 380 while ($cmd) 381 { 382 ($left, $cmd, $remainder) = split /\x60/, $expr, 3; 383 $left = "" if(!defined($left)); 384 $cmd = "" if(!defined($cmd)); 385 $remainder = "" if(!defined($remainder)); 386 if ($cmd) 387 { 388 $result .= $left . eval('`' . $cmd . '`'); 389 $result =~ s/[\r\n]+$//; 390 last unless $remainder; 391 $expr = $remainder; 392 } 393 else 394 { 395 $result .= $expr; 396 } 397 } 398 $expr = $result; 399 } 400 401 # substitute environment variables by their values 402 $var = 1; 403 $result = ""; 404 while ($var) 405 { 406 ($left, $var, $remainder) = split /[\[\]]/, $expr, 3; 407 $left = "" if(!defined($left)); 408 $var = "" if(!defined($var)); 409 $remainder = "" if(!defined($remainder)); 410 if ($var) 411 { 412 $result .= 413 $left 414 . ( 415 lc($var) eq "module" 416 ? "module" 417 : ($ENV{$var} ? $ENV{$var} : "")); 418 last unless $remainder; 419 $expr = $remainder; 420 } 421 else 422 { 423 $result .= $expr; 424 } 425 } 426 return $result; 427} 428 429# cmpPattern($string, $pattern) compares $string with $pattern 430# and returns boolean result of the comparison. The pattern 431# may contain wildcard caracters '?' and '*'. 432sub cmpPattern 433{ 434 my ($string, $pattern) = @_; 435 $pattern =~ s/\?/./g; 436 $pattern =~ s/\*/.*/g; 437 return $string =~ /^$pattern$/; 438} 439 440sub boolExpr 441{ 442 my ($expr, $ifLevel, $moduleIfLevel) = @_; 443 my ($result, $not, $left, $right); 444 $result = $not = ""; 445 446 if ($expr =~ /^not\s+(.+)$/i) 447 { 448 $not = 1; 449 $expr = $1; 450 } 451 452 if ($expr =~ /^(.+)==(.+)$/) 453 { 454 ($left, $right) = stripSpaces($1, $2); 455 if (lc($left) eq "module") 456 { 457 if ($result = lc($right) eq "hpt") 458 { 459 $module = "hpt"; 460 $moduleIfLevel = $ifLevel; 461 } 462 elsif ($result = lc($right) eq "htick") 463 { 464 $module = "htick"; 465 $moduleIfLevel = $ifLevel; 466 } 467 } 468 elsif (lc($right) eq "module") 469 { 470 if ($result = lc($left) eq "hpt") 471 { 472 $module = "hpt"; 473 $moduleIfLevel = $ifLevel; 474 } 475 elsif ($result = lc($left) eq "htick") 476 { 477 $module = "htick"; 478 $moduleIfLevel = $ifLevel; 479 } 480 } 481 else 482 { 483 $result = $left eq $right; 484 } 485 } 486 elsif ($expr =~ /^(.+)!=(.+)$/) 487 { 488 ($left, $right) = stripSpaces($1, $2); 489 $result = $left ne $right; 490 } 491 elsif ($expr =~ /^(.+)=~(.+)$/) 492 { 493 $result = cmpPattern(stripSpaces($1, $2)); 494 } 495 elsif ($expr =~ /^(.+)!~(.+)$/) 496 { 497 $result = not cmpPattern(stripSpaces($1, $2)); 498 } 499 500 return $not ? not $result : $result; 501} 502 503# stripComment(@lines) strips a comment from @lines and returns the array 504sub stripComment 505{ 506 my @arr = @_; 507 foreach (@arr) 508 { 509 next unless $_; 510 next if s/^$commentChar.*$//; 511 s/\s+$commentChar\s.*$//; 512 } 513 return @arr; 514} 515 516# parseIf($line, \@condition) parses $line for conditional operators 517# and returns 1 if the line should be skipped else 0. 518sub parseIf 519{ 520 my ($line, $rCondition, $ifLevel, $moduleIfLevel) = @_; 521 522 return 1 if $line eq ""; 523 524 if ($line =~ /^if\s+(.+)$/i) 525 { 526 $ifLevel++; 527 return 1 if @$rCondition and not $$rCondition[-1]; 528 push @$rCondition, boolExpr(expandVars($1), $ifLevel, $moduleIfLevel); 529 return 1; 530 } 531 elsif ($line =~ /^ifdef\s+(.+)$/i) 532 { 533 $ifLevel++; 534 return 1 if @$rCondition and not $$rCondition[-1]; 535 my $var = expandVars($1); 536 push @$rCondition, ($var ? exists $ENV{$var} : 0); 537 return 1; 538 } 539 elsif ($line =~ /^ifndef\s+(.+)$/i) 540 { 541 $ifLevel++; 542 return 1 if @$rCondition and not $$rCondition[-1]; 543 my $var = expandVars($1); 544 push @$rCondition, ($var ? not exists $ENV{$var} : 1); 545 return 1; 546 } 547 elsif ($line =~ /^elseif\s+(.+)$/i or $line =~ /^elif\s+(.+)$/i) 548 { 549 return 1 if @$rCondition != $ifLevel; 550 $moduleIfLevel = 0 if $moduleIfLevel and $moduleIfLevel == $ifLevel; 551 pop @$rCondition; 552 push @$rCondition, boolExpr(expandVars($1), $ifLevel, $moduleIfLevel); 553 return 1; 554 } 555 elsif ($line =~ /^else$/i) 556 { 557 return 1 if @$rCondition != $ifLevel; 558 $moduleIfLevel = 0 if $moduleIfLevel and $moduleIfLevel == $ifLevel; 559 push @$rCondition, not pop(@$rCondition); 560 return 1; 561 } 562 elsif ($line =~ /^endif$/i) 563 { 564 $moduleIfLevel = 0 if $moduleIfLevel and $moduleIfLevel == $ifLevel; 565 pop @$rCondition if @$rCondition == $ifLevel--; 566 return 1; 567 } 568 569 return 1 if $ifLevel and not $$rCondition[-1]; 570 return 0; 571} 572 573# findTokenValue($token, $tokenFile) returns ($value, $tokenFile), 574# where $value is the value of the $token in husky fidoconfig. 575# Search of the token is started in the file with the full path 576# $tokenFile in the argument and in all included files and the returned 577# $tokenFile is the file where the token was found. 578# If the token was not found, $value is an empty string, 579# if the token was found but with empty value, then 580# a string "on" is returned as $value. 581sub findTokenValue 582{ 583 my ($token, $tokenFile) = @_; 584 my ($value, @lines, @condition, $ifLevel, $moduleIfLevel); 585 $value = ""; 586 $ifLevel = $moduleIfLevel = 0; 587 588 ($tokenFile) = stripQuotes(stripSpaces($tokenFile)); 589 590 open(FIN, "<", $tokenFile) or die("$tokenFile: $!"); 591 @lines = <FIN>; 592 close FIN; 593 594 foreach my $line (stripSpaces(stripComment(@lines))) 595 { 596 next if parseIf($line, \@condition, $ifLevel, $moduleIfLevel); 597 598 $line = expandVars($line); 599 600 if ($line =~ /^$token\s+(.+)$/i) 601 { 602 ($value) = stripSpaces($1); 603 last; 604 } 605 elsif ($line =~ /^$token$/i) 606 { 607 $value = "on"; 608 last; 609 } 610 elsif ($line =~ /^include\s+(.+)$/i) 611 { 612 my $newTokenFile; 613 ($value, $newTokenFile) = findTokenValue($token, $1); 614 if ($value and $newTokenFile) 615 { 616 $tokenFile = $newTokenFile; 617 last; 618 } 619 } 620 elsif ($line =~ /^set\s+(.+)$/i) 621 { 622 my ($var, $val) = stripSpaces(split(/=/, $1)); 623 ($val) = stripQuotes($val); 624 $val ? ($ENV{$var} = $val) : delete $ENV{$var}; 625 } 626 elsif ($line =~ /^commentChar\s+(\S)$/i) 627 { 628 $commentChar = $1; 629 } 630 } ## end foreach my $line (@lines) 631 return ($value, $tokenFile); 632} ## end sub findTokenValue 633 634# searchTokenValue($token, $tokenFile) 635sub searchTokenValue 636{ 637 my ($token, $tokenFile) = @_; 638 $commentChar = '#'; 639 return findTokenValue($token, $tokenFile); 640} 641 642# isOn($value) returns true if the $value is the string representing "true" 643# according to husky fidoconfig rules 644sub isOn 645{ 646 my ($val) = @_; 647 return 1 if($val eq "1" or lc($val) eq "yes" or lc($val) eq "on"); 648 return 0; 649} 650 651 652###################### The main program starts here ########################## 653 654$fidoconfig = $ENV{FIDOCONFIG} if defined $ENV{FIDOCONFIG}; 655 656if ((@ARGV == 1 && $ARGV[0] =~ /^(-|--|\/)(h|help|\?)$/i) || (!defined($fidoconfig) && @ARGV != 1)) 657{ 658 usage(); 659} 660 661$fidoconfig = $ARGV[0] if(!defined($fidoconfig)); 662if (!(-f $fidoconfig && -s $fidoconfig)) 663{ 664 print "\n\'$fidoconfig\' is not fidoconfig\n"; 665 usage(); 666} 667 668unless ($OS = $^O) 669{ 670 $OS = $Config::Config{'osname'}; 671} 672 673if ($OS =~ /^MSWin/i) 674{ 675 $OS = 'WIN'; 676} 677elsif ($OS =~ /^dos/i) 678{ 679 $OS = 'DOS'; 680} 681elsif ($OS =~ /^os2/i) 682{ 683 $OS = 'OS/2'; 684} 685elsif ($OS =~ /^VMS/i or $OS =~ /^MacOS/i or $OS =~ /^epoc/i or $OS =~ /NetWare/i) 686{ 687 die("$OS is not supported\n"); 688} 689else 690{ 691 $OS = 'UNIX'; 692} 693$ENV{OS} = $OS; 694$ENV{$OS} = $OS; 695 696#### Read fidoconfig #### 697my ($address, $path, $fileBoxesDir); 698$fidoconfig = normalize($fidoconfig); 699 700my $separateBundles; 701($separateBundles, $path) = searchTokenValue("SeparateBundles", $fidoconfig); 702die "\nSeparateBundles mode is not supported\n" if(isOn($separateBundles)); 703 704($address, $path) = searchTokenValue("address", $fidoconfig); 705$defZone = $1 if($address ne "" && $address =~ /^(\d+):\d+\/\d+(?:\.\d+)?(?:@\w+)?$/); 706defined($defZone) or die "\nYour FTN address is not defined or has a syntax error\n"; 707 708($fileBoxesDir, $path) = searchTokenValue("FileBoxesDir", $fidoconfig); 709if($fileBoxesDir ne "") 710{ 711 -d $fileBoxesDir or die "\nfileBoxesDir \'$fileBoxesDir\' is not a directory\n"; 712 $fileBoxesDir = normalize($fileBoxesDir); 713} 714 715($defOutbound, $path) = searchTokenValue("Outbound", $fidoconfig); 716$defOutbound ne "" or die "\nOutbound is not defined\n"; 717-d $defOutbound or die "\nOutbound \'$defOutbound\' is not a directory\n"; 718$defOutbound = normalize($defOutbound); 719 720@dirs = listOutbounds($defOutbound); 721@boxesDirs = listFileBoxes($fileBoxesDir) if($fileBoxesDir ne ""); 722 723allFilesInASO(); 724 725foreach my $dir (@dirs) 726{ 727 allFilesInBSO($dir); 728} 729 730foreach my $dir (@boxesDirs) 731{ 732 allFilesInFileBoxes($dir); 733} 734 735print <<EOF; 736+------------------+--------+-----------+-----------+-----------+ 737| Node | Days | NetMail | EchoMail | Files | 738+------------------+--------+-----------+-----------+-----------+ 739EOF 740foreach my $node (sort nodesort keys %minmtime) 741{ 742 $netmail{$node} = 0 if(!defined $netmail{$node}); 743 $echomail{$node} = 0 if(!defined $echomail{$node}); 744 $files{$node} = 0 if(!defined $files{$node}); 745 my $format = "| %-16s |%7u |" . 746 niceNumberFormat($netmail{$node}) . " |" . 747 niceNumberFormat($echomail{$node}) . " |" . 748 niceNumberFormat($files{$node}) . " |\n"; 749 printf $format, 750 $node, (time()-$minmtime{$node})/(24*60*60), 751 niceNumber($netmail{$node}), 752 niceNumber($echomail{$node}), 753 niceNumber($files{$node}); 754} 755print "+------------------+--------+-----------+-----------+-----------+\n"; 756exit(0); 757