1#!/usr/bin/perl 2# hptstat (c)opyright 2002-03, by val khokhlov 3$VERSION = "0.92"; 4%areas; # areas found in stat (tag=>id), id=1,2,3,... 5@area_tag; # ...reverse array (id=>tag) 6%links; # links found in stat 7@stat; # array ($tag, @addr, @msgs, @bytes) 8 # idx: 0 1 2 3 4 5 6 7 8 9 10 9 # val: id z:n/f.p in out dupe bad inb outb 10$INB = $OUTB = 0; # total input and output bytes 11%config_areas, @config_links; # parsed hpt config 12 13# ==================================================================== 14# MODIFY THE SECTION BELOW TO CUSTOMIZE REPORT 15# -->--- 16 17# init([<default binary stat log>[, <default config file>]]) 18init(); #init("/home/val/fido/log/hpt.sta", "/home/val/fido/hpt/hpt.conf"); 19 20# file(<name>|"-") to save part of report to file <name>, stdout if "-" 21#file("areas.rep"); 22 23# pkt(<hash>) to save part of report to .pkt, <hash> keys: subj,from,to,area 24#pkt({'from'=>'advhptstat', 'subj'=>'Areas summary'}); 25 26# header 27print center("hpt statistics"), 28 center(localtime($stat1)." - ".localtime($stat2)), "\n"; 29# top 10 areas graph 30print center("Top 10 areas"), 31 join("\n", make_histgr('Area', 1, [9,10], [9,10], 10, 2)), "\n\n"; 32# links graph 33print center("Traffic by links"), 34 join("\n", make_histgr('Link', 0, [9,10], [9,10])), "\n\n"; 35# areas summary 36print center("Areas summary"), "\n", 37 join("\n", make_summary('Area', 0, 1)), "\n\n"; 38# links summary 39print center("Links summary"), "\n", 40 join("\n", make_summary('Link', 0, 1)), "\n\n"; 41# zero traffic areas 42print center("Zero traffic areas"), "\n", 43 join("\n", make_notraf()), "\n\n"; 44# bad and dupe combined report 45print center("Bad and duplicate messages"), "\n", 46 join("\n", make_baddupe(['Dupe', ' Bad'], 2, [7,8], [7,8])), "\n\n"; 47# --<--- 48# END OF CUSTOMIZATION SECTION 49# ==================================================================== 50done(); 51 52# -------------------------------------------------------------------- 53# center a line 54sub center { return sprintf '%'.(39-length($_[0])/2)."s%s\n", ' ', $_[0]; } 55# -------------------------------------------------------------------- 56# cmp fido addresses 57sub acmp { 58 my @a = split m![:/.@]!o, $_[0]; 59 my @b = split m![:/.@]!o, $_[1]; 60 return $a[0] <=> $b[0] || $a[1] <=> $b[1] || $a[2] <=> $b[2] || $a[3] <=> $b[3]; 61} 62# -------------------------------------------------------------------- 63# parse stat file into @stat 64sub parse_stat { 65 my $gz; 66 my ($name, $warn) = @_; 67 print STDERR " * processing ".($GZ ? "gzip'ed " : "")."stat file: $name\n" if $DBG; 68eval { 69 open F, $name or die "Can't open stat file $name\n"; binmode F; 70 if (!$GZ && $name !~ /\.[Gg][Zz]$/o) { read F, $_, 16; } 71 else { 72 die "Compress::Zlib perl module required for gzip'ed files processing\n" unless eval { require Compress::Zlib; import Compress::Zlib; 1; }; 73 $gz = gzopen(\*F, "r") or die "gzopen() error: $gzerrno\n"; 74 $gz->gzread($_, 16); 75 } 76 my ($rev, $t0) = unpack 'x2 S1 L1', $_; 77 # check revision 78 if ($rev != 1) { 79 $gz->gzclose if $gz; 80 close F; 81 die "Stat file $name revision $rev, expected 1\n"; 82 } 83 # set times 84 $stat1 = $t0 if !defined $stat1 || $stat1 > $t0; 85 $stat2 = (stat F)[9] if $stat2 < (stat F)[9]; 86 # read file 87 while ( $gz ? $gz->gzread($_, 4) > 0 : !eof F ) { 88 read F, $_, 4 unless $gz; 89 my ($lc, $tl, $tag, $id) = unpack 'S2', $_; 90 # area tag 91 !$gz ? read F, $tag, $tl : $gz->gzread($tag, $tl); 92 $id = $areas{$tag}; 93 if (!defined $id) { $areas{$tag} = $id = keys(%areas)+1; $area_tag[$id] = $tag; } 94 # links data 95 for (my $i = 0; $i < $lc; $i++) { 96 !$gz ? read F, $_, 32 : $gz->gzread($_, 32); 97 push @stat, [$id, unpack('S4 L6', $_)]; 98 my ($z,$n,$f,$p) = unpack 'S4', $_; 99 $links{$p ? "$z:$n/$f.$p" : "$z:$n/$f"} = 1; 100 $INB += $stat[-1][9]; $OUTB += $stat[-1][10]; 101 } 102 } 103 $gz->gzclose if $gz; 104 close F; 105}; 106 if ($@) { 107 if ($warn) { print STDERR " * error processing, skipped\n" if $DBG; } 108 else { die $@; } 109 } 110 else { 111 if (defined $move) { 112 my $to = POSIX::strftime($move, (localtime)[0..5]); 113 print STDERR " * moving successfully processed file $name to $to" if $DBG; 114 File::Path::mkpath( File::Basename::dirname($to) ); 115 File::Copy::move($name, $to); 116 } 117 elsif ($del) { 118 print STDERR " * deleting successfully processed file $name" if $DBG; 119 unlink $name; 120 } 121 } 122} 123# -------------------------------------------------------------------- 124# parse hpt config 125sub parse_config { 126 my %tokens = ('advstatisticsfile'=>1, 'address'=>2, 'sysop'=>1, 'reportto'=>1, 127 'localinbound'=>1, 'origin'=>1, 'tearline'=>1); 128 my $in_link; 129 local *F; 130 my ($name) = @_; 131 print STDERR " * processing config file: $name\n" if $DBG; 132 open F, $name or die "Can't open husky config file $name\n"; 133 while (<F>) { 134 chomp $_; study $_; 135 # strip comments and empty lines 136 next if /^#/; 137 s/\s+#\s+.*$//; 138 next if /^\s*$/; 139 my ($cmd) = /^\s*(\S+)/; my $lcmd = lc $cmd; 140 # parse stat file 141 if ($tokens{$lcmd} && ($tokens{$lcmd} < 2 || !defined $config{$lcmd})) { 142 my @s = /^\s*\S+\s+(?:"(.*?)(?<!\\)"|(.+?)\s*$)/; 143 my $s = $s[0].$s[1]; 144 $s =~ s/\[([^\]]+)\]/$SET{$1} or $ENV{$1}/eg; 145 print STDERR " * found $cmd: $s\n" if $DBG; 146 $config{$lcmd} = $s; 147 } 148 # parse area 149 elsif ($lcmd eq 'echoarea') { 150 my @s = /^\s*\S+\s+(?:"(.*?)(?<!\\)"|(\S+))/; 151 my $tag = $s[0].$s[1]; 152 $config_areas{$tag} = {uplink=>undef, links=>[]}; 153 s/-[Aa]\s+\S+//; 154 s/-[Dd]\s+\"[^\"]+\"//; 155 my @arr = m!([*\d]+:[*\d]+/[*\d]+(?:\.[*\d]+)?)((?:\s+-\S+)*)!g; 156 for (my $i = 0; $i < @arr; $i += 2) { 157 $arr[$i] =~ s/\.0+$//; 158 if ($arr[$i+1] =~ /-def/i) { $config_areas{$tag}{'uplink'} = $arr[$i]; } 159 else { push @{$config_areas{$tag}{'links'}}, $arr[$i]; } 160 } 161 } 162 # parse link 163 elsif ($lcmd eq 'link') { $in_link = 1; } 164 elsif ($in_link && $lcmd eq 'aka') { 165 my ($aka) = /^\s*\S+\s+(\S+)/; 166 $aka =~ s/\.0+$//; 167 push @config_links, $aka; 168 } 169 # parse set 170 elsif ($lcmd eq 'set') { 171 my ($s1, $s2) = /^\s*\S+\s+(\S+)[^=]*=\s*"?(.*?)"?\s*$/o; 172 $s2 =~ s/\[([^\]]+)\]/$SET{$1} or $ENV{$1}/eg; 173 print STDERR " * found set: $s1=$s2\n" if $DBG; 174 $SET{$s1} = $s2; 175 } 176 # parse include 177 elsif ($lcmd eq 'include') { 178 my @s = /^\s*\S+\s+(?:"(.*?)(?<!\\)"|(\S+))/o; 179 my $s = $s[0].$s[1]; 180 $s =~ s/\[([^\]]+)\]/$SET{$1} or $ENV{$1}/eg; 181 parse_config($s) if -r $s; 182 } 183 } 184 close F; 185 $stat_file = $config{'advstatisticsfile'}; 186} 187# -------------------------------------------------------------------- 188# traffic to string: traf2str($traf); format: ###x or #.#x, x=[kMG] 189sub traf2str { 190 my $s = ''; my @symb = ('', 'k', 'M', 'G'); 191 for my $cc (@_) { 192 my $x = 0; my $c = $cc; 193 if ($c < 0.1) { $s .= ' -- '; next; } 194 while ($c >= 1000) { $c /= 1024; $x++; } 195 if ($c < 10) { $s .= sprintf "%3.1f%s", $c < 9.95 ? $c : 9.9, $symb[$x]; } 196 else { $s .= sprintf "%3d%s", $c, $symb[$x]; } 197 } 198 return $s; 199} 200# -------------------------------------------------------------------- 201# percents to string: perc2str($actual, $base); format: ##.#% 202sub perc2str { 203 my ($actual, $base) = (@_, 1); 204 if ($base == 0) { return ' -- '; } 205 elsif ($actual > 0.9995*$base) { return ' 100%'; } 206 else { return sprintf "%4.1f%%", 100*$actual/$base; } 207} 208# -------------------------------------------------------------------- 209# 210sub out_histgr { 211# my @symb = (' ', '�', '�', '�'); 212 my @symb = ('�', '�', '�', '�'); 213 my (@sum, @out); 214 my $len = 50; 215 216 my ($arr, $type, $max, $maxlen, $totals) = @_; 217 for my $v (@$arr) { 218 for (my $i = 2; $i < @$v; $i++) { $sum[$i] += $v->[$i]; } 219 } 220 my $title = @$arr.' '.lc($type).'(s)'; 221 if ($maxlen < length($title)) { $maxlen = length($title); } 222 my $cnt = @{$arr->[0]} - 2; 223 my $clen = $maxlen + 3 + $cnt*11; 224 $len = 78-$clen if $len > 78-$clen; 225 push @out, 226 sprintf("%-${maxlen}s %-${len}s %-10s %-10s\n", $type, '', ' Incoming', ' Outgoing'). 227 ('�'x$maxlen).' �'.('�'x$len).'� '.('�'x10).' '.('�'x10); 228 for my $v (@$arr) { 229 my $s = sprintf "%-${maxlen}s �", $v->[0]; 230 for (my $l = 0; $l < $len; $l++) { 231 my $ch = 0; 232 $ch |= 1 if ($max && $len*$v->[2]/$max > $l); 233 $ch |= 2 if ($max && $len*$v->[3]/$max > $l); 234 $s .= $symb[$ch]; 235 } 236 $s .= "�"; 237 for (my $i = 2; $i < 2+$cnt; $i++) { 238 $s .= sprintf " %4s %s", traf2str($v->[$i]), perc2str($v->[$i], $sum[$i]); 239 } 240 push @out, $s; 241 } 242 push @out, ('�'x$maxlen).' �'.('�'x$len).'� '.('�'x10).' '.('�'x10); 243 my ($s2, $s3) = ($totals < 2) ? @sum[2,3] : ($INB, $OUTB); 244 push @out, sprintf "%${maxlen}s %${len}s %4s %s %4s %s", 245 $title, '', traf2str($sum[2]), perc2str($sum[2], $s2), 246 traf2str($sum[3]), perc2str($sum[3], $s3) if $totals; 247 return @out; 248} 249# -------------------------------------------------------------------- 250# make_histgr($type, $sort_field, $tosum, $toout[, $count[, $totals]]) 251# type - Area or Link 252# sort_field - 0 to sort by area/link, 253# 1 to sort by sum of $tosum fields, 254# 2... to sort by corresponding $toout field 255# tosum - pointer to array of fields to make sum of 256# toout - pointer to array of fields to include into output 257# count - make histogram of top $count items 258# totals - totals line percents mode: 0 - no totals, 1 - 100%, 259# 2 - ratio of listed items/total traffic 260sub make_histgr { 261 my (@arr, $cur, $prev); 262 my ($max, $maxlen) = (0, 0); 263 264 my ($type, $sf, $tosum, $toout, $cnt, $totals) = @_; 265 for my $v (@stat) { 266 # index by rec 267 if ($type eq 'Area') { $cur = $area_tag[$v->[0]]; } 268 elsif ($type eq 'Link') { 269 $cur = $v->[1].':'.$v->[2].'/'.$v->[3]; 270 $cur .= '.'.$v->[4] unless $v->[4] == 0; 271 } 272 # find rec by index 273 my $c; 274 for ($c = 0; $c <= @arr; $c++) { 275 push @arr, [$cur] if $c == @arr; 276 last if $arr[$c][0] eq $cur; 277 } 278 next unless defined $c; 279 # update rec 280 for my $i (@$tosum) { $arr[$c][1] += $v->[$i]; } 281 for (my $i = 0; $i < @$toout; $i++) { 282 $arr[$c][$i+2] += $v->[$toout->[$i]]; 283 $max = $arr[$c][$i+2] if $arr[$c][$i+2] > $max; 284 } 285 $maxlen = length $arr[$c][0] if $maxlen < length $arr[$c][0]; 286 } 287 # nothing to do 288 return () if (@arr <= 0); 289 # sort 290 if ($sf > 0) { @arr = sort { $b->[$sf] <=> $a->[$sf] } @arr; } 291 elsif ($type eq 'Area') { @arr = sort { $a->[0] cmp $b->[0] } @arr; } 292 else { @arr = sort { acmp($a->[0], $b->[0]) } @arr; } 293 # make top array 294 splice @arr, $cnt, $#arr if $cnt > 0; 295 $totals = !($cnt > 0) unless defined $totals; 296 return out_histgr(\@arr, $type, $max, $maxlen, $totals); 297} 298# -------------------------------------------------------------------- 299# 300sub make_summary { 301 my (@arr, @tot, @out, $cur, $len); 302 303 my ($type, $sf, $empty) = @_; 304 # process stat 305 for my $v (@stat) { 306 # index by rec 307 if ($type eq 'Area') { $cur = $area_tag[$v->[0]]; } 308 elsif ($type eq 'Link') { 309 $cur = $v->[1].':'.$v->[2].'/'.$v->[3]; 310 $cur .= '.'.$v->[4] unless $v->[4] == 0; 311 } 312 # find rec by index 313 my $c; 314 for ($c = 0; $c <= @arr; $c++) { 315 push @arr, [$cur] if $c == @arr; 316 last if $arr[$c][0] eq $cur; 317 } 318 next unless defined $c; 319 # update record 320 for (my $i = 5; $i <= 11; $i++) { 321 $arr[$c][$i-4] += $v->[$i]; 322 $tot[$i-4] += $v->[$i]; 323 } 324 $maxlen = length $arr[$c][0] if $maxlen < length $arr[$c][0]; 325 } 326 # parse hpt config to find empty areas 327 if ($empty) { 328 ##parse_config() unless defined %config_areas || defined @config_links; 329 if ($type eq 'Area') { 330 for my $v (keys %config_areas) { push @arr, [$v] if !$areas{$v}; } 331 } elsif ($type eq 'Link') { 332 for my $v (@config_links) { push @arr, [$v] if !$links{$v}; } 333 } 334 } 335 # sort 336 if ($sf > 0) { @arr = sort { $b->[$sf] <=> $a->[$sf] } @arr; } 337 elsif ($type eq 'Area') { @arr = sort { $a->[0] cmp $b->[0] } @arr; } 338 else { @arr = sort { acmp($a->[0], $b->[0]) } @arr; } 339 # make out 340 $len = 78 - (1+11+1+11+1+4+1+4+1+10+1+10); 341 push @out, sprintf("%-${len}s", $type).' In msgs Out msgs Bad Dupe In bytes Out bytes'; 342 push @out, ('�'x$len).' '.('�'x11).' '.('�'x11).' '.('�'x4).' '.('�'x4).' '.('�'x10).' '.('�'x10); 343 for my $v (@arr) { 344 my $s = $v->[0]; 345 if (length $s > $len) { substr $s, $len-3, length($s)-$len+3, '...'; } 346 push @out, sprintf("%-${len}s %5s %s %5s %s %4s %4s %4s %s %4s %s", 347 $s, 348 ($v->[1] || '-'), perc2str($v->[1], $tot[1]), 349 ($v->[2] || '-'), perc2str($v->[2], $tot[2]), 350 ($v->[4] || '-'), ($v->[3] || '-'), 351 traf2str($v->[5]), perc2str($v->[5], $tot[5]), 352 traf2str($v->[6]), perc2str($v->[6], $tot[6])); 353 } 354 push @out, sprintf "%${len}s", "No data available" unless @arr > 0; # nothing to out 355 push @out, ('�'x$len).' '.('�'x11).' '.('�'x11).' '.('�'x4).' '.('�'x4).' '.('�'x10).' '.('�'x10); 356 push @out, sprintf("%${len}s %5s %s %5s %s %4s %4s %4s %s %4s %s", 357 "Total ".@arr." ".lc($type)."(s)", 358 ($tot[1] || '-'), perc2str($tot[1], $tot[1]), 359 ($tot[2] || '-'), perc2str($tot[2], $tot[2]), 360 ($tot[4] || '-'), ($tot[3] || '-'), 361 traf2str($tot[5]), perc2str($tot[5], $tot[5]), 362 traf2str($tot[6]), perc2str($tot[6], $tot[6])) if @arr > 0; 363 return @out; 364} 365# -------------------------------------------------------------------- 366# areas with no traffic 367sub make_notraf { 368 my ($maxlen, @out, $len) = (16); 369 ##parse_config() unless defined %config_areas; 370 for my $tag (keys %config_areas) { 371 next if $areas{$tag}; 372 if (length $tag > $maxlen) { $maxlen = length $tag; } 373 } 374 $len = 78 - 18 - $maxlen; 375 push @out, sprintf("%-${maxlen}s", 'Area').' Uplink Links'; 376 push @out, ('�'x$maxlen).' '.('�'x16).' '.('�'x$len); 377 for my $tag (sort keys %config_areas) { 378 next if $areas{$tag}; 379 my $s = join(' ', @{$config_areas{$tag}{'links'}}); 380 if (length $s > $len) { substr $s, $len-3, length($s)-$len+3, '...'; } 381 push @out, sprintf "%-${maxlen}s %16s %s", $tag, 382 $config_areas{$tag}{'uplink'} || 'n/a', $s; 383 } 384 push @out, " No areas" unless @out > 2; 385 push @out, ('�'x$maxlen).' '.('�'x16).' '.('�'x$len); 386 return @out; 387} 388# -------------------------------------------------------------------- 389# links and areas with bad or dupe messages 390sub make_baddupe { 391 my (@out, @arr, @tot, $len, $s, $i); 392 my (%was_area, %was_link); 393 my ($titles, $sf, $tosum, $toout) = @_; 394 for my $v (@stat) { 395 for ($i = 0; $i <= @$toout; $i++) { last if $v->[$toout->[$i]] > 0; } 396 next if ($i == @$toout); 397 my $tag = $area_tag[$v->[0]]; 398 # sum - sort field 399 my $sum = 0; 400 for my $i (@$tosum) { $sum += $v->[$i]; } 401 # out rec 402 $link = $v->[1].':'.$v->[2].'/'.$v->[3].($v->[4] ? '.'.$v->[4] : ''); 403 my @rec = ($tag, $link, $sum); 404 for my $i (@$toout) { push @rec, $v->[$i]; $tot[$i] += $v->[$i]; } 405 push @arr, \@rec; 406 # calc totals 407 $was_area{ $v->[0] } = 1; 408 $was_link{ $link } = 1; 409 } 410 # sort 411 if ($sf > 1) { @arr = sort { $b->[$sf] <=> $a->[$sf] } @arr; } 412 elsif ($sf == 1) { @arr = sort { acmp($a->[1], $b->[1]) } @arr; } 413 else { @arr = sort { $a->[0] cmp $b->[0] } @arr; } 414 # make out 415 $len = 78 - 17 - 5*@$toout; 416 $s = sprintf("%-${len}s", 'Area').' Link '; 417 for (my $i = 0; $i < @$toout; $i++) { $s .= ' '.$titles->[$i]; } 418 push @out, $s; 419 $s = ('�'x$len).' '.('�'x16); 420 for (my $i = 0; $i < @$toout; $i++) { $s .= ' '.('�'x4); } 421 push @out, $s; 422 for my $rec (@arr) { 423 my $ss = $rec->[0]; 424 if (length $ss > $len) { substr $ss, $len-3, length($ss)-$len+3, '...'; } 425 $s = sprintf "%-${len}s %16s", $ss, $rec->[1]; 426 for ($i = 0; $i < @$toout; $i++) { $s .= ' '.sprintf "%4s", $rec->[$i+3] || '-'; } 427 push @out, $s; 428 } 429 push @out, " No records" unless @arr > 0; 430 $s = ('�'x$len).' '.('�'x16); 431 for (my $i = 0; $i < @$toout; $i++) { $s .= ' '.('�'x4); } 432 push @out, $s; 433 if (@arr > 0) { 434 $s = sprintf "%${len}s %16s", 'Total '.keys(%was_area).' area(s)', keys(%was_link).' link(s)'; 435 for my $i (@$toout) { $s .= ' '.sprintf "%4s", $tot[$i] || '-'; } 436 push @out, $s; 437 } 438 return @out; 439} 440# -------------------------------------------------------------------- 441# debug output of @stat array; optionally sort by specified column 442sub debug_stat { 443 my @sorted; 444 my ($sort) = @_; 445 if ($sort) { @sorted = sort { $b->[$sort] <=> $a->[$sort] } @stat; } 446 printf "%-30s %-16s\t In Out Dup Bad In b Out b\n", "Tag", "Address"; 447 printf "%s %s\t--- --- --- --- ----- -----\n", '-'x30, '-'x16; 448 for my $arr ($sort ? @sorted : @stat) { 449 printf "%-30s %d:%d/%d.%d\t%3d %3d %3d %3d %5d %5d\n", $area_tag[$arr->[0]], @$arr[1..$#$arr]; 450 } 451} 452# -------------------------------------------------------------------- 453# convert string to datetime: str2time($s[, $base]) 454sub str2time { 455 die "POSIX perl module is required for archive processing\n" unless eval { require POSIX; 1; }; 456 my ($s, $base) = @_; 457 $base = time if !defined $base; 458 my ($h, $d, $m, $y, $w) = (localtime $base)[2..6]; 459 $w = 7 if $w == 0; 460 $h = 0 unless $s =~ /[Hh]/o; 461 while (length $s > 0) { 462 my @a = $s =~ /^([+-]?)(\d+)([hHdDwWmMyY])?/o or return undef; 463 substr $s, 0, length(join '', @a), ''; 464 $a[2] = 'd' if !defined $a[2]; 465 if (lc $a[2] eq 'y') { 466 if ($a[0] eq '-') { $y -= $a[1]; } 467 elsif ($a[0] eq '+') { $y += $a[1]; } 468 elsif ($a[1] < 1900) { $y = $a[1]+100; } 469 else { $y = $a[1]-1900; } 470 } 471 elsif (lc $a[2] eq 'm') { 472 if ($a[0] eq '-') { $m -= $a[1]; } 473 elsif ($a[0] eq '+') { $m += $a[1]; } 474 else { $m = $a[1] - 1; } 475 } 476 elsif (lc $a[2] eq 'w') { 477 if ($a[0] eq '-') { $d -= $w+7*$a[1]-1; $w = 1; } 478 elsif ($a[0] eq '+') { $d += 7*$a[1]-$w+1; $w = 1; } 479 else { return undef; } 480 } 481 elsif (lc $a[2] eq 'd') { 482 if ($a[0] eq '-') { $d -= $a[1]; } 483 elsif ($a[0] eq '+') { $d += $a[1]; } 484 else { $d = $a[1]; } 485 } 486 elsif (lc $a[2] eq 'h') { 487 if ($a[0] eq '-') { $h -= $a[1]; } 488 elsif ($a[0] eq '+') { $h += $a[1]; } 489 else { $h = $a[1]; } 490 } 491 } 492 return POSIX::mktime(0, 0, $h, $d, $m, $y, $w, -1, -1); 493} 494# -------------------------------------------------------------------- 495# command line parser 496sub parse_cmdline { 497 my $i; 498 for ($i = 0; $i < @ARGV; $i++) { 499 if ($ARGV[$i] eq '-c') { 500 die "Use: -c <config file>\n" if $i+1 >= @ARGV; 501 $conf_file = $ARGV[$i+1]; $i++; 502 } 503 elsif ($ARGV[$i] =~ /^--conf/io) { 504 ($conf_file) = $ARGV[$i] =~ /^--conf=(.+)$/io or die "Use: --conf=<conf-file>\n"; 505 } 506 elsif ($ARGV[$i] =~ /^(?:-z|--[Gg][Zz])$/) { $GZ = 1; } 507 elsif (lc $ARGV[$i] eq '-a') { 508 die "Use: -a <archive layout> <start date> <period>\n" if $i+3 >= @ARGV; 509 $archive = $ARGV[$i+1]; 510 $dt1 = str2time($ARGV[$i+2]) or die "Bad date format: ".$ARGV[$i+2]."\n"; 511 $dt2 = str2time($ARGV[$i+3], $dt1) or die "Bad date format: ".$ARGV[$i+3]."\n"; 512 $i += 3; 513 } 514 elsif ($ARGV[$i] =~ /^--arch/io) { 515 my ($s1, $s2); 516 ($archive, $s1, $s2) = $ARGV[$i] =~ /^--arch=([^,]+),([^,]+),([^,]+)$/io or die "use: --arch=<archive-layout>,<start-date>,<period>\n"; 517 $dt1 = str2time($s1) or die "Bad date format: $s1\n"; 518 $dt2 = str2time($s2, $dt1) or die "Bad date format: $s2\n"; 519 } 520 elsif (lc $ARGV[$i] eq '-m') { 521 die "Use: -m <archive layout>\n" if $i+1 >= @ARGV; 522 $move = $ARGV[$i+1]; 523 $i++; 524 } 525 elsif ($ARGV[$i] =~ /^--move/io) { 526 ($move) = $ARGV[$i] =~ /^--move=(.+)$/io or die "use: --move=<archive-layout>\n"; 527 } 528 elsif ($ARGV[$i] =~ /^(?:-d|-[Dd][Ee][Ll])$/o) { $del = 1; } 529 elsif ($ARGV[$i] =~ /^(?:-h|-\?|--[Hh][Ee][Ll][Pp])$/o) { print USAGE(); exit; } 530 elsif ($ARGV[$i] =~ /^(?:-D|--[Dd][Ee][Bb][Uu][Gg])$/o) { $DBG = 1; } 531 elsif (-f $ARGV[$i]) { push @stat_file, $ARGV[$i]; $i++; last; } 532 else { die "Unknown parameter or missing stat file: $ARGV[$i]\n"; } 533 } 534 for (; $i < @ARGV; $i++) { 535 if (-f $ARGV[$i]) { push @stat_file, $ARGV[$i]; last; } 536 else { die "Missing stat file: $ARGV[$i]\n"; } 537 } 538 # make sure ;) 539 if (defined $move || defined $archive) { 540 die "POSIX perl module is required for archive processing\n" unless eval { require POSIX; 1; }; 541 } 542 if (defined $move) { 543 for ( ('File/Basename.pm', 'File/Copy.pm', 'File/Path.pm') ) { 544 die "$_ perl module is required for archive processing\n" unless eval { require; 1; }; 545 } 546 } 547} 548# -------------------------------------------------------------------- 549# init 550sub init { 551 $GZ = 0; 552 parse_cmdline; 553 # parse config _only_ if we know its name 554 $conf_file = $ENV{FIDOCONFIG} || $_[1] unless defined $conf_file; 555 parse_config($conf_file) if defined $conf_file; 556 # parse stat archive 557 if (defined $archive) { 558 print STDERR " * period: ".localtime($dt1)."-".localtime($dt2)."\n * archive layout: $archive\n" if $DBG; 559 my ($s, $s0); 560 for (my $i = $dt1; $i < $dt2; $i += 3600*24) { 561 #print STDERR " * strftime=".POSIX::strftime($archive, (localtime($i))[0..5])." for date ".localtime($i)."\n" if $DBG; 562 $s = POSIX::strftime($archive, (localtime($i))[0..5]); 563 next if $s eq $s0; 564 parse_stat($s, 1); 565 $s0 = $s; 566 } 567 } 568 # parse several stat files 569 elsif (@stat_file > 0) { 570 for my $stat_file (@stat_file) { parse_stat($stat_file); } 571 } 572 # parse one stat file only 573 else { 574 $stat_file = $_[0] unless defined $stat_file; 575 die "Please specify statfile in cmdline, parse_stat() or advStatisticsFile keyword\n" unless defined $stat_file; 576 parse_stat($stat_file); 577 } 578} 579# -------------------------------------------------------------------- 580# close files 581sub done { 582 if (defined $footer) { 583 print $footer; 584 my $buf; my $sz = tell PKT; seek PKT, 0, 0; 585 read PKT, $buf, $sz; 586 $buf =~ tr!\n!\r!; 587 seek PKT, 0, 0; print PKT $buf; 588 close PKT; undef $footer; 589 } 590 elsif (defined $file) { close OUT; undef $file; } 591} 592# -------------------------------------------------------------------- 593# file 594sub file { 595 done(); 596 open OUT, ">$_[0]" or die "Can't create file $_[0]\n"; select OUT; 597 $file = 1; 598} 599# -------------------------------------------------------------------- 600# pkt 601sub pkt { 602 my @mon = qw'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec'; 603 sleep 1 if defined $footer; 604 done(); 605 # params 606 my $msg = $_[0]; 607 $msg->{'from'} = "Statistic generator" unless defined $msg->{'from'}; 608 $msg->{'subj'} = "hpt statistics" unless defined $msg->{'subj'}; 609 $msg->{'area'} = $config{'reportto'} unless defined $msg->{'area'}; 610 $msg->{'area'} = undef if lc($msg->{'area'}) eq 'netmail' || $msg->{'area'} eq ''; 611 unless (defined $msg->{'to'}) { 612 $msg->{'to'} = defined $msg->{'area'} ? 'All' : $config{'sysop'}; 613 } 614 $msg->{'tearline'} = $config{'tearline'} unless defined $msg->{'tearline'}; 615 $msg->{'tearline'} = "advhptstat ver.$VERSION" if $msg->{'tearline'} eq ''; 616 $msg->{'origin'} = $config{'origin'} unless defined $msg->{'origin'}; 617 # get .pkt name 618 for (my $i = 0; $i <= 9999; $i++) { 619 $pktname = $config{'localinbound'}.sprintf("/ahcc%04d.pkt", $i); 620 last unless -f $pktname; 621 } 622 print STDERR " * creating pkt $pktname ($msg->{from} -> $msg->{to}: $msg->{subj})\n" if $DBG; 623 open PKT, "+>$pktname" or die "Can't create file $name\n"; binmode PKT; select PKT; 624 # type-2+ (fsc-0048) header 625 my @t = localtime; $t[5] %= 100; 626 my @from = $config{'address'} =~ m!^(\d+):(\d+)/(\d+)(?:\.(\d+))?!; 627 my $passwd = ''; my @to = @from[0..3]; 628 my $hdr = pack 'S12 C2 Z8 S2 S2 C2 S5 L', $from[2], $to[2], 629 $t[5], $t[4], $t[3], $t[2], $t[1], $t[0], 630 0, 2, ($from[3] ? -1 : $from[1]), $to[1], 0xfe, 0, $passwd, $from[0], $to[0], 631 ($from[3] ? $from[1] : 0), 0x0200, 0, 0, 0x0002, $from[0], $to[0], $from[3], $to[3], 0; 632 print $hdr; 633 # add packed message header 634 my $hdr = pack 'S6 Z20', $from[2], $to[2], $from[1], $to[1], 635 defined $msg->{'area'} ? 0x100 : 0x101, 0, 636 sprintf('%02d %3s %02d %02d:%02d:%02d', $t[3], $mon[$t[4]], $t[5]%100, $t[2], $t[1], $t[0]); 637 $hdr .= substr($msg->{'to'}, 0, 35)."\x00"; 638 $hdr .= substr($msg->{'from'}, 0, 35)."\x00"; 639 $hdr .= substr($msg->{'subj'}, 0, 71)."\x00"; 640 print "\x02\x00", $hdr; 641 if ( defined $msg->{'area'} ) { print "AREA:$msg->{area}\r"; } 642 else { 643 printf "\x01INTL %d:%d/%d %d:%d/%d\r", @to[0..2], @from[0..2]; 644 printf "\x01TOPT %d\r", $to[3] if $to[3]; 645 printf "\x01FMPT %d\r", $from[3] if $from[3]; 646 } 647 printf "\x01MSGID %s %08x\r", $config{'address'}, time; 648 $footer = "--- $msg->{tearline}\r"; 649 $footer .= " * Origin: $msg->{origin} ($config{address})\r" if defined $msg->{'area'}; 650 $footer .= "\x00\x00\x00"; 651} 652 653sub USAGE () { return <<EOF 654advhptstat ver.$VERSION, (c)opyright 2002-03, by val khokhlov 655 656 Usage: advhptstat [options] [stat file(s)...] 657 Options are: 658 -c <config>, --conf=<config> specifies config file name 659 -d, --del delete successfully processed logs 660 -m <layout>, --move=<layout> archive successfully processed logs 661 -z, --gz force use gzip'ed binary stat logs 662 Instead of one or more stat files you can use archive for a period: 663 -a <layout> <start> <end>, --arch=<layout>,<start>,<end> 664 <layout> - full filename of a stat log for a day if strftime() format 665 <start> - start date of period (see below for format) 666 <end> - end date of period (actually, *not* inclusive) 667 668 date <start>, <end> consists of token(s): [+-]<NN>[hdwmy] 669 use 15x to set value to 15 (h - hour, d - day, m - month, y - year) 670 use +2d to advance day forward by 2, -6d to advance day backward by 6 671 use -1w to set date to Monday of previous week, +1w - next week 672 (if letter [hdwmy] is omitted 'd' is assumed) 673 674 Examples (assume now is 17 Jan 2003): 675 advhptstat hpt.stat.bin -- simply use hpt.stat.bin 676 advhptstat -a "/home/fido/log/%Y/%m/%d/hpt.sta.gz" -7 +7 677 -- will use files: /home/fido/log/2003/01/##/hpt.sta.gz, ##=10..16 678EOF 679} 680