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