1#! /usr/bin/perl -w
2# fixscript will replace this line with code to load INN::Config
3
4#  Copyright Andreas Lamrecht 1998
5#  <Andreas.Lamprect@siemens.at>
6#
7#  Modified by Kjetil T. Homme 1998, 2000
8#  <kjetilho@ifi.uio.no>
9#
10#  Modified by Robert R. Collier 1998
11#  <rob@lspace.org>
12#
13#  bigint support added by Duane Currie (sandman@hub.org) 1998
14
15use strict;
16use Getopt::Long;
17use Math::BigInt;
18use Math::BigFloat;
19use English;
20
21my $conffile = "$INN::Config::pathetc/cycbuff.conf";
22my $storageconf = "$INN::Config::pathetc/storage.conf";
23my $lastconftime = 0;
24
25sub usage {
26    print <<"_end_";
27Summary tool for CNFS
28
29Usage:
30	$0 [-ahpPsv] [-c class] [-i seconds] [-l [seconds]] [-m buffer]
31
32	If called without args, does a one-time status of all CNFS buffers
33	-a:           print the age of the oldest article in the cycbuff
34	-c class:     print out status of CNFS buffers in that class
35	-h:           this information
36	-i seconds:   initial sleep of that many seconds at startup
37	-l [seconds]: loop like vmstat, default seconds = 600
38	-m buffer:    print out information suitable for MRTG
39	-p:           print out an MRTG config file
40	-P:           write PID into $INN::Config::pathrun/cnfsstat.pid
41	-s:           log through syslog
42	-v:           do consistency checks and print the result
43_end_
44    exit(1);
45}
46
47my (%class, %buff, %stor, @storsort);
48my (%prevclass, %prevbuff, %prevstor, @prevstorsort);
49
50my @buffers;
51
52my ($oclass, $obuffer);
53my %opt = (c=>\$oclass, m=>\$obuffer);
54Getopt::Long::config('no_ignore_case');
55GetOptions(\%opt,
56           "-a", "-c=s", "-h", "-i=i", "-l:i", "-m=s",
57           "-p", "-P", "-s", "-v");
58
59usage() if $opt{'h'};
60
61my $use_syslog = 0;
62if ($opt{'s'}) {
63    eval { require Sys::Syslog; import Sys::Syslog; $use_syslog = 1 };
64    if ($use_syslog) {
65        if ($Sys::Syslog::VERSION lt 0.15) {
66            eval "sub Sys::Syslog::_PATH_LOG { '/dev/log' }" if $^O eq 'dec_osf';
67            Sys::Syslog::setlogsock('unix') if $^O =~ /linux|dec_osf|freebsd|darwin/;
68        }
69	openlog('cnfsstat', 'pid', $INN::Config::syslog_facility);
70    } else {
71	print STDERR "Syslog is not available.  -s option is ignored.\n";
72    }
73}
74
75if ($opt{'P'}) {
76    if (open my $FILE, '>', "$INN::Config::pathrun/cnfsstat.pid") {
77	print $FILE "$$\n";
78	close $FILE;
79    };
80}
81
82my $sleeptime = (defined($opt{'l'}) && $opt{'l'} > 0) ? $opt{'l'} : 600;
83
84unless (read_cycbuffconf()) {
85    print STDERR "Invalid $conffile file.\n";
86    exit (1);
87}
88
89unless (read_storageconf()) {
90    print STDERR "Invalid $storageconf file.\n";
91    exit (1);
92}
93
94
95mrtg($obuffer) if $obuffer;
96mrtg_config() if $opt{'p'};
97
98# Initial sleep, before starting the work.
99if(defined($opt{'i'}) && $opt{'i'} > 0) {
100    sleep($opt{'i'});
101    if (!$use_syslog) {
102        print STDOUT "$opt{'i'} seconds later:\n";
103    }
104}
105
106
107START:
108
109# Check whether the configuration files need reloading.
110my $cycbufftime = (stat($conffile))[9] if (-r $conffile);
111my $storagetime = (stat($storageconf))[9] if (-r $storageconf);
112my $maxtime = ($cycbufftime < $storagetime) ? $storagetime : $cycbufftime;
113
114# Set $lastconftime for the first run of the comparison.
115$lastconftime = $maxtime if not $lastconftime;
116
117if ($lastconftime < $maxtime) {
118    my $reloadok = 1;
119
120    $lastconftime = $maxtime;
121
122    # Save the previous configuration, in case reloading it fails.
123    # Direct copies of the arrays and hashes works fine here.
124    %prevclass = %class; undef %class;
125    %prevbuff = %buff; undef %buff;
126    %prevstor = %stor; undef %stor;
127    @prevstorsort = @storsort; undef @storsort;
128
129    unless (read_cycbuffconf()) {
130        print STDERR "Invalid $conffile file.\n";
131        $reloadok = 0;
132    }
133
134    unless (read_storageconf()) {
135        print STDERR "Invalid $storageconf file.\n";
136        $reloadok = 0;
137    }
138
139    # In case reloading configuration files fails, restore the
140    # previous known configuration for this run of cnfsstat.
141    if (!$reloadok) {
142        %class = %prevclass;
143        %buff = %prevbuff;
144        %stor = %prevstor;
145        @storsort = @prevstorsort;
146    }
147}
148
149my $logline;
150my $header_printed = 0;
151my ($gr, $cl, $min, $max);
152if ($oclass) {
153    if ($class{$oclass}) {
154	if (!$header_printed) {
155            if ($stor{$oclass}) {
156                ($gr, $cl, $min, $max) = split(/:/, $stor{$oclass});
157            } else {
158                ($gr, $cl, $min, $max) = ('', $oclass, 0, 0);
159            }
160            # Remove leading and trailing double quotes, if present.
161            $gr =~ s/"?([^"]*)"?/$1/g;
162	    if ($use_syslog) {
163		if ($min || $max) {
164		    $logline = sprintf("Class %s for groups matching \"%s\" article size min/max: %d/%d", $oclass, $gr, $min, $max);
165		} else {
166		    $logline = sprintf("Class %s for groups matching \"%s\"", $oclass, $gr);
167		}
168	    } else {
169		print STDOUT "Class $oclass";
170		print STDOUT " for groups matching \"$gr\"";
171		if ($min || $max) {
172		    print STDOUT ", article size min/max: $min/$max";
173		}
174		print STDOUT "\n";
175	    }
176	    $header_printed = 1;
177	}
178
179	@buffers = split(/,/, $class{$oclass});
180	if (! @buffers) {
181	    print STDERR "No buffers in Class $oclass ...\n";
182	    next;
183	}
184
185	foreach my $b (@buffers) {
186	    if (! $buff{$b} ) {
187		print STDERR "No buffer definition for buffer $b ...\n";
188		next;
189	    }
190	    print_cycbuff_head($buff{$b});
191	}
192    } else {
193	print STDERR "Class $oclass not found ...\n";
194    }
195} else { # Print all Classes
196    my %buffDone;
197    foreach my $c (@storsort) {
198	($gr, $cl, $min, $max) = split(/:/, $stor{$c});
199        # Remove leading and trailing double quotes, if present.
200        $gr =~ s/"?([^"]*)"?/$1/g;
201	if ($use_syslog) {
202	    if ($min || $max) {
203		$logline = sprintf("Class %s for groups matching \"%s\" article size min/max: %d/%d", $c, $gr, $min, $max);
204	    } else {
205		$logline = sprintf("Class %s for groups matching \"%s\"", $c, $gr);
206	    }
207	} else {
208	    print STDOUT "Class $c";
209	    print STDOUT " for groups matching \"$gr\"";
210	    if($min || $max) {
211		print STDOUT ", article size min/max: $min/$max";
212	    }
213	    print STDOUT "\n";
214	}
215	@buffers = split(/,/, $class{$c});
216	if(! @buffers) {
217	    print STDERR "No buffers in Class $c ...\n";
218	    next;
219	}
220
221	foreach my $b (@buffers) {
222	    if(! $buff{$b} ) {
223		print STDERR "No buffer definition for buffer $b ...\n";
224		next;
225	    }
226	    print_cycbuff_head($buff{$b});
227            $buffDone{$b}++;
228	}
229	if (!$use_syslog) {
230	    print STDOUT "\n";
231	}
232    }
233
234    if (!$use_syslog) {
235        # Finally, print all retired cyclic buffers, still active but no longer
236        # mentioned in a class.
237        my $buffRetired = 0;
238        foreach my $b (sort keys(%buff)) {
239            if(! exists($buffDone{$b})) {
240                if (!$buffRetired) {
241                    print STDOUT "Retired cyclic buffers\n";
242                }
243                print_cycbuff_head($buff{$b});
244                $buffRetired++;
245            }
246        }
247    }
248}
249
250if(defined($opt{'l'})) {
251    sleep($sleeptime);
252    if (!$use_syslog) {
253	print STDOUT "$sleeptime seconds later:\n";
254    }
255    goto START;
256}
257
258sub read_cycbuffconf {
259    my @line;
260    return 0 unless open my $CONFFILE, '<', $conffile;
261
262    while(<$CONFFILE>) {
263	$_ =~ s/^\s*(.*?)\s*$/$1/;
264	# Here we handle continuation lines
265	while (m/\\$/) {
266	    my $contline = <$CONFFILE>;
267	    $contline =~ s/^\s*(.*?)\s*$/$1/;
268	    chop;
269	    $_ .= $contline;
270	}
271	# \x23 below is #.  Emacs perl-mode gets confused by the "comment"
272	next if ($_ =~ /^\s*$/ || $_ =~ /^\x23/);
273	next if ($_ =~ /^cycbuffupdate:/ || $_ =~ /^refreshinterval:/);
274
275	if($_ =~ /^metacycbuff:/) {
276	    @line = split(/:/, $_);
277	    if ($class{$line[1]}) {
278		print STDERR "Class $line[1] more than one time in CycBuff Conffile $conffile ...\n";
279		return 0;
280	    }
281
282	    $class{$line[1]} = $line[2];
283	    next;
284	}
285
286	if ($_ =~ /^cycbuff/) {
287	    @line = split(/:/, $_);
288	    if ($buff{$line[1]}) {
289		print STDERR "Buff $line[1] more than one time in CycBuff Conffile $conffile ...\n";
290		return 0;
291	    }
292	    $buff{$line[1]} = $line[2];
293	    next;
294	}
295
296	print STDERR "Unknown config line \"$_\" in CycBuff Conffile $conffile ...\n";
297        return 0;
298    }
299    close $CONFFILE;
300    return 1;
301}
302
303sub read_storageconf {
304    my $line = 0;
305    return 0 unless open my $STOR, '<', $storageconf;
306
307    while (<$STOR>) {
308	++$line;
309	next if /^\s*#/;
310
311	# defaults
312	my %key = ("NEWSGROUPS" => "*",
313		    "SIZE" => "0,0");
314
315	if (/method\s+cnfs\s+\{/) {
316	    while (<$STOR>) {
317		++$line;
318		next if /^\s*#/;
319		last if /\}/;
320		if (/(\w+):\s+(\S+)/i) {
321		    $key{uc($1)} = $2;
322		}
323	    }
324	    unless (defined $key{'CLASS'} && defined $key{'OPTIONS'}) {
325		print STDERR "storage.conf:$line: ".
326			"Missing 'class' or 'options'\n";
327		return 0;
328	    }
329
330	    $key{'SIZE'} .= ",0" unless $key{'SIZE'} =~ /,/;
331	    $key{'SIZE'} =~ s/,/:/;
332
333	    if (!defined $stor{$key{'OPTIONS'}}) {
334		$stor{$key{'OPTIONS'}} = "$key{'NEWSGROUPS'}:$key{'CLASS'}:" .
335			"$key{'SIZE'}:$key{'OPTIONS'}";
336		push(@storsort, $key{'OPTIONS'});
337	    }
338	}
339    }
340    return 1;
341}
342
343sub print_cycbuff_head {
344    my ($buffpath) = @_;
345    my ($name, $len, $free, $update, $cyclenum, $oldart) =
346	    get_cycbuff_info($buffpath);
347
348    if ($use_syslog) {
349	($name) = split(/\s/, $name);
350	$name =~ s/\0//g;
351	# Log only if the buffer is initialized (cyclenum is not -1).
352	syslog ('notice', '%s Buffer %s, len: %.2f  Mbytes, used: %.2f Mbytes (%4.1f%%) %3d cycles',
353		$logline, $name, Math::BigFloat->new($len) / (1024 * 1024),
354		Math::BigFloat->new($free) / (1024 * 1024),
355		100 * Math::BigFloat->new($free) / Math::BigFloat->new($len),
356		$cyclenum) if $cyclenum >= 0;
357	return 0;
358    }
359
360    $name =~ s/\0//g;
361    print " Buffer $name, size: ", human_readable($len, 4);
362    print ", position: ", human_readable($free, 4);
363    printf "  %.2f cycles\n", $cyclenum + Math::BigFloat->new($free) / Math::BigFloat->new($len);
364
365    # The CNFS buffer may not have been initialized yet or received an article.
366    # Take it into account because $oldart may be undefined.
367    my ($when, $ago) = make_time($update);
368    if (defined $oldart or not $opt{'a'}) {
369        print "  Newest: $when, $ago ago\n";
370    } else {
371        print "  Created: $when, $ago ago\n";
372    }
373
374    if ($opt{'a'}) {
375        if (defined $oldart) {
376            my ($when, $ago) = make_time($oldart);
377            print "  Oldest: $when, $ago ago\n";
378        } else {
379            print "  No oldest article\n";
380        }
381    }
382    return;
383}
384
385sub make_time {
386    my ($t) = @_;
387    my (@ret);
388
389    my ($sec,$min,$hour,$mday,$mon,$year) =
390	    (localtime($t))[0..5];
391    push (@ret, sprintf("%04d-%02d-%02d %2d:%02d:%02d",
392			$year + 1900, $mon + 1, $mday, $hour, $min, $sec));
393    $t = time - $t;
394
395    $mday = int($t/86400); $t = $t % 86400;
396    $hour = int($t/3600);  $t = $t % 3600;
397    $min  = int($t/60);    $t = $t % 60;
398
399    push (@ret, sprintf("%4d days, %2d:%02d:%02d",
400			$mday, $hour, $min, $t));
401    return @ret;
402}
403
404sub human_readable {
405    my ($val, $digits) = @_;
406    $val =~ s/\+//;
407
408    my @name = ("kBytes", "MBytes", "GBytes", "TBytes");
409    my $base = 1024;
410    my $factor = 1024;
411
412    my $unit = -1;
413    my $oldscaled = Math::BigFloat->new($val) / $base;
414    my $scaled = $oldscaled;
415    while ( ( int($scaled) > 0 ) && ( $unit < $#name ) ) {
416	$oldscaled = $scaled;
417	$scaled /= $factor;
418	$unit++;
419    }
420    $scaled = $oldscaled;
421    my $predigits = length (int($scaled));
422    my $postdigits = $digits - $predigits - 1;
423    $postdigits = 0 if $postdigits < 0;
424    ++$digits;
425
426    return sprintf ("%${digits}.${postdigits}f %s", $scaled, $name[$unit]);
427}
428
429sub mrtg {
430	my $buffer = shift;
431	# print "Buffer = $buff{$buffer}\n";
432	my @info = get_cycbuff_info($buff{$buffer});
433	print "$info[1]\n";
434	print "$info[2]\n";
435	print "$info[4]\n";
436	print "$info[0]\n";
437	exit(0);
438}
439
440sub mrtg_config {
441	print "Sub MRTG-CONFIG\n";
442	foreach my $class (sort(keys(%class))) {
443		print "##\n## Class  : $class\n## Wildmat: $stor{$class}\n##\n\n";
444		foreach my $buffer (split /\,/, $class{$class}) {
445			mrtg_buffer($class, $buffer);
446		}
447	}
448	exit(0);
449}
450
451sub mrtg_buffer {
452	my ($class,$buffer) = @_;
453	#my ($name, $num, $buff, $size) = @_;
454        my $tag = 'cnfs-' . $buffer;
455
456        print 'Target[', $tag, ']: `', "$INN::Config::pathbin/cnfsstat -m ", $buffer, '`', "\n";
457        print 'MaxBytes[', $tag, ']: ', (get_cycbuff_info($buff{$buffer}))[1], "\n";
458        print 'Title[', $tag, ']: ', "${buffer} Usage\n";
459        print 'Options[', $tag, ']: growright gauge', "\n";
460        print 'YLegend[', $tag, ']: ', "${buffer}\n";
461        print 'ShortLegend[', $tag, ']: MB', "\n";
462        print 'PageTop[', $tag, ']: ', "<H1>Usage of ${buffer}</H1>\n";
463	print "<BR><TT>$stor{$class}</TT>\n";
464        print "\n";
465        return 1;
466}
467
468sub bigsysseek {
469    my ($handle, $offset) = @_;
470
471    # $offset may be a bigint; and have a value that doesn't fit in a signed long.
472    # Even with largefiles enabled, perl will still truncate the argument to lseek64
473    # to 32 bits.  So we seek multiple times, <2G at a time.
474
475    if ($offset > 2147483647) {
476	# Since perl truncates the return value of lseek64 to 32 bits, it might
477	# see a successful return value as negative, and return FALSE (undef).
478	# So we must ignore the return value of sysseek and assume that it worked.
479
480	seek($handle, 0, 0);
481	while ($offset > 2000000000) {
482	    sysseek($handle, 2000000000, 1) || return 0;
483	    $offset -= 2000000000;
484	}
485	sysseek($handle, $offset, 1) || return 0;
486	return 1;
487    } else {
488	return sysseek($handle, $offset, 0);
489    }
490}
491
492sub check_read_return {
493  my $result = shift;
494  die "read: $!\n" unless defined($result);
495  die "read reached eof\n" unless $result;
496  return $result;
497}
498
499sub get_cycbuff_info {
500    my ($buffpath) = @_;
501    my $oldart;
502
503    my $CNFSMASIZ = 8;
504    my $CNFSNASIZ = 16;
505    my $CNFSPASIZ = 64;
506    my $CNFSLASIZ = 16;
507    my $headerlength = 2 * $CNFSMASIZ + 2 * $CNFSNASIZ + $CNFSPASIZ + (6 * $CNFSLASIZ);
508
509    my ($BUFF, $buff);
510
511    if ( !open $BUFF, '<', $buffpath ) {
512	print STDERR "Cannot open Cycbuff $buffpath ...\n";
513	exit(1);
514    }
515
516    $buff = "";
517    if ( !read $BUFF, $buff, $headerlength ) {
518	print STDERR "Cannot read $headerlength bytes from file $buffpath...\n";
519	exit(1);
520    }
521
522    my ($magic, $name, $path, $lena, $freea, $updatea, $cyclenuma, $metaname,
523     $orderinmeta, $currentbuff, $blksza) =
524           unpack("a8 a16 a64 a16 a16 a16 a16 a16 a16 a8 a16", $buff);
525
526    if (!$magic) {
527	print STDERR "Error while unpacking header ...\n";
528	exit(1);
529    }
530
531    my $len = bhex($lena);
532    my $free = bhex($freea);
533    my $update = hex($updatea);
534    my $cyclenum = hex($cyclenuma) - 1;
535    my $blksz = ($magic =~ m/^CBuf4/) ? hex($blksza) : 512;
536
537    if ($opt{'a'}) {
538
539	my $pagesize = 16384;
540	my $minartoffset = int($len / ($blksz * 8)) + 512;
541	# Align upwards:
542	$minartoffset = ($minartoffset + $pagesize) & ~($pagesize - 1);
543
544	if ($cyclenum == 0 && $free == $minartoffset) {
545	    # The cycbuff has no articles yet.
546	    goto done;
547	}
548
549	# Don't loop endlessly, set rough upper bound
550	my $sentinel = $cyclenum == 0 ? $free : $len;
551	my $offset = $cyclenum == 0 ? $minartoffset : $free + $pagesize;
552
553	bigsysseek($BUFF, $offset) || die "sysseek: $!\n";
554	check_read_return (sysread ($BUFF, $buff, $pagesize));
555	do {
556            my $chunk;
557	    check_read_return (sysread ($BUFF, $chunk, $pagesize));
558
559	    $buff .= $chunk;
560	    while ($buff =~ /^message-id:\s+(<.*?>)/mi) {
561		$buff = $POSTMATCH;
562		$oldart = lookup_age($1);
563		next unless $oldart;
564
565		# Is the article newer than the last update of the cycbuff?
566		if ($oldart >= $update) {
567		    $update = $oldart;
568		} elsif ($oldart < $update - 60) {
569		    goto done;
570		}
571	    }
572	    # Just in case we chopped Message-ID in two, use the end
573	    # at the front in next iteration.
574	    $buff = substr ($buff, -$blksz);
575
576	} while ($sentinel -= $pagesize > 0);
577    }
578
579done:
580    close $BUFF;
581    return($name,$len,$free,$update,$cyclenum,$oldart);
582}
583
584sub lookup_age {
585    my ($msgid) = @_;
586
587    my $history = safe_run("$INN::Config::newsbin/grephistory", "-l", $msgid);
588    if ($history =~ /\t(\d+)~/) {
589	return $1;
590    }
591
592    if ($opt{'v'}) {
593        print "   (Missing $msgid)\n";
594    }
595
596    return 0;
597}
598
599sub safe_run {
600    my $output = "";
601
602    my $pid = open my $KID_TO_READ, "-|";
603    die "fork: $!\n" unless defined $pid;
604    if ($pid) {
605	while (<$KID_TO_READ>) {
606	    $output .= $_;
607	}
608	close $KID_TO_READ;
609    } else {
610	exec(@_) || die "can't exec $_[0]: $!";
611	# NOTREACHED
612    }
613    return $output;
614}
615
616# Hex to bigint conversion routine.
617# bhex(HEXSTRING) returns BIGINT (with leading + chopped off).
618#
619# In most languages, unlimited size integers are done using string math
620# libraries usually called bigint.  (Java, Perl, etc.)
621#
622# Bigint's are really just strings.
623
624sub bhex {
625    my $hexValue = shift;
626    $hexValue =~ s/^0x//;
627
628    my $integerValue = Math::BigInt->new('0');
629    for (my $i = 0; $i < length($hexValue); $i += 2) {
630        # Could be more efficient going at larger increments, but byte
631        # by byte is safer for the case of 9 byte values, 11 bytes, etc.
632
633        my $byte = substr($hexValue, $i, 2);
634        my $byteIntValue = hex($byte);
635
636        # bmuladd() is only in Perl >= 5.10.0.
637        $integerValue->bmul('256');
638        $integerValue->badd("$byteIntValue");
639    }
640
641    my $result = $integerValue->bstr();
642    $result =~ s/^\+//;
643    return $result;
644}
645