1#!/usr/bin/perl
2# $Id$
3# License: OSI Artistic License
4# Author:  (c) Soren Dossing, 2005
5# Author:  (c) Alan Brenner, Ithaka Harbors, 2008
6# Author:  (c) Matthew Wall, 2010
7
8# FIXME: get rid of the global variables
9
10## no critic (RegularExpressions)
11## no critic (ProhibitCascadingIfElse)
12## no critic (ProhibitExcessComplexity)
13## no critic (ProhibitDeepNests)
14## no critic (ProhibitMagicNumbers)
15## no critic (ProhibitConstantPragma)
16## no critic (ProhibitPostfixControls)
17
18package ngshared; ## no critic (Capitalization)
19
20use strict;
21use warnings;
22use Carp;
23use CGI qw(escape unescape -nosticky);
24use Data::Dumper;
25use English qw(-no_match_vars);
26use Fcntl qw(:DEFAULT :flock);
27use File::Find;
28use File::Basename;
29use File::Path qw(mkpath);
30use RRDs;
31use POSIX;
32use Time::HiRes qw(gettimeofday);
33use MIME::Base64;
34use Digest::MD5 qw(md5);
35
36use Exporter qw(import);
37
38use vars qw($VERSION %Config %Labels %i18n %authhosts %authz %hsdata $colorsub $LOG $CFGNAME); ## no critic (ProhibitPackageVars)
39
40# FIXME: for now we export pretty much everything.  this should be pruned so
41# that we export only what we must for the cgi and data collection, but still
42# permit tests to have access.
43# FIXME: this should be done as EXPORT_OK or EXPORT_TAGS
44## no critic (Modules::ProhibitAutomaticExportation)
45our @EXPORT = qw($VERSION $CFGNAME %Config DBCRT DBERR DBWRN DBINF DBDEB cfgparams checkrrddir convertdeprecated dbfilelist debug dumper getdebug getimg getlabel getparams getperiodctrls getperiodlabel getrules getstyle gettimestamp graphsizes hashcolor havepermission htmlerror imgerror init initperiods loadperms printfooter printgraphlinks printheader printinitscript printperiodlinks processdata readconfig readdatasetdb readgroupdb readhostdb readi18nfile readlabelsfile readperfdata readrrdoptsfile readservdb rrdline $LOG %authz %authhosts %hsdata %Labels %i18n addopt arrayorstring buildurl checkdatasources checkdirempty checkdsname checkminmax checkuserlist cleanline createminmax createrrd filterdb formatelapsedtime formattime getcfgfn getdataitems getdatalabel getdbs gethsdd gethsddvalue gethsdvalue gethsdvalue2 getlineattr getperms getrefresh getrras getserverlist graphinfo hsddmatch initlog listtodict mergeopts mkfilename mki18nfilename mklegend mkvname parsedb printcontrols printdefaultscript printi18nscript printincludescript printmenudatascript printsummary readfile readnagiosperms readpermsfile rrdupdate runcreate runupdate scandirectory scanhierarchy scanhsdata scrubuserlist setdata setlabels sortnaturally stacktrace str2list evalrules);
46
47$VERSION = '1.5.2';
48$CFGNAME = 'nagiosgraph.conf';
49
50use constant PROG => basename($PROGRAM_NAME);
51
52use constant {
53    DBCRT => 1,
54    DBERR => 2,
55    DBWRN => 3,
56    DBINF => 4,
57    DBDEB => 5,
58};
59
60use constant {
61    NAGIOSGRAPHURL => 'http://nagiosgraph.sourceforge.net/',
62    ERRSTYLE => 'font-family: sans-serif; font-size: 0.8em; padding: 0.5em; background-color: #fff6f3; border: solid 1px #cc3333; margin-bottom: 1.5em;',
63    DBLISTROWS => 10,
64    PERIODLISTROWS => 6,
65    RRDEXT => '.rrd',
66    DEFAULT => 'default',
67    DSNAME_MAXLEN => 19,
68    NCONFIG_VERSION => 35,  # required version of Nagios::Config
69};
70
71# the javascript version number here must match the version number in the
72# nagiosgraph.js file.  change this number when the javascript is not
73# backward compatible with previous versions.
74use constant {
75    JSVERSION => 1.7,
76    JSMISSING => 'nagiosgraph.js is not installed or wrong version.',
77    JSDISABLED => 'JavaScript is disabled.',
78};
79
80# default values for configuration options
81use constant {
82    GEOMETRIES => '500x80,650x150,1000x200',
83    GRAPHTOP => 21,
84    GRAPHLEFT => 50,
85    GRAPHWIDTH => 600,
86    GRAPHHEIGHT => 100,
87    COLORMAX => '888888',
88    COLORMIN => 'BBBBBB',
89    COLORS => 'D05050,D08050,D0D050,50D050,50D0D0,5050D0,D050D0',
90    COLORSCHEME => 1,
91    COLORSATURATION => 0.8,
92    COLORVALUE => 0.95,
93    STEPSIZE => 300,
94    HEARTBEAT => 600,
95    RESOLUTIONS => '600 700 775 797',
96    STEPS => '1 6 24 288',
97    XFF => 0.5,
98    PERIODS => 'day week month year',
99    FIXED_SCALE_FORMAT => '%7.2lf',
100    DEFAULT_FORMAT => '%7.2lf%s',
101};
102
103# 5x5 clear image
104use constant IMG => 'iVBORw0KGgoAAAANSUhEUgAAAAUAAAAFCAYAAACNbyblAAAAIXRFWHRTb2Z0d2FyZQBHcmFwaGljQ29udmVydGVyIChJbnRlbCl3h/oZAAAAGUlEQVR4nGL4//8/AzrGEKCCIAAAAP//AwB4w0q2n+syHQAAAABJRU5ErkJggg==';
105# 8x8 plus sign
106use constant IMG_PLUS => 'data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAICAQAAABuBnYAAAAAGUlEQVQImWNggIANQIgC8AlsQIOYAiQbCgAUMxNBUqWR0wAAAABJRU5ErkJggg==';
107# 8x8 minus sign
108use constant IMG_MINUS => 'data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAICAQAAABuBnYAAAAAEklEQVQIW2NgIANsQIOYAiQDAOcmCwGcy16yAAAAAElFTkSuQmCC';
109
110$colorsub = -1;
111
112# Pre-defined available graph periods
113#     Hourly     =   1h =   3600s
114#     Daily      =  33h = 118800s
115#     Weekly     =   9d = 777600s
116#     Monthly    =   5w = 3024000s
117#     Quarterly  =  14w = 8467200s
118#     Yearly     = 400d = 34560000s
119# Period data tuples are [name, period (seconds), offset (seconds)]
120my @PERIOD_KEYS = qw(hour day week month quarter year);
121my %PERIOD_DATA = ('hour' => ['hour', 5_400, 3_600],
122                   'day' => ['day', 118_800, 86_400],
123                   'week' => ['week', 777_600, 604_800],
124                   'month' => ['month', 3_024_000, 2_592_000],
125                   'quarter' => ['quarter', 8_467_200, 7_776_000],
126                   'year' => ['year', 34_560_000, 31_536_000],);
127my %PERIOD_LABELS =qw(hour Hour day Day week Week month Month quarter Quarter year Year);
128
129# keys for string literals in the javascript
130my @JSLABELS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
131push @JSLABELS, qw(Mon Tue Wed Thu Fri Sat Sun);
132push @JSLABELS, qw(OK Now Cancel);
133push @JSLABELS, 'now', 'graph data';
134
135# image parameters
136my @IMG_FG_COLOR = (255,20,20);
137
138# Debug/logging support #######################################################
139# Write information to STDERR
140sub stacktrace {
141    my $msg = shift;
142    warn "$msg\n";
143    my $max_depth = 30;
144    my $ii = 1;
145    warn "--- Begin stack trace ---\n";
146    while ((my @call_details = (caller $ii++)) && ($ii < $max_depth)) {
147      warn "$call_details[1] line $call_details[2] in function $call_details[3]\n";
148    }
149    warn "--- End stack trace ---\n";
150    return;
151}
152
153# Write debug information to log file
154sub debug {
155    my ($level, $text) = @_;
156    if (not defined $Config{debug}) { $Config{debug} = 0; }
157    return if ($level > $Config{debug});
158    $level = qw(none critical error warn info debug)[$level];
159    my $message = join q( ), scalar (localtime), PROG, $PID, $level, $text;
160    if (not fileno $LOG) {
161        stacktrace($message);
162        return;
163    }
164    # Get a lock on the LOG file (blocking call)
165    my $rval = eval {
166        flock $LOG, LOCK_EX;
167        print ${LOG} "$message\n" or carp("cannot write to LOG: $OS_ERROR");
168        flock $LOG, LOCK_UN;
169        return 0;
170    };
171    if ($EVAL_ERROR or $rval) {
172        stacktrace($message);
173    }
174    return;
175}
176
177sub dumper {
178    my ($level, $label, $vals) = @_;
179    return if ! defined $Config{debug} || $level > $Config{debug};
180    my $dd = Data::Dumper->new([$vals], [$label]);
181    $dd->Indent(1);
182    my $out = $dd->Dump();
183    chomp $out;
184    debug($level, substr $out, 1);
185    return;
186}
187
188sub gettimestamp {
189    my @tod = gettimeofday;
190    return $tod[0] * 1_000_000 + $tod[1];
191}
192
193# if a filename is relative, we look for it in the configuration directory.
194# otherwise use the complete filename.
195sub getcfgfn {
196    my ($fn) = @_;
197    if ( substr($fn, 0, 1) ne q(/) ) {
198        $fn = $INC[0] . q(/) . $fn;
199    }
200    return $fn;
201}
202
203sub formatelapsedtime {
204    my ($s,$e) = @_;
205    my $ms = $e - $s;
206    my $hh = int $ms / 3_600_000_000;
207    $ms -= $hh * 3_600_000_000;
208    my $mm = int $ms / 60_000_000;
209    $ms -= $mm * 60_000_000;
210    my $ss = int $ms / 1_000_000;
211    $ms -= $ss * 1_000_000;
212    $ms = int $ms / 1_000;
213    if ($hh < 10) { $hh = '0' . $hh; }
214    if ($mm < 10) { $mm = '0' . $mm; }
215    if ($ss < 10) { $ss = '0' . $ss; }
216    if ($ms < 1) { $ms = '000'; }
217    elsif ($ms < 10) { $ms = '00' . $ms; }
218    elsif ($ms < 100) { $ms = '0' . $ms; }
219    return $hh . q(:) . $mm . q(:) . $ss . q(.) . $ms;
220}
221
222sub init {
223    my ($app) = @_;
224
225    my $errmsg = readconfig($app, 'cgilogfile');
226    if ($errmsg ne q()) {
227        htmlerror($errmsg);
228        croak($errmsg);
229    }
230
231    my ($cgi, $params) = getparams();
232    getdebug($app, $params->{host}, $params->{service});
233
234    $errmsg = readi18nfile($cgi->multi_param('language'));
235    if ($errmsg ne q()) {
236        debug(DBWRN, $errmsg);
237    }
238    $errmsg = readlabelsfile();
239    if ($errmsg ne q()) {
240        debug(DBWRN, $errmsg);
241    }
242    $errmsg = checkrrddir('read');
243    if ($errmsg ne q()) {
244        htmlerror($errmsg);
245        croak($errmsg);
246    }
247    $errmsg = readrrdoptsfile();
248    if ($errmsg ne q()) {
249        htmlerror($errmsg);
250        croak($errmsg);
251    }
252    $errmsg = loadperms( $cgi->remote_user() );
253    if ($errmsg ne q()) {
254        htmlerror($errmsg);
255        croak($errmsg);
256    }
257
258    dumper(DBDEB, 'config', \%Config);
259    dumper(DBDEB, 'params', $params);
260    dumper(DBDEB, 'i18n', \%i18n);
261    dumper(DBDEB, 'labels', \%Labels);
262
263    scanhsdata();
264    #dumper(DBDEB, 'all host/service data', \%hsdata);
265    %authhosts = getserverlist( $cgi->remote_user() );
266    #dumper(DBDEB, 'data for ' . $cgi->remote_user(), \%authhosts);
267
268    return $cgi, $params;
269}
270
271# If logging is enabled, make sure we can write to the log file.
272# Attempt to write to the log file.  If that fails, write to STDERR.
273# CGI scripts will typically fail to write to the log file (unless
274# the web server user has write permissions on it), so output will
275# go to the web server logs.
276sub initlog {
277    my ($app, $logfn) = @_;
278    if (defined $Config{'debug_' . $app}) {
279        $Config{debug} = $Config{'debug_' . $app};
280    }
281    if (! $logfn) {
282        $logfn = defined $Config{logfile} ? $Config{logfile} : q();
283    }
284    if ($Config{debug} > 0) {
285        if (not open $LOG, '>>', $logfn) { ## no critic (RequireBriefOpen)
286            open $LOG, '>&=STDERR' or ## no critic (RequireBriefOpen)
287                croak('Cannot log to file or STDERR');
288            debug(DBCRT, "Cannot write to '$logfn', using STDERR instead");
289        }
290    }
291    return;
292}
293
294# we must have a type (the CGI script that is being invoked).  we may or may
295# not have a host and/or service.
296sub getdebug {
297    my ($type, $host, $service) = @_;
298    if (not defined $type) {
299        debug(DBWRN, 'no type defined, enabling debug');
300        $Config{debug} = DBDEB;
301        return;
302    }
303
304    if (not $host) { $host = q(); }
305    if (not $service) { $service = q(); }
306
307    # All this allows debugging one service, or one host,
308    # or one service on one host, for each line of input.
309    my $key = 'debug_' . $type;
310    my $hkey = 'debug_' . $type . '_host';
311    my $skey = 'debug_' . $type . '_service';
312    if (defined $Config{$key}) {
313        if (defined $Config{$hkey}) {
314            if ($Config{$hkey} eq $host) {
315                if (defined $Config{$skey}) {
316                    if ($Config{$skey} eq $service) {
317                        $Config{debug} = $Config{$key};
318                    } else {
319                        $Config{debug} = 0;
320                    }
321                } else {
322                    $Config{debug} = $Config{$key};
323                }
324            } else {
325                $Config{debug} = 0;
326            }
327        } elsif (defined $Config{$skey}) {
328            if ($Config{$skey} eq $service) {
329                $Config{debug} = $Config{$key};
330            } else {
331                $Config{debug} = 0;
332            }
333        } else {
334            $Config{debug} = $Config{$key};
335        }
336    }
337
338    if (defined $Config{$key}) {
339        debug(DBDEB, "getdebug $key = $Config{$key}");
340    }
341    if (defined $Config{$hkey}) {
342        debug(DBDEB, "getdebug $hkey = $Config{$hkey}");
343    }
344    if (defined $Config{$skey}) {
345        debug(DBDEB, "getdebug $skey = $Config{$skey}");
346    }
347
348    return;
349}
350
351# HTTP support ################################################################
352# get parameters from CGI
353#
354# these are the CGI arguments that we understand:
355#
356# host=host_name (from nagios configuration)
357# service=service_description (from nagios configuration)
358# db=db[,ds[,ds[...]]] (may be comma-delimited or specified multiple times)
359# geom=WxH
360# rrdopts=
361# offset=seconds
362# period=(hour,day,week,month,quarter,year)
363# graphonly
364# showgraphtitle
365# hidelegend
366# fixedscale
367# showtitle
368# showdesc
369# expand_controls
370# expand_period=(hour,day,week,month,quarter,year)
371#
372sub getparams {
373    my $cgi = new CGI;  ## no critic (ProhibitIndirectSyntax)
374    $cgi->autoEscape(0);
375    my %rval;
376
377    # these flags are either string or array
378    for my $ii (qw(host service db label group geom rrdopts offset period expand_period)) {
379        if ($cgi->param($ii)) {
380            if (ref($cgi->param($ii)) eq 'ARRAY') {
381                my @rval = $cgi->param($ii);
382                $rval{$ii} = \@rval;
383            } elsif ($ii eq 'db' || $ii eq 'label') {
384                $rval{$ii} = [$cgi->multi_param($ii),];
385            } else {
386                $rval{$ii} = $cgi->param($ii);
387            }
388        } else {
389            $rval{$ii} = q();
390        }
391    }
392
393    # these flags are boolean.  if they exist, then consider it true.
394    for my $ii (qw(expand_controls fixedscale showgraphtitle showtitle showdesc graphonly hidelegend)) {
395        $rval{$ii} = q();
396        for my $jj ($cgi->param()) {
397            if ($jj eq $ii) {
398                $rval{$ii} = 1;
399                last;
400            }
401        }
402    }
403
404    if (not $rval{host}) { $rval{host} = q(); }
405    if (not $rval{service}) { $rval{service} = q(); }
406    if (not $rval{group}) { $rval{group} = q(); }
407    if (not $rval{db}) { $rval{db} = []; }
408    if (not $rval{label}) { $rval{label} = []; }
409
410    if ($rval{offset}) { $rval{offset} = int $rval{offset}; }
411    if (not $rval{offset} or $rval{offset} <= 0) { $rval{offset} = 0; }
412
413    return $cgi, \%rval;
414}
415
416# return two strings: period and expand_period.  each is a comma-delimited
417# list of day, week, month, quarter, year.  first try to get the value from
418# the parameters.  if that fails, use whatever is defined in config.
419#
420# CGI uses comma-delimited, old configs used space-delimited, so we deal with
421# either.  we ensure the result is comma-delimited.
422sub initperiods {
423    my ($context, $opts) = @_;
424    if ($context eq 'both') {
425        $context = 'all';
426    }
427
428    my $s = $opts->{period};
429    my $c = $Config{'time' . $context};
430    my $p = q();
431    if (defined $c && $c ne q()) { $p = $c; }
432    if (defined $s && $s ne q()) { $p = $s; }
433    $p =~ s/ /,/g; ## no critic (RegularExpressions)
434
435    $s = $opts->{expand_period};
436    $c = $Config{'expand_time' . $context};
437    my $ep = q();
438    if (defined $c && $c ne q()) { $ep = $c; }
439    if (defined $s && $s ne q()) { $ep = $s; }
440    $ep =~ s/ /,/g; ## no critic (RegularExpressions)
441
442    return ($p, $ep);
443}
444
445sub getstyle {
446    my @style;
447    if ($Config{stylesheet}) {
448        @style = (-style => {-src => "$Config{stylesheet}"});
449    }
450    return @style;
451}
452
453sub getrefresh {
454    my @refresh;
455    if ($Config{refresh}) {
456        @refresh = (-http_equiv => 'Refresh', -content => "$Config{refresh}");
457    }
458    return @refresh;
459}
460
461# configure parameters with something that we are sure will work.  grab values
462# from the supplied default object.  if there are any gaps, use values from the
463# configuration.
464sub cfgparams {
465    my($p, $dflt) = @_;
466
467    foreach my $ii (qw(expand_controls fixedscale showgraphtitle showtitle showdesc hidelegend graphonly)) {
468        if ($dflt->{$ii} ne q()) {
469            $p->{$ii} = $dflt->{$ii};
470        } elsif(defined $Config{$ii}) {
471            $p->{$ii} = $Config{$ii} eq 'true' ? 1 : 0;
472        } else {
473            $p->{$ii} = 0;
474        }
475    }
476
477    if ($dflt->{period} ne q()) {
478        $p->{period} = $dflt->{period};
479    }
480    if ($dflt->{expand_period} ne q()) {
481        $p->{expand_period} = $dflt->{expand_period};
482    }
483    if ($dflt->{geom} ne q()) {
484        $p->{geom} = $dflt->{geom};
485    }
486    $p->{offset} = $dflt->{offset} ne q() ? $dflt->{offset} : 0;
487
488    return;
489}
490
491sub arrayorstring {
492    my ($opts, $param) = @_;
493    #dumper(DBDEB, "arrayorstring param=$param opts", $opts);
494    my $rval = q();
495    if (exists $opts->{$param} and $opts->{$param}) {
496        if (ref($opts->{$param}) eq 'ARRAY') {
497            for my $ii (@{$opts->{$param}}) {
498                next if not defined $ii;
499                $rval .= "&$param=" . escape($ii);
500            }
501        } else {
502            $rval .= "&$param=" . escape($opts->{$param});
503        }
504    }
505    return $rval;
506}
507
508sub buildurl {
509    my ($host, $service, $opts) = @_;
510    if (not $host or not $service) {
511        return q();
512    }
513    debug(DBDEB, "buildurl($host, $service)");
514    dumper(DBDEB, 'buildurl: opts', $opts);
515    my $url = join q(&), 'host=' . $host, 'service=' . $service;
516    $url .= arrayorstring($opts, 'db');
517    $url .= arrayorstring($opts, 'geom');
518    if (exists $opts->{fixedscale} and $opts->{fixedscale}) {
519        $url .= '&fixedscale';
520    }
521    $url .= arrayorstring($opts, 'rrdopts');
522    debug(DBDEB, "buildurl: returning $url");
523    return $url;
524}
525
526# construct the filename to RRD data file.  this requires at least a valid
527# host and service to work.
528sub mkfilename {
529    my ($host, $service, $db) = @_;
530    if (not $host or not $service) {
531        debug(DBWRN, 'cannot construct filename: missing host or service');
532        return 'BOGUSDIR', 'BOGUSFILE';
533    }
534    $db ||= q();
535    my $directory = $Config{rrddir};
536    my $filename = q();
537    if (defined $Config{dbseparator} && $Config{dbseparator} eq 'subdir') {
538        $directory .=  q(/) . $host;
539        if ($db) {
540            $filename = escape("${service}___${db}") . RRDEXT;
541        } else {
542            $filename = escape("${service}___");
543        }
544    } else {
545        # Build filename for traditional separation
546        if ($db) {
547            $filename = escape("${host}_${service}_${db}") . RRDEXT;
548        } else {
549            $filename = escape("${host}_${service}_");
550        }
551    }
552    return $directory, $filename;
553}
554
555# this is completely self-contained so that it can be called no matter what
556# error we encounter.  stylesheet is hard-coded so no dependencies.
557sub htmlerror {
558    my ($msg) = @_;
559    my $cgi = new CGI; ## no critic (ProhibitIndirectSyntax)
560    print $cgi->header(-type => 'text/html', -expires => 0) .
561        $cgi->start_html(-id => 'nagiosgraph',
562                         -title => 'NagiosGraph Error',
563                         -head => $cgi->style({-type=>'text/css'},
564                                              '.error {' . ERRSTYLE . '}')) .
565        $cgi->div( { -class => 'error' }, $msg ) . "\n" .
566        $cgi->end_html() or
567        debug(DBCRT, "could not write to STDOUT: $OS_ERROR");
568    return;
569}
570
571sub imgerror {
572    my ($cgi, $msg) = @_;
573    $OUTPUT_AUTOFLUSH = 1;
574    print $cgi->header(-type => 'image/png', -charset => 'ISO-8859-1') .
575        ( defined $msg && $msg ne q() ? getimg($msg) : decode_base64(IMG))
576        or debug(DBCRT, "could not write to STDOUT: $OS_ERROR");
577    return;
578}
579
580# emit a png image with the message in it.  only works if GD is available.
581# if no GD, just return a small blank image.
582sub getimg {
583    my ($msg) = @_;
584    debug(DBDEB, "getimg($msg)");
585    my $rval = eval { require GD; };
586    if (defined $rval && $rval == 1) {
587        my @lines = split /\n/, $msg;
588        my $pad = 4;
589        my $maxw = 600;
590        my $maxh = 15;
591        my $width = 2 * $pad + $maxw;
592        my $height = 2 * $pad + $maxh * scalar @lines;
593        my $img = GD::Image->new($width, $height);
594        my $wht = $img->colorAllocate(255, 255, 255);
595        my $fg = $img->colorAllocate($IMG_FG_COLOR[0],
596                                     $IMG_FG_COLOR[1],
597                                     $IMG_FG_COLOR[2]);
598        $img->transparent($wht);
599        $img->rectangle(2,2,$width-3,$height-3,$wht);
600        my $y = $pad;
601        foreach my $line (@lines) {
602            $img->string(GD->gdSmallFont,$pad,$y,"$line",$fg);
603            $y += $maxh;
604        }
605        return $img->png;
606    }
607    return decode_base64(IMG);
608}
609
610# Color subroutines ###########################################################
611# Choose a color for service
612sub hashcolor {
613    my $label = shift;
614    my $color = shift;
615    $color ||= $Config{colorscheme};
616    debug(DBDEB, "hashcolor($color)");
617
618    # color 9 is user defined (or the default rainbow if nothing userdefined).
619    if ($color == 9) {
620        # Wrap around, if we have more values than given colors
621        $colorsub++;
622        if ($colorsub >= scalar @{$Config{colors}}) { $colorsub = 0; }
623        debug(DBDEB, 'hashcolor: returning color = ' . $Config{colors}[$colorsub]);
624        return $Config{colors}[$colorsub];
625    }
626
627    my $h = vec md5($label), $color-1, 8;
628    my $s = $Config{colorsaturation} || COLORSATURATION;
629    my $v = $Config{colorvalue} || COLORVALUE;
630    $h = $h/255;
631    my ($r, $g, $b) = hsv2rgb($h, $s, $v);
632    # generate the hex color value
633    $color = sprintf '%02X%02X%02X', $r, $g, $b;
634    debug(DBDEB, "hashcolor: returning color = $color");
635    return $color;
636}
637
638# Accepts a list of HSV values from 0 to 1 and returns RGB values from 0 to 255
639# Based on algorithm from http://www.cs.rit.edu/~ncs/color/t_convert.html
640sub hsv2rgb {
641    my ($h, $s, $v) = @_;
642    my ($r, $g, $bb) = $v; # achromatic (grey)
643
644    if ($s != 0) {
645        my $h_i = int $h * 6;
646        my $f = ($h * 6) - $h_i;
647
648        my $x = $v * (1 - $s);
649        my $y = $v * (1 - $s * $f);
650        my $z = $v * (1 - $s * (1 - $f));
651
652        ($r, $g, $bb) = ($v, $z, $x) if $h_i == 0;
653        ($r, $g, $bb) = ($y, $v, $x) if $h_i == 1;
654        ($r, $g, $bb) = ($x, $v, $z) if $h_i == 2;
655        ($r, $g, $bb) = ($x, $y, $v) if $h_i == 3;
656        ($r, $g, $bb) = ($z, $x, $v) if $h_i == 4;
657        ($r, $g, $bb) = ($v, $x, $y) if $h_i == 5;
658    }
659
660    return int $r*256, int $g*256, int $bb*256;
661}
662
663# Configuration subroutines ###################################################
664# parse string values and store them as a data structure
665sub listtodict {
666    my ($val, $sep, $commasplit) = @_;
667    $sep ||= q(,);
668    $commasplit ||= 0;
669    #debug(DBDEB, "listtodict($val, $sep, $commasplit)");
670    my (%rval);
671    $Config{$val} ||= q();
672    if (ref $Config{$val} eq 'HASH') {
673        #debug(DBDEB, 'listtodict: returning existing hash');
674        return $Config{$val};
675    }
676    $Config{$val . 'sep'} ||= $sep;
677    #debug(DBDEB, 'listtodict: splitting "' . $Config{$val} . '" on "' . $Config{$val . 'sep'} . q(")); # "
678    foreach my $ii (split $Config{$val . 'sep'}, $Config{$val}) {
679        if ($val eq 'hostservvar') {
680            my @data = split /,/, $ii;
681            #dumper(DBDEB, 'listtodict: hostservvar data', \@data);
682            if (defined $rval{$data[0]}) {
683                if (defined $rval{$data[0]}->{$data[1]}) {
684                    $rval{$data[0]}->{$data[1]}->{$data[2]} = 1;
685                } else {
686                    $rval{$data[0]}->{$data[1]} = {$data[2] => 1};
687                }
688            } else {
689                $rval{$data[0]} = {$data[1] => {$data[2] => 1}};
690            }
691        } elsif ($commasplit) {
692            my @data = split /,/, $ii;
693            #dumper(DBDEB, 'listtodict: commasplit data', \@data);
694            $rval{$data[0]} = $data[1];
695        } else {
696            $rval{$ii} = 1;
697        }
698    }
699    $Config{$val} = \%rval;
700    #dumper(DBDEB, 'listtodict: rval', $Config{$val});
701    return $Config{$val};
702}
703
704# FIXME: ensure no regexp breakage (do this when reading/validated conf)
705# return a list from the indicated string.
706# strip any leading and trailing spaces from each element.
707sub str2list {
708    my ($str, $delim) = @_;
709    $str ||= q();
710    $delim ||= q(;);
711    my @rval;
712    foreach my $i (split /$delim/, $str) {
713        $i =~ s/^\s+//g;
714        $i =~ s/\s+$//g;
715        if ($i ne q()) {
716            push @rval, $i;
717        }
718    }
719    return \@rval;
720}
721
722# Subroutine for checking that the directory with RRD file is not empty
723sub checkdirempty {
724    my $directory = shift;
725    if (not opendir DIR, $directory) {
726        debug(DBCRT, "cannot open directory $directory: $OS_ERROR");
727        return 0;
728    }
729    my @files = readdir DIR;
730    closedir DIR or debug(DBERR, "cannot close $directory: $OS_ERROR");
731    return (scalar @files > 2) ? 0 : 1;
732}
733
734# pass a debug value if you want to debug the initial config file parsing.
735# otherwise the debug level will be set by whatever is found in the config.
736sub readfile {
737    my ($filename, $hashref, $debug) = @_;
738    $debug ||= 0;
739    debug(DBDEB, "readfile($filename, $debug)");
740    if ($debug) { $Config{debug} = $debug; }
741    open my $FH, '<', $filename or ## no critic (RequireBriefOpen)
742        return "cannot open $filename: $OS_ERROR";
743    my $cfgdebug;
744    my ($key, $val);
745    while (<$FH>) {
746        next if /^\s*#/;        # skip commented lines
747        s/^\s+//;               # removes leading whitespace
748        /^([^=]+)\s*=\s*(.*)$/x and do { # splits into key=val pairs
749            $key = $1;
750            $val = $2;
751            $key =~ s/\s+$//;   # removes trailing whitespace
752            $val =~ s/\s+$//;   # removes trailing whitespace
753            if ($key eq 'debug') {
754                $cfgdebug = $val;
755            } else {
756                $hashref->{$key} = $val;
757            }
758        };
759    }
760    close $FH or return "close failed for $filename: $OS_ERROR";
761    if (defined $cfgdebug) {
762        $hashref->{debug} = $cfgdebug;
763    }
764    return q();
765}
766
767# check status of the rrd directory.  this expects either 'write' or 'read'.
768sub checkrrddir {
769    my ($rrdstate) = @_;
770    my $errmsg = q();
771    if ($rrdstate eq 'write') {
772        # Make sure rrddir exists and is writable
773        if (not -d $Config{rrddir}) {
774            debug(DBINF, "creating directory $Config{rrddir}");
775            my $err;
776            mkpath($Config{rrddir}, {error => \$err});
777            if ($err && @{$err}) {
778                $errmsg =
779                    "Cannot create rrd directory $Config{rrddir}: $OS_ERROR";
780            }
781        } elsif (not -w $Config{rrddir}) {
782            $errmsg = "Cannot write to rrd directory $Config{rrddir}";
783        }
784    } else {
785        # Make sure rrddir is readable and not empty
786        if (! -r $Config{rrddir} ) {
787            $errmsg = "Cannot read rrd directory $Config{rrddir}";
788        } elsif (checkdirempty($Config{rrddir})) {
789            $errmsg = "No data in rrd directory $Config{rrddir}";
790        }
791    }
792    if ($errmsg ne q()) { debug(DBCRT, $errmsg); }
793    return $errmsg;
794}
795
796# read the config file.  get the log initialized as soon as possible.
797# convert any deprecated variables to new variables and/or syntax.
798# ensure sane default values for everything, even if not specified.
799sub readconfig {
800    my ($app, $logid, $cfgfn) = @_;
801    if (! $logid) { $logid = 'logfile'; }
802    if (! $cfgfn) { $cfgfn = $INC[0] . q(/) . $CFGNAME; }
803
804    my $debug = 0; # set this higher to debug config file parsing
805    my $errstr = readfile($cfgfn, \%Config, $debug);
806    if ($errstr ne q()) { return $errstr; }
807
808    initlog($app, $Config{$logid});
809
810    convertdeprecated(\%Config);
811
812    # now initialize structures and configure defaults
813
814    $Config{rrdoptshash}{global} =
815        defined $Config{rrdopts} ? $Config{rrdopts} : q();
816
817    foreach my $ii ('withmaximums', 'withminimums',
818                    'altautoscale', 'nogridfit', 'logarithmic') {
819        listtodict($ii, q(,));
820    }
821    foreach my $ii ('hostservvar') {
822        listtodict($ii, q(;));
823    }
824    foreach my $ii ('altautoscalemax', 'altautoscalemin') {
825        listtodict($ii, q(;), 1);
826    }
827    foreach my $ii ('plotasLINE1', 'plotasLINE2', 'plotasLINE3', 'plotasAREA',
828                    'plotasTICK', 'stack', 'negate', 'lineformat',
829                    'maximums', 'minimums', 'lasts', 'fixedscale') {
830        if ($Config{$ii}) {
831            $Config{$ii . 'list'} =
832                str2list($Config{$ii}, $Config{$ii} =~ /;/ ? q(;) : q(,));
833        }
834    }
835    foreach my $ii ('heartbeats', 'stepsizes', 'resolutions', 'steps', 'xffs'){
836        if (defined $Config{$ii}) {
837            my $key = $ii;
838            chop $key;
839            $Config{$key . 'list'} = str2list($Config{$ii});
840        }
841    }
842
843    # set these only if they have not been specified in the config file
844    foreach my $ii (['timeall', 'day week month'],
845                    ['timehost', 'day'],
846                    ['timeservice', 'day'],
847                    ['timegroup', 'day'],
848                    ['expand_timeall', 'day week month'],
849                    ['expand_timehost', 'day'],
850                    ['expand_timeservice', 'day'],
851                    ['expand_timegroup', 'day'],
852                    ['geometries', GEOMETRIES],
853                    ['colorscheme', COLORSCHEME],
854                    ['colors', COLORS],
855                    ['colormax', COLORMAX],
856                    ['colormin', COLORMIN],
857                    ['resolution', RESOLUTIONS],
858                    ['step', STEPS],
859                    ['xff', XFF],
860                    ['heartbeat', HEARTBEAT],
861                    ['stepsize', STEPSIZE],) {
862        if (not $Config{$ii->[0]}) { $Config{$ii->[0]} = $ii->[1]; }
863    }
864    $Config{colors} = [split /\s*,\s*/, $Config{colors}];
865
866    return q();
867}
868
869# process the configuration variables and convert anything in old format to
870# the newest format.  this is to maintain backward compatibility with older
871# configuration files.
872sub convertdeprecated {
873    my ($cfg) = @_;
874
875    # lineformat=warn,LINE1,FFFFFF  ->  lineformat=warn=LINE1,FFFFFF
876    if ( defined $cfg->{lineformat} && $cfg->{lineformat} !~ /=/ ) {
877        my $v = q();
878        foreach my $tuple (split /;/, $cfg->{lineformat}) {
879            my $lhs = q();
880            my $rhs = q();
881            foreach my $x (split /,/, $tuple) {
882                if ($x eq 'LINE1' || $x eq 'LINE2' ||
883                    $x eq 'LINE3' || $x eq 'AREA' ||
884                    $x eq 'TICK' || $x eq 'STACK' ||
885                    $x =~ /[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]+/) {
886                    if ($rhs ne q()) {
887                        $rhs .= q(,);
888                    }
889                    $rhs .= $x;
890                } else {
891                    if ($lhs ne q()) {
892                        $lhs .= q(,);
893                    }
894                    $lhs .= $x;
895                }
896            }
897            if ($v ne q()) {
898                $v .= q(;);
899            }
900            $v .= $lhs . q(=) . $rhs;
901        }
902        $cfg->{lineformat} = $v;
903    }
904
905    return;
906}
907
908sub readrrdoptsfile {
909    if ( defined $Config{rrdoptsfile} ) {
910        my $errstr = readfile(getcfgfn($Config{rrdoptsfile}),
911                              $Config{rrdoptshash});
912        if ($errstr ne q()) {
913            return $errstr;
914        }
915    }
916    return q();
917}
918
919sub loadperms {
920    my ($user) = @_;
921
922    if ( defined $Config{authzmethod} ) {
923        if ( $Config{authzmethod} eq 'nagios3' ) {
924            return readnagiosperms( $user );
925        } elsif ( $Config{authzmethod} eq 'nagiosgraph' ) {
926            return readpermsfile( $user );
927        } else {
928            return "unknown authzmethod '$Config{authzmethod}'";
929        }
930    }
931    return q();
932}
933
934# TODO: respect contacts, not just all host/services
935# read the nagios permissions configuration.  this would be a lot easier if
936# there were an api.  instead we have to read the config files and basically
937# reverse engineer the nagios behavior.
938sub readnagiosperms {
939    my ($user) = @_;
940
941    undef %authz;
942    $authz{default_host_access}{default_service_access} = 0;
943    if ( not defined $Config{authzfile} or $Config{authzfile} eq q() ) {
944        return 'authzfile is not defined';
945    }
946    my $fn = $Config{authzfile};
947    my $authenabled = 1;  # nagios defaults to use authentication
948    my $host_users = q();
949    my $serv_users = q();
950    my $default_user = q();
951    open my $FH, '<', $fn or ## no critic (RequireBriefOpen)
952        return "cannot open nagios config $fn: $OS_ERROR";
953    while (<$FH>) {
954        my $line = $_;
955        $line =~ s/\s//g;
956        if ( $line =~ /^authorized_for_all_hosts\s*=\s*(.*)/ ) {
957            $host_users = $1;
958        } elsif ( $line =~ /^authorized_for_all_services\s*=\s*(.*)/ ) {
959            $serv_users = $1;
960        } elsif ( $line =~ /^default_user_name\s*=\s*(.*)/ ) {
961            $default_user = $1;
962        } elsif ( $line =~ /^use_authentication\s*=\s*([\d])/ ) {
963            $authenabled = $1;
964        }
965    }
966    close $FH or return "close failed for $fn: $OS_ERROR";
967
968    if ( $authenabled == 0 ) {
969        undef %authz;
970        debug(DBINF, 'nagios authorization is disabled, full access granted');
971        return q();
972    }
973
974    # if there is no user but there is a nagios default user, use the default
975    if ( (! defined $user || $user eq q()) && $default_user ne q() ) {
976        $user = $default_user;
977    }
978
979    if ( not defined $user or $user eq q() ) {
980        debug(DBWRN, 'no discernable user, defaulting to no permissions');
981        return q();
982    }
983
984    foreach my $i (split /,/, $host_users) {
985        if ( $user eq $i ) {
986            $authz{default_host_access}{default_service_access} = 1;
987            last;
988        }
989    }
990    foreach my $i (split /,/, $serv_users) {
991        if ( $user eq $i ) {
992            $authz{default_host_access}{default_service_access} = 1;
993            last;
994        }
995    }
996
997    return q();
998}
999
1000# read the authz file.  we load permissions only for the indicated user (no
1001# need to know permissions for anyone else).  if no authzfile is specified,
1002# do not apply access control rules.  if no user is specified, then lockdown.
1003sub readpermsfile {
1004    my ($user) = @_;
1005
1006    # defining authz enables enforcement of access controls.
1007    # default to no permissions.
1008    undef %authz;
1009    $authz{default_host_access}{default_service_access} = 0;
1010    if ( not defined $user or $user eq q() ) {
1011        debug(DBWRN, 'no discernable user, defaulting to no permissions');
1012        return q();
1013    }
1014    if ( not defined $Config{authzfile} or $Config{authzfile} eq q() ) {
1015        return 'authzfile is not defined';
1016    }
1017    my $fn = getcfgfn($Config{authzfile});
1018    open my $FH, '<', $fn or ## no critic (RequireBriefOpen)
1019        return "cannot open access control file $fn: $OS_ERROR";
1020    my $lineno = 0;
1021    while (<$FH>) {
1022        $lineno += 1;
1023        next if /^\s*#/;        # skip commented lines
1024        s/^\s+//;               # removes leading whitespace
1025        if ( /^([^=]+)\s*=\s*(.*)$/x ) {
1026            my $n = $1;
1027            my $v = $2;
1028            $n =~ s/\s+$//;
1029            $v = scrubuserlist($v);
1030            if (checkuserlist($v)) {
1031                debug(DBWRN, "authzfile: bad userlist '$v' (line $lineno)");
1032                next;
1033            }
1034            my ($h,$s) = split /,/, $n;
1035            $h =~ s/\s+//g;
1036            if (not $h or $h eq q() or $h eq q(*)) {
1037                $h = 'default_host_access';
1038            }
1039            if (not $s or $s eq q() or $s eq q(*)) {
1040                $s = 'default_service_access';
1041            }
1042            my $p = getperms($user, $v);
1043            if (defined $p) {
1044                $authz{$h}{$s} = $p;
1045            }
1046        } else {
1047            debug(DBWRN, "authzfile: bad format (line $lineno)");
1048        }
1049    }
1050    close $FH or return "close failed for $fn: $OS_ERROR";
1051    return q();
1052}
1053
1054sub scrubuserlist {
1055    my ($v) = @_;
1056    $v =~ s/\s+//g;      # remove all spaces from userlist
1057    return $v;
1058}
1059
1060sub checkuserlist {
1061    my ($v) = @_;
1062    if ( $v =~ /[^!a-zA-Z0-9_\.\*-,]/ ) {
1063        return 1;
1064    }
1065    return 0;
1066}
1067
1068# do glob matching.  wrap it in an eval to ensure no failures.
1069# return 1 if user matches positive, 0 if matches negative, undef if no match.
1070# consider bad pattern a rejection.
1071sub getperms {
1072    my ($user, $str) = @_;
1073    if ($str eq q()) { return 0; }
1074    my $match;
1075    foreach my $pattern (split /,/, $str) {
1076        $pattern =~ s/\./\\./g;
1077        $pattern =~ s/\*/\.\*/g;
1078        my $rval = eval {
1079            my $m = 1;
1080            if (substr($pattern, 0, 1) eq q(!)) {
1081                $pattern = substr $pattern, 1;
1082                $m = 0;
1083            }
1084            if ( $user =~ /^${pattern}$/ ) {
1085                return $m;
1086            }
1087            return;
1088        };
1089        if ($EVAL_ERROR) {
1090            debug(DBCRT, "bad regex pattern '$pattern'");
1091            return 0;
1092        }
1093        if (defined $rval) {
1094            $match = $rval;
1095        }
1096    }
1097    return $match;
1098}
1099
1100# determine whether the user can view the indicated host and service.
1101# the format for the authz structure is:
1102#
1103# authz = { * => { * => 0, service9 => 1 },
1104#           host0 => { * => 1, service1 => 0 },
1105#           host1 => { service0 => 0, service3 => 0 },
1106#           host2 => { service0 => 1, service1 => 0 },
1107#         };
1108#
1109sub havepermission {
1110    my ($host, $service) = @_;
1111    if ( not %authz ) {
1112        return 1;
1113    }
1114    my $ok = 0;
1115    if ( defined $authz{default_host_access}{default_service_access} ) {
1116        $ok = $authz{default_host_access}{default_service_access};
1117        if ( defined $service
1118             and defined $authz{default_host_access}{$service} ) {
1119            $ok = $authz{default_host_access}{$service};
1120        }
1121    }
1122    if ( defined $host and defined $authz{$host} ) {
1123        if ( defined $authz{$host}{default_service_access} ) {
1124            $ok = $authz{$host}{default_service_access};
1125        }
1126        if ( defined $service and defined $authz{$host}{$service} ) {
1127            $ok = $authz{$host}{$service};
1128        }
1129    }
1130    return $ok;
1131}
1132
1133sub readlabelsfile {
1134    if ( defined $Config{labelfile} ) {
1135        undef %Labels;
1136        my $errstr = readfile(getcfgfn($Config{labelfile}), \%Labels);
1137        if ($errstr ne q()) {
1138            return $errstr;
1139        }
1140    }
1141    return q();
1142}
1143
1144# get the i18n strings.  use the language we are given.  if there is none, use
1145# the language from the config file.  if there is none, use the environment.
1146# if that fails, warn.  if there is no file corresponding to the language,
1147# warn about it so someone can create a translation.  if someone defines a
1148# specialized en file, use it, but do not complain if we do not find en since
1149# that is what we fall back to.
1150sub readi18nfile {
1151    my ($lang) = @_;
1152    if ( ! $lang ) {
1153        $lang = $Config{language};
1154    }
1155    if ( ! $lang ) {
1156        ($lang) = ($ENV{HTTP_ACCEPT_LANGUAGE}
1157                   ? split /,/, $ENV{HTTP_ACCEPT_LANGUAGE} : q());
1158    }
1159    if ( $lang && $lang ne q()) {
1160        $lang =~ tr/-/_/;
1161        my $fn = getcfgfn( mki18nfilename( $lang ));
1162        if ( ! -f $fn  && $lang =~ /(..)_/ ) {
1163            $lang = $1;
1164            $fn = getcfgfn( mki18nfilename( $lang ));
1165        }
1166        if ( -f $fn ) {
1167            my $errstr = readfile( $fn, \%i18n );
1168            if ( $errstr ne q() ) {
1169                return $errstr;
1170            }
1171        } elsif ( substr($lang, 0, 2) ne q(en)) {
1172            return "No translations for '$lang' ($fn)";
1173        }
1174    } else {
1175        return 'Cannot determine language';
1176    }
1177    return q();
1178}
1179
1180sub mki18nfilename {
1181    my ($key) = @_;
1182    return 'nagiosgraph_' . $key . '.conf';
1183}
1184
1185sub parsedb {
1186    my ($line) = @_;
1187    $line =~ s/^&db=//;
1188    my @db = split /&db=/, $line;
1189    my %labels;
1190    for my $i (0 .. @db - 1) {
1191        if ($db[$i] =~ /([^&]+)&label=(.*)/) {
1192            $db[$i] = $1;
1193            $labels{$db[$i]} = $2;
1194        }
1195    }
1196    return \@db, \%labels;
1197}
1198
1199# return all databases for the indiated host-service pair
1200sub getdbs {
1201    my ($host, $service, $data) = @_;
1202    my @db;
1203    if ($data->{$host}{$service}) {
1204        @db = @{$data->{$host}{$service}};
1205    }
1206    return \@db;
1207}
1208
1209# return the subset of the specified databases for which we actually have data.
1210sub filterdb {
1211    my ($host, $service, $dblist, $data) = @_;
1212    my @actualdb;
1213    if ($data->{$host}{$service} && $dblist) {
1214        my @dbs = @{$data->{$host}{$service}};
1215        foreach my $x (@{$dblist}) {
1216            my $found = 0;
1217            my ($db,$ds) = split /,/, $x;
1218            for my $i (0 .. @dbs-1) {
1219                my @known = @{$dbs[$i]};
1220                if ($db eq $known[0]) {
1221                    if ($ds) {
1222                        for my $i (1 .. @known-1) {
1223                            if ($ds eq $known[$i]) {
1224                                push @actualdb, $x;
1225                                last;
1226                            }
1227                        }
1228                    } else {
1229                        push @actualdb, $x;
1230                    }
1231                }
1232            }
1233        }
1234    }
1235    return \@actualdb;
1236}
1237
1238# remove leading and trailing spaces.  there is no need to escape the strings
1239# in the config files, but we unescape just in case someone has done this.
1240# older distributions included escaped labels in the sample configs.
1241sub cleanline {
1242    my ($line) = @_;
1243    $line = unescape($line);
1244    $line =~ tr/+/ /;
1245    $line =~ s/^\s+//g;
1246    $line =~ s/\s+$//g;
1247    return $line;
1248}
1249
1250# Read hostdb file
1251#
1252# This returns a list of graph infos for the specified host based on the
1253# contents of the hostdb file.
1254#
1255# If there is no file defined or if the file contains no service lines,
1256# return all services for which data exist for the indicated host.
1257#
1258# Services are defined with this format:
1259#
1260#   service=name[&db=db[,ds][&label=text][&db=db[,ds][&label=text][...]]]
1261#
1262sub readhostdb {
1263    my ($host) = @_;
1264    $host ||= q();
1265    if ($host eq q() || $host eq q(-)) { return (); }
1266
1267    debug(DBDEB, "readhostdb($host)");
1268
1269    my $usedefaults = 1;
1270    my @ginfo;
1271    if (defined $Config{hostdb}) {
1272        my $fn = getcfgfn($Config{hostdb});
1273        if (open my $DB, '<', $fn) { ## no critic (RequireBriefOpen)
1274            my $lineno = 0;
1275            while (my $line = <$DB>) {
1276                chomp $line;
1277                $lineno += 1;
1278                next if $line =~ /^\s*#/;        # skip commented lines
1279                $line = cleanline($line);
1280                my $service = q();
1281                my $label = q();
1282                if ( $line =~ s/^service\s*=\s*([^&]+)// ) {
1283                    $service = $1;
1284                    if ($line =~ s/^&label=([^&]+)//) {
1285                        $label = $1;
1286                    }
1287                }
1288                if ( ! $service ) {
1289                    if ( $line =~ /\S+/ ) {
1290                        debug(DBWRN, "hostdb: bad format (line $lineno)");
1291                    }
1292                    next;
1293                }
1294                $usedefaults = 0;
1295                my ($db, $dblabel);
1296                if ($line ne q()) {
1297                    ($db, $dblabel) = parsedb($line);
1298                    $db = filterdb($host, $service, $db, $authhosts{hostserv});
1299                    next if scalar @{$db} == 0;
1300                } else {
1301                    # find out if there are data for this host-service, but
1302                    # do not specify the databases explicitly.
1303                    my $x = getdbs($host, $service, \%hsdata);
1304                    next if scalar @{$x} == 0;
1305                    $db = [];
1306                    $dblabel = [];
1307                }
1308                my %info;
1309                $info{host} = $host;
1310                $info{service} = $service;
1311                if ($label ne q())  { $info{service_label} = $label; }
1312                $info{db} = $db;
1313                $info{db_label} = $dblabel;
1314                push @ginfo, \%info;
1315                debug(DBDEB, "readhostdb: match for $host $service $line");
1316            }
1317            close $DB or debug(DBERR, "close failed for $fn: $OS_ERROR");
1318        } else {
1319            my $msg = "cannot open hostdb $fn: $OS_ERROR";
1320            debug(DBERR, $msg);
1321            htmlerror($msg);
1322            die $msg; ## no critic (RequireCarping)
1323        }
1324    } else {
1325        debug(DBINF, 'no hostdb file has been specified');
1326    }
1327
1328    if ($usedefaults) {
1329        debug(DBDEB, 'readhostdb: using defaults');
1330        my $defaultds = readdatasetdb();
1331        my @services = sortnaturally(keys %{$hsdata{$host}});
1332        foreach my $service (@services) {
1333            my %info;
1334            $info{host} = $host;
1335            $info{service} = $service;
1336            if ($defaultds && $defaultds->{$service}) {
1337                $info{db} = $defaultds->{$service};
1338            } else {
1339                $info{db} = \@{$hsdata{$host}{$service}};
1340            }
1341            push @ginfo, \%info;
1342        }
1343    }
1344
1345    dumper(DBDEB, 'readhostdb: graphinfos', \@ginfo);
1346    return \@ginfo;
1347}
1348
1349# Read the servdb file
1350#
1351# This returns a list of hosts that have data for the specified service and db.
1352#
1353# If there is no file defined or if the file contains no hosts,
1354# return all hosts for which data exist for the indicated service and db.
1355#
1356# Hosts are defined with this format:
1357#
1358#   host=name[,name1[,name2[...]]]
1359#
1360sub readservdb {
1361    my ($service, $dblist) = @_;
1362    $service ||= q();
1363    if ($service eq q() || $service eq q(-)) { return (); }
1364
1365    debug(DBDEB, "readservdb($service, " .
1366          ($dblist ? join ', ', @{$dblist} : q()) . ')');
1367
1368    my $usedefaults = 1;
1369    my @allhosts;
1370    my @validhosts;
1371    if (defined $Config{servdb}) {
1372        my $fn = getcfgfn($Config{servdb});
1373        if (open my $DB, '<', $fn) { ## no critic (RequireBriefOpen)
1374            my $lineno = 0;
1375            while (my $line = <$DB>) {
1376                chomp $line;
1377                $lineno += 1;
1378                next if $line =~ /^\s*#/;        # skip commented lines
1379                $line = cleanline($line);
1380                if ( $line =~ /^host\s*=\s*(.+)/ ) {
1381                    $usedefaults = 0;
1382                    push @allhosts, split /\s*,\s*/, $1;
1383                } elsif ( $line =~ /\S+/ ) {
1384                    debug(DBWRN, "servdb: bad format (line $lineno)");
1385                }
1386            }
1387            close $DB or debug(DBERR, "close failed for $fn: $OS_ERROR");
1388        } else {
1389            my $msg = "cannot open servdb $fn: $OS_ERROR";
1390            debug(DBERR, $msg);
1391            htmlerror($msg);
1392            die $msg; ## no critic (RequireCarping)
1393        }
1394
1395        # check to see if there is a valid database for the host/service
1396        foreach my $host (@allhosts) {
1397            if ($dblist) {
1398                my $db = filterdb($host,$service,$dblist,$authhosts{hostserv});
1399                if ($db && scalar @{$db} > 0) {
1400                    push @validhosts, $host;
1401                }
1402            } else {
1403                my $x = getdbs($host, $service, \%hsdata);
1404                if (scalar @{$x} > 0) {
1405                    push @validhosts, $host;
1406                }
1407            }
1408        }
1409    } else {
1410        debug(DBINF, 'no servdb file has been specified');
1411    }
1412
1413    if ($usedefaults) {
1414        debug(DBDEB, 'readservdb: using defaults');
1415        @allhosts = sortnaturally(keys %hsdata);
1416        foreach my $host (@allhosts) {
1417            if ($hsdata{$host}{$service}
1418                && scalar @{$hsdata{$host}{$service}} > 0) {
1419                push @validhosts, $host;
1420            }
1421        }
1422    }
1423
1424    dumper(DBDEB, 'readservdb: all hosts', \@allhosts);
1425    dumper(DBDEB, 'readservdb: validated hosts', \@validhosts);
1426    return \@validhosts;
1427}
1428
1429# Read the groupdb file
1430#
1431# This returns a list of graph infos for the specified group and a list
1432# of all group names.
1433#
1434# If there is a group configuration file, then use the contents of that file.
1435# If there is a nagios configuration file, the list of groups will be
1436# automatically generated from the service groups defined in the Nagios
1437# configuration. Automatic generation of groups requires a sufficiently
1438# recent Nagios::Config perl module.
1439#
1440# Groups are defined with this format:
1441#
1442#   groupname=host,service[&label=text][&db=db[,ds][&label=text][...]]
1443#
1444sub readgroupdb {
1445    my ($g) = @_;
1446    $g ||= q();
1447    debug(DBDEB, "readgroupdb($g)");
1448
1449    if ( ! defined $Config{groupcfgfile} &&
1450         ! defined $Config{groupdb} ) {
1451        my $msg = 'No group configuration file(s) specified.  To display Nagios service groups, specify the Nagios configuration file using the \'groupcfgfile\' directive.  To explicitly enumerate groups, specify them in a file referred to by the \'groupdb\' directive.';
1452        debug(DBERR, $msg);
1453        htmlerror($msg);
1454        die $msg; ## no critic (RequireCarping)
1455    }
1456
1457    my %gnames;
1458    my @ginfo;
1459    if (defined $Config{groupdb}) {
1460        my $fn = getcfgfn($Config{groupdb});
1461        if (open my $DB, '<', $fn) { ## no critic (RequireBriefOpen)
1462            my $lineno = 0;
1463            while (my $line = <$DB>) {
1464                chomp $line;
1465                $lineno += 1;
1466                next if $line =~ /^\s*#/;        # skip commented lines
1467                $line = cleanline($line);
1468                my $group = q();
1469                my $host = q();
1470                my $service = q();
1471                my $label = q();
1472                if ( $line =~ s/^([^=]+)\s*=\s*([^,]+)\s*,\s*([^&]+)// ) {
1473                    $group = $1;
1474                    $host = $2;
1475                    $service = $3;
1476                    if ($line =~ s/^&label=([^&]+)//) {
1477                        $label = $1;
1478                    }
1479                }
1480                if ( ! $group || ! $host || ! $service ) {
1481                    if ( $line =~ /\S+/ ) {
1482                        debug(DBWRN, "groupdb: bad format (line $lineno)");
1483                    }
1484                    next;
1485                }
1486                $gnames{$group} = 1;
1487                next if $group ne $g;
1488                my ($db, $dblabel);
1489                if ($line ne q()) {
1490                    ($db, $dblabel) = parsedb($line);
1491                    $db = filterdb($host, $service, $db, $authhosts{hostserv});
1492                    next if scalar @{$db} == 0;
1493                } else {
1494                    # find out if there are data for this host-service, but
1495                    # do not specify the databases explicitly.
1496                    my $x = getdbs($host, $service, \%hsdata);
1497                    next if scalar @{$x} == 0;
1498                    $db = [];
1499                    $dblabel = [];
1500                }
1501                my %info;
1502                $info{host} = $host;
1503                $info{service} = $service;
1504                if ($label ne q())  { $info{service_label} = $label; }
1505                $info{db} = $db;
1506                $info{db_label} = $dblabel;
1507                push @ginfo, \%info;
1508                debug(DBDEB, "readgroupdb: match for $host $service $line");
1509            }
1510            close $DB or debug(DBERR, "close failed for $fn: $OS_ERROR");
1511        } else {
1512            my $msg = "cannot open groupdb $fn: $OS_ERROR";
1513            debug(DBERR, $msg);
1514            htmlerror($msg);
1515            die $msg; ## no critic (RequireCarping)
1516        }
1517    } else {
1518        debug(DBINF, 'no groupdb file has been specified');
1519    }
1520
1521    if (defined $Config{groupcfgfile}) {
1522        my $fn = $Config{groupcfgfile};
1523        if ( ! -f $fn ) {
1524            my $msg = "Cannot read nagios configuration file $fn";
1525            debug(DBERR, $msg);
1526            htmlerror($msg);
1527            die $msg; ## no critic (RequireCarping)
1528        }
1529        my $rval = eval { require Nagios::Config; };
1530        if (defined $rval && $rval == 1) {
1531            if ( Nagios::Config->VERSION >= NCONFIG_VERSION ) {
1532                debug(DBDEB, 'readgroupdb: using nagios service groups');
1533                my $cfg = Nagios::Config->new( Filename => $fn );
1534                my $objs = $cfg->all_objects_for_type('Nagios::ServiceGroup');
1535                foreach my $o (@{$objs}) {
1536                    my $n = $o->name ? $o->name : q();
1537                    my $a = $o->alias ? $o->alias : q();
1538                    debug(DBDEB, 'readgroupdb: ' . $n . ' (' . $a . ')');
1539                    my $group = $a ne q() ? $a : $n;
1540                    $gnames{$group} = 1;
1541                    next if $group ne $g;
1542
1543                    my $members = $o->members();
1544                    foreach my $m (@{$members}) {
1545                        my $h = $m->[0];
1546                        my $s = $m->[1];
1547                        my $hostn = $m->[0]->{host_name};
1548                        my $hosta = $m->[0]->{alias};
1549                        my $servn = $m->[1]->{service_description};
1550                        my $serva = $m->[1]->{display_name};
1551
1552                        my %info;
1553                        $info{host} = $hostn;
1554                        $info{service} = $servn;
1555                        $info{service_label} = $serva;
1556                        $info{db} = q();
1557                        $info{db_label} = q();
1558                        push @ginfo, \%info;
1559                        debug(DBDEB, "readgroupdb: match for $hostn $servn");
1560                    }
1561                }
1562            } else {
1563                my $msg = 'Incompatible version of Nagios::Object: found version ' . Nagios::Config->VERSION . ' but version ' . NCONFIG_VERSION . ' or higher is required.';
1564                debug(DBERR, $msg);
1565                htmlerror($msg);
1566                die $msg; ## no critic (RequireCarping)
1567            }
1568        } else {
1569            my $msg = 'Please install the perl module Nagios::Object to obtain groups from the Nagios configuration, or specify groups manually in the groupdb file.';
1570            debug(DBERR, $msg);
1571            htmlerror($msg);
1572            die $msg; ## no critic (RequireCarping)
1573        }
1574    }
1575
1576    my @gnames = sortnaturally(keys %gnames);
1577    dumper(DBDEB, 'groups', \@gnames);
1578    dumper(DBDEB, 'graphinfos', \@ginfo);
1579    return \@gnames, \@ginfo;
1580}
1581
1582# Default data for services are defined using lines with this format:
1583#
1584#   service=name&db=database[,ds-name][&db=database[,ds-name][...]]
1585#
1586# Data sets from the db file are used only if no data sets are specified as
1587# an argument to this subroutine.
1588sub readdatasetdb {
1589    if (! defined $Config{datasetdb} || $Config{datasetdb} eq q()) {
1590        my $msg = 'no datasetdb file has been specified';
1591        debug(DBDEB, $msg);
1592        my %rval;
1593        return \%rval;
1594    }
1595
1596    my %data;
1597    my $fn = getcfgfn($Config{datasetdb});
1598    if (open my $DB, '<', $fn) { ## no critic (RequireBriefOpen)
1599        my $lineno = 0;
1600        while (my $line = <$DB>) {
1601            chomp $line;
1602            $lineno += 1;
1603            next if $line =~ /^\s*#/;        # skip commented lines
1604            $line = cleanline($line);
1605            if ( $line =~ /^service\s*=\s*([^&]+)(.+)/ ) {
1606                my $service = $1;
1607                my $dbstr = $2;
1608                my ($db, $dblabel) = parsedb($dbstr);
1609                $data{$service} = $db;
1610                debug(DBDEB, 'readdatasetdb: match for ' . $line);
1611            } elsif ( $line =~ /\S+/ ) {
1612                debug(DBWRN, "datasetdb: bad format (line $lineno)");
1613            }
1614        }
1615        close $DB or debug(DBERR, "close failed for $fn: $OS_ERROR");
1616    } else {
1617        my $msg = "cannot open datasetdb $fn: $OS_ERROR";
1618        debug(DBERR, $msg);
1619        htmlerror($msg);
1620        die $msg; ## no critic (RequireCarping)
1621    }
1622
1623    dumper(DBDEB, 'readdatasetdb: data sets', \%data);
1624    return \%data;
1625}
1626
1627# Get list of matching rrd files
1628# unescape the filenames as we read in since they should be escaped on disk
1629sub dbfilelist {
1630    my ($host, $serv) = @_;
1631    my @files;
1632    debug(DBDEB, "dbfilelist($host, $serv)");
1633    if ($host ne q() && $host ne q(-) && $serv ne q() && $serv ne q(-)) {
1634        my ($directory, $filename) = mkfilename($host, $serv);
1635        debug(DBDEB, "dbfilelist: scanning $directory for $filename");
1636        if (opendir DH, $directory) {
1637            while (my $entry=readdir DH) {
1638                next if $entry =~ /^\./;
1639                if ($entry =~ /^${filename}(.+)\.rrd$/) {
1640                    push @files, unescape($1);
1641                }
1642            }
1643            closedir DH or debug(DBERR, "cannot close $directory: $OS_ERROR");
1644        } else {
1645            debug(DBERR, "cannot open directory $directory: $OS_ERROR");
1646        }
1647    }
1648    dumper(DBDEB, 'dbfilelist: files', \@files);
1649    return \@files;
1650}
1651
1652# Graphing routines ###########################################################
1653# Return a list of the data 'lines' in an rrd file
1654sub getdataitems {
1655    my ($file) = @_;
1656    my ($ds,                 # return value from RRDs::info
1657        %dupes);             # temporary hash to filter duplicate values with
1658    if (-f $file) {
1659        $ds = RRDs::info($file);
1660    } else {
1661        $ds = RRDs::info("$Config{rrddir}/$file");
1662    }
1663    my $ERR = RRDs::error();
1664    if ($ERR) {
1665        debug(DBERR, 'RRDs::info ERR ' . $ERR);
1666        dumper(DBERR, 'ds', $ds);
1667    }
1668    return grep { ! $dupes{$_}++ }          # filters duplicate data set names
1669        map { /ds\[(.*)\]/ and $1 }         # returns just the data set names
1670            grep { /ds\[(.*)\]/ } keys %{$ds}; # gets just the data set fields
1671}
1672
1673# Find graphs and values
1674sub graphinfo {
1675    my ($host, $service, $db) = @_;
1676    debug(DBDEB, "graphinfo: host=$host service=$service");
1677    dumper(DBDEB, 'graphinfo: db', $db);
1678
1679    my ($hs,                    # host/service
1680        @rrd,                    # the returned list of hashes
1681        $ds);
1682
1683    if (defined $Config{dbseparator} && $Config{dbseparator} eq 'subdir') {
1684        $hs = $host . q(/) . escape("$service") . q(___);
1685    } else {
1686        $hs = escape("${host}_${service}") . q(_);
1687    }
1688
1689    # Determine which files to read lines from
1690    if ($db && scalar @{$db} > 0) {
1691        my $nn = 0;
1692        for my $dd (@{$db}) {
1693            my ($dbname, @lines) = split /,/, $dd; # db filename, data sources
1694            $rrd[$nn]{file} = $hs . escape("$dbname") . RRDEXT;
1695            $rrd[$nn]{dbname} = $dbname;
1696            for my $ll (@lines) {
1697                my ($line, $unit) = split /~/, $ll;
1698                if ($unit) {
1699                    $rrd[$nn]{line}{$line}{unit} = $unit;
1700                } else {
1701                    $rrd[$nn]{line}{$line} = 1;
1702                }
1703            }
1704            $nn++;
1705        }
1706        debug(DBDEB, "graphinfo: Specified $hs db files in $Config{rrddir}: "
1707                     . join ', ', map { $_->{file} } @rrd);
1708    } else {
1709        @rrd = map {{ file=>$_ }}
1710                     map { "${hs}${_}.rrd" }
1711                     @{dbfilelist($host, $service)};
1712        debug(DBDEB, "graphinfo: Listing $hs db files in $Config{rrddir}: "
1713                     . join ', ', map { $_->{file} } @rrd);
1714    }
1715
1716    foreach my $rrd ( @rrd ) {
1717        if (not $rrd->{line}) {
1718            foreach my $ii (getdataitems($rrd->{file})) {
1719                $rrd->{line}{$ii} = 1;
1720            }
1721            debug(DBDEB, "graphinfo: DS $rrd->{file} lines: "
1722                  . join ', ', keys %{$rrd->{line}});
1723        }
1724        if (not $rrd->{dbname}) {
1725            if ($rrd->{file} =~ /___(.*).rrd/) {
1726                $rrd->{dbname} = unescape($1);
1727            } elsif ($rrd->{file} =~ /_(.*).rrd/) {
1728                $rrd->{dbname} = unescape($1);
1729            }
1730            debug(DBDEB, "graphinfo: DS $rrd->{file} dbname: "
1731                  . $rrd->{dbname});
1732        }
1733    }
1734
1735    dumper(DBDEB, 'graphinfo: rrd', \@rrd);
1736    return \@rrd;
1737}
1738
1739# return the first instance of a match for host, service, db, datasource
1740sub gethsddvalue { ## no critic (ProhibitManyArgs)
1741    my ($key, $dflt, $host, $service, $db, $ds) = @_;
1742    return gethsdd('DS', $key, $dflt, $host, $service, $db, $ds);
1743}
1744
1745# return the first instance of a match for the host, service, and database.
1746sub gethsdvalue {
1747    my ($key, $dflt, $host, $service, $db) = @_;
1748    return gethsdd('S', $key, $dflt, $host, $service, $db);
1749}
1750
1751# similar to gethsdvalue, but use the non-list key first if one is defined.
1752sub gethsdvalue2 {
1753    my ($key, $val, $host, $service, $db) = @_;
1754    my $x = $val;
1755    if ( defined $Config{$key} ) {
1756        $x = $Config{$key};
1757    }
1758    return gethsdd('S', $key, $x, $host, $service, $db);
1759}
1760
1761# return the first instance of a match for the host, service, database, and
1762# datasource.
1763sub gethsdd { ## no critic (ProhibitManyArgs)
1764    my ($pri, $key, $dflt, $host, $service, $db, $ds) = @_;
1765    my $value = $dflt;
1766    if ( defined $Config{$key . 'list'} ) {
1767        foreach my $item (@{$Config{$key . 'list'}}) {
1768            my ($p, $v);
1769            if ($item =~ /=/) {
1770                ($p,$v) = split /=/, $item;
1771            } else {
1772                ($p,$v) = ($item, 1);
1773            }
1774            if (hsddmatch($key, $p, $pri, $host, $service, $db, $ds)) {
1775                $value = $v;
1776                last;
1777            }
1778        }
1779    }
1780    return $value;
1781}
1782
1783# return 1 if we have a match, 0 otherwise.
1784# there are different matching patterns, depending on whether the priority is
1785# the datasource (ds) or the service (s).  the pattern matching expects four
1786# fields, so format the components depending on how many fields are in the
1787# match string.
1788#
1789# datasource
1790#                               datasource
1791#                      database,datasource
1792#              service,database,datasource
1793#         host,service,database,datasource
1794#
1795# service
1796#              service
1797#              service,database
1798#         host,service,database
1799#
1800sub hsddmatch { ## no critic (ProhibitManyArgs)
1801    my ($key, $str, $priority, $host, $service, $db, $ds) = @_;
1802    $host ||= q();
1803    $service ||= q();
1804    $db ||= q();
1805    $ds ||= q();
1806    my $count = $str =~ s/(,)/$1/g;
1807    my $tuple = 'BOGUS_PATTERN';
1808    if ($priority eq 'DS') {
1809        if ($count == 0) {
1810            $tuple = $ds;
1811        } elsif ($count == 1) {
1812            $tuple = "$db,$ds";
1813        } elsif ($count == 2) {
1814            $tuple = "$service,$db,$ds";
1815        } elsif ($count == 3) {
1816            $tuple = "$host,$service,$db,$ds";
1817        } else {
1818            debug(DBDEB, "in config '$key', bad pattern '$str': expecting 1 to 4 parts, found " . ($count+1));
1819        }
1820    } else {
1821        if ($count == 0) {
1822            $tuple = $service;
1823        } elsif ($count == 1) {
1824            $tuple = "$service,$db";
1825        } elsif ($count == 2) {
1826            $tuple = "$host,$service,$db";
1827        } else {
1828            debug(DBDEB, "in config '$key', bad pattern '$str': expecting 1 to 3 parts, found " . ($count+1));
1829        }
1830    }
1831
1832    return $tuple =~ /^${str}$/ ? 1 : 0;
1833}
1834
1835# FIXME: support old-style formatting of linestyle
1836sub getlineattr {
1837    my ($host,$service,$db,$ds) = @_;
1838    my $stack = gethsddvalue('stack', 0, $host, $service, $db, $ds) ? 1 : 0;
1839    my $linestyle = $Config{plotas};
1840    foreach my $ii (qw(LINE1 LINE2 LINE3 AREA TICK)) {
1841        if (gethsddvalue('plotas' . $ii, 0, $host, $service, $db, $ds)) {
1842            $linestyle = $ii;
1843            last;
1844        }
1845    }
1846    my $linecolor = q();
1847    if (defined $Config{lineformat}) {
1848        my $tuple = gethsddvalue('lineformat', q(), $host, $service, $db, $ds);
1849        if ($tuple ne q()) {
1850            my @values = split /,/, $tuple;
1851            foreach my $value (@values) {
1852                if ($value eq 'LINE1' || $value eq 'LINE2' ||
1853                    $value eq 'LINE3' || $value eq 'AREA' ||
1854                    $value eq 'TICK') {
1855                    $linestyle = $value;
1856                } elsif ($value =~ /[0-9a-fA-F][0-9a-fA-F][0-9a-fA-F]+/) {
1857                    $linecolor = $value;
1858                } elsif ($value eq 'STACK') {
1859                    $stack = 1;
1860                }
1861            }
1862        }
1863    }
1864    if ($linecolor eq q()) {
1865        $linecolor = hashcolor($ds);
1866    }
1867    return $linestyle, $linecolor, $stack;
1868}
1869
1870# the rrd vname can contain only A-Za-z0-9_- and must be no more than 255 long
1871sub mkvname {
1872    my ($dbname, $dsname) = @_;
1873    my $vname = $dbname . '_' . $dsname;
1874    $vname =~ s/[^A-Za-z0-9_-]/_/g;
1875    if (length $vname > 255) {
1876        $vname = substr $vname, 0, 255;
1877    }
1878    return $vname;
1879}
1880
1881# prepare a string for the rrd graph legend.  pad with trailing spaces.
1882# escape colons so they do not confuse rrdtool
1883sub mklegend {
1884    my ($s, $maxlen) = @_;
1885    $s =~ s/\\/\\\\/g;
1886    $s =~ s/:/\\:/g;
1887    return sprintf "%-${maxlen}s", $s;
1888}
1889
1890# TODO: enable per-host/service/db/ds formats
1891sub getformat {
1892    my ($host, $service, $db, $ds) = @_;
1893    return DEFAULT_FORMAT;
1894}
1895
1896sub getgeom {
1897    my ($config, $geom) = @_;
1898    my $w = GRAPHWIDTH;
1899    my $h = GRAPHHEIGHT;
1900    if ($geom && $geom ne DEFAULT) {
1901        ($w, $h) = split /x/, $geom;
1902    } elsif (defined $config->{default_geometry}) {
1903        ($w, $h) = split /x/, $config->{default_geometry};
1904    }
1905    return ($w, $h);
1906}
1907
1908sub setlabels { ## no critic (ProhibitManyArgs)
1909    my ($host, $serv, $dbname, $dsname, $file, $label, $maxlen) = @_;
1910    debug(DBDEB, "setlabels($host, $serv, $dbname, $dsname, $file, $maxlen)");
1911    my @ds;
1912    my $id = mkvname($dbname, $dsname);
1913    my $legend = mklegend($label, $maxlen);
1914    my ($linestyle, $linecolor, $stack) =
1915        getlineattr($host, $serv, $dbname, $dsname);
1916    my $sdef = $stack ? ':STACK' : q();
1917    if (gethsdvalue('maximums', 0, $host, $serv, $dbname)) {
1918        push @ds, "DEF:$id=$file:$dsname:MAX"
1919                , "CDEF:ceil$id=$id,CEIL"
1920                , "$linestyle:${id}#$linecolor:$legend$sdef";
1921    } elsif (gethsdvalue('minimums', 0, $host, $serv, $dbname)) {
1922        push @ds, "DEF:$id=$file:$dsname:MIN"
1923                , "CDEF:floor$id=$id,FLOOR"
1924                , "$linestyle:${id}#$linecolor:$legend$sdef";
1925    } else {
1926        my $t = gethsdvalue('lasts', 0, $host, $serv, $dbname) ?
1927            'LAST' : 'AVERAGE';
1928        push @ds, "DEF:${id}=$file:$dsname:$t";
1929        if (gethsddvalue('negate', 0, $host, $serv, $dbname, $dsname)) {
1930            push @ds, "CDEF:${id}_neg=${id},-1,*"
1931                    , "$linestyle:${id}_neg#$linecolor:$legend$sdef";
1932        } else {
1933            push @ds, "$linestyle:${id}#$linecolor:$legend$sdef";
1934        }
1935    }
1936    return @ds;
1937}
1938
1939sub setdata { ## no critic (ProhibitManyArgs)
1940    my ($serv, $dbname, $dsname, $file, $dur, $fmt) = @_;
1941    my $format = defined $fmt && $fmt ne q() ? $fmt : DEFAULT_FORMAT;
1942    debug(DBDEB, "setdata($serv, $dbname, $dsname, $file, $dur, $format)");
1943    my @ds;
1944    my $id = mkvname($dbname, $dsname);
1945    if ($dur > 120_000) { # long enough to start getting summation
1946        if (defined $Config{withmaximums}->{$serv}) {
1947            my $maxcolor = (defined $Config{colormax}
1948                            ? $Config{colormax} : COLORMAX);
1949            push @ds, "DEF:${id}_max=${file}_max:$dsname:MAX"
1950                    , "LINE1:${id}_max#${maxcolor}:" . _('maximum');
1951        }
1952        if (defined $Config{withminimums}->{$serv}) {
1953            my $mincolor = (defined $Config{colormin}
1954                            ? $Config{colormin} : COLORMIN);
1955            push @ds, "DEF:${id}_min=${file}_min:$dsname:MIN"
1956                    , "LINE1:${id}_min#${mincolor}:" . _('minimum');
1957        }
1958        if (defined $Config{withmaximums}->{$serv}) {
1959            push @ds, "CDEF:${id}_maxif=${id}_max,UN"
1960                    , "CDEF:${id}_maxi=${id}_maxif,${id},${id}_max,IF"
1961                    , "GPRINT:${id}_maxi:MAX:Max\\:$format";
1962        } else {
1963            push @ds, "GPRINT:$id:MAX:Max\\:$format";
1964        }
1965        push @ds, "GPRINT:$id:AVERAGE:Avg\\:$format";
1966        if (defined $Config{withminimums}->{$serv}) {
1967            push @ds, "CDEF:${id}_minif=${id}_min,UN"
1968                    , "CDEF:${id}_mini=${id}_minif,${id},${id}_min,IF"
1969                    , "GPRINT:${id}_mini:MIN:Min\\:$format\\n"
1970        } else {
1971            push @ds, "GPRINT:$id:MIN:Min\\:$format\\n"
1972        }
1973    } else {
1974        push @ds, "GPRINT:$id:MAX:Max\\:$format"
1975                , "GPRINT:$id:AVERAGE:Avg\\:$format"
1976                , "GPRINT:$id:MIN:Min\\:$format"
1977                , "GPRINT:$id:LAST:Cur\\:$format\\n";
1978    }
1979    return @ds;
1980}
1981
1982# Generate all the parameters for rrd to produce a graph
1983sub rrdline {
1984    my ($params) = @_;
1985    dumper(DBDEB, 'rrdline: params', $params);
1986
1987    my @ds;
1988    my $host = $params->{host};
1989    my $service = $params->{service};
1990    my $db = $params->{db};
1991    my ($graphinfo) = graphinfo($host, $service, $db);
1992
1993    my $errmsg = q();
1994    if (scalar @{$graphinfo} == 0) {
1995        $errmsg = 'No data available: host=' . $host . ' service=' . $service;
1996        if ($db) { $errmsg .= ' db=' . join q(,), @{$db}; }
1997    } else {
1998        foreach my $ii (@{$graphinfo}) {
1999            my @lines = keys %{$ii->{line}};
2000            if (scalar @lines == 0) {
2001                if ($errmsg ne q()) { $errmsg .= "\n"; }
2002                $errmsg .= 'No data available: host=' . $host . ' service=' . $service . ' db=' . $ii->{dbname};
2003            }
2004        }
2005    }
2006    if ($errmsg ne q()) {
2007        return \@ds, $errmsg;
2008    }
2009
2010    # assimilate any labels that were specified
2011    if (defined $params->{label}) {
2012        foreach my $k (@{$params->{label}}) {
2013            if ( $k =~ /([^:]+):(.+)/ ) {
2014                $Labels{$1} = $2;
2015            }
2016        }
2017    }
2018
2019    my $fixedscale = 0;
2020    if (defined $params->{fixedscale}) {
2021        $fixedscale = $params->{fixedscale};
2022    }
2023    my $duration = 118_800;
2024    if (defined $params->{period} && $PERIOD_DATA{$params->{period}}) {
2025        $duration = $PERIOD_DATA{$params->{period}}[1];
2026    }
2027    my $offset = 0;
2028    if (defined $params->{offset} && $params->{offset} ne q()) {
2029        $offset = $params->{offset};
2030    }
2031
2032    # start with global rrdopts from the config file
2033    my $rrdopts = mergeopts(q(), $Config{rrdoptshash}{global});
2034    # add options for the specified service
2035    $rrdopts = mergeopts($rrdopts, $Config{rrdoptshash}{$service});
2036    # add options from the parameters
2037    $rrdopts = mergeopts($rrdopts, $params->{rrdopts});
2038
2039    # use duration and offset from rrdopts if they were specified there.
2040    # this assumes formatting from printgraphicslinks.
2041    if ($rrdopts =~ /-enow-(\d+)/) {
2042        $offset = $1;
2043    }
2044    if ($rrdopts =~ /-snow-(\d+)/) {
2045        $duration = $1 - $offset;
2046    }
2047
2048    # build the list of arguments for rrdtool
2049    push @ds, q(-);
2050    if (index($rrdopts, '-a') == -1 && index($rrdopts, '--imgformat') == -1) {
2051        push @ds, '-a', 'PNG';
2052    }
2053    if (index($rrdopts, '-s') == -1 && index($rrdopts, '--start') == -1) {
2054        my $s = $duration + $offset;
2055        push @ds, '-s', "now-$s";
2056    }
2057    if (index($rrdopts, '-e') == -1 && index($rrdopts, '--end') == -1) {
2058        push @ds, '-e', "now-$offset";
2059    }
2060
2061    # Identify where to pull data from and what to call it
2062    my $directory = $Config{rrddir};
2063    # Compute the longest label length
2064    my $longest = 0;
2065    for my $ii (@{$graphinfo}) {
2066        my $dbname = $ii->{dbname};
2067        foreach my $dsname (keys %{$ii->{line}}) {
2068            my $label = getdatalabel("$dbname,$dsname");
2069            if (length $label > $longest) {
2070                $longest = length $label;
2071            }
2072        }
2073    }
2074    # now get the data and labels.  apply fixed scaling to the vertical axis
2075    # if all of the data sources are fixed scale or if fixed scaling was
2076    # explicitly specified.
2077    for my $ii (@{$graphinfo}) {
2078        my $file = $ii->{file};
2079        my $dbname = $ii->{dbname};
2080        my $fn = "$directory/$file";
2081        dumper(DBDEB, 'rrdline: this graphinfo entry', $ii);
2082        my $allfixed = 1;
2083        for my $dsname (sortnaturally(keys %{$ii->{line}})) {
2084            my ($serv, $pos) = ($service, length($service) - length $dsname);
2085            if (substr($service, $pos) eq $dsname) {
2086                $serv = substr $service, 0, $pos;
2087            }
2088            my $label = getdatalabel("$dbname,$dsname");
2089            push @ds, setlabels($host, $serv, $dbname, $dsname,
2090                                "$fn", $label, $longest);
2091            my $fmt = $fixedscale ?
2092                FIXED_SCALE_FORMAT : getformat($host, $serv, $dbname, $dsname);
2093            if (gethsddvalue('fixedscale', 0, $host, $serv, $dbname, $dsname)) {
2094                $fmt = FIXED_SCALE_FORMAT;
2095            } else {
2096                $allfixed = 0;
2097            }
2098            push @ds, setdata($serv, $dbname, $dsname, "$fn", $duration, $fmt);
2099        }
2100        $fixedscale = 1 if $allfixed;
2101    }
2102
2103    # Dimensions of graph
2104    my ($w, $h) = getgeom(\%Config, $params->{geom});
2105    if ($w > 0 && index($rrdopts, '-w') == -1) {
2106        push @ds, '-w', $w;
2107    }
2108    if ($h > 0 && index($rrdopts, '-h') == -1) {
2109        push @ds, '-h', $h;
2110    }
2111
2112    # Additional parameters to rrd graph, if specified
2113    my $opt = q();
2114    foreach my $ii (split /\s+/, $rrdopts) {
2115        if (substr($ii, 0, 1) eq q(-)) {
2116            $opt = $ii;
2117            push @ds, $opt;
2118        } else {
2119            if ($ds[-1] eq $opt) {
2120                push @ds, $ii;
2121            } else {
2122                $ds[-1] .= " $ii";
2123            }
2124        }
2125    }
2126    if ($fixedscale && index($rrdopts, '-X') == -1) {
2127        push @ds, '-X', '0';
2128    }
2129    foreach my $ii (['altautoscale', '-A'],
2130                    ['altautoscalemin', '-J'],
2131                    ['altautoscalemax', '-M'],
2132                    ['nogridfit', '-N'],
2133                    ['logarithmic', '-o']) {
2134        push @ds, addopt($ii->[0], $service, $rrdopts, $ii->[1]);
2135    }
2136    return \@ds, q();
2137}
2138
2139sub addopt {
2140    my ($conf, $service, $rrdopts, $rrdopt) = @_;
2141    my @ds;
2142    if (defined $Config{$conf}
2143        and exists $Config{$conf}{$service}
2144        and index($rrdopts, $rrdopt) == -1) {
2145        push @ds, $rrdopt;
2146    }
2147    return @ds;
2148}
2149
2150# FIXME: at some point it might be nice to replace args in a with corresponding
2151# args from b.  for now we just append everything in b to a.
2152sub mergeopts {
2153    my ($a, $b) = @_;
2154    $b ||= q();
2155    return $a . ($b eq q() ? q() : q( ) . $b);
2156}
2157
2158# Server/service menu routines ################################################
2159# scan the rrd files and populate the hsdata object with the result.
2160sub scanhsdata {
2161    if (defined $Config{dbseparator} && $Config{dbseparator} eq 'subdir') {
2162        File::Find::find(\&scanhierarchy, $Config{rrddir});
2163    } else {
2164        File::Find::find(\&scandirectory, $Config{rrddir});
2165    }
2166    return;
2167}
2168
2169# scan for rrd files in a directory hierarchy.  build a hash with the result.
2170sub scanhierarchy {
2171    my $current = $_;
2172    my $rrdlen = 0 - length RRDEXT;
2173    if (-d $current and substr($current, 0, 1) ne q(.)) {
2174        # Directories are for hostnames
2175        if (not checkdirempty($current)) { %{$hsdata{$current}} = (); }
2176    } elsif (-f $current && substr($current, $rrdlen) eq RRDEXT) {
2177        # Files are for services
2178        my $host = $File::Find::dir;
2179        $host =~ s|^$Config{rrddir}/||;
2180        # We got the server to associate with and now
2181        # we get the service name by splitting on separator
2182        my ($service, $db) = split /___/, $current;
2183        if ($db) { $db = substr $db, 0, $rrdlen; }
2184        if (not exists $hsdata{$host}{unescape($service)}) {
2185            @{$hsdata{$host}{unescape($service)}} = (unescape($db));
2186        } else {
2187            push @{$hsdata{$host}{unescape($service)}}, unescape($db);
2188        }
2189    }
2190    return;
2191}
2192
2193# scan for rrd files in a single directory.  build a hash with the result.
2194sub scandirectory {
2195    my $current = $_;
2196    my $rrdlen = 0 - length RRDEXT;
2197    if (-f $current && substr($current, $rrdlen) eq RRDEXT) {
2198        my $fn = substr $current, 0, $rrdlen;
2199        my ($host, $service, $db) = split /_/, $fn;
2200        if ($host && $service && $db) {
2201            if (not exists $hsdata{$host}{unescape($service)}) {
2202                @{$hsdata{$host}{unescape($service)}} = (unescape($db));
2203            } else {
2204                push @{$hsdata{$host}{unescape($service)}}, unescape($db);
2205            }
2206        }
2207    }
2208    return;
2209}
2210
2211# get the list of hosts and services for which the user has permission.  the
2212# userid does nothing in this subroutine - it is just used in the messages.
2213sub getserverlist {
2214    my($userid) = @_;
2215    $userid ||= q();
2216    debug(DBDEB, 'getserverlist(' . $userid . ')');
2217
2218    my @hosts;
2219    foreach my $ii (sortnaturally(keys %hsdata)) {
2220        if (havepermission($ii)) {
2221            push @hosts, $ii;
2222        } else {
2223            debug(DBINF, "permission denied: user $userid, host $ii");
2224        }
2225    }
2226
2227    my %hostserv; # hash of hosts, services, and data
2228    foreach my $ii (@hosts) {
2229        my @services = sortnaturally(keys %{$hsdata{$ii}});
2230        foreach my $jj (@services) {
2231            if ( ! havepermission($ii, $jj) ) {
2232                debug(DBINF, "permission denied: user $userid, host $ii, service $jj");
2233                next;
2234            }
2235            foreach my $kk (@{$hsdata{$ii}{$jj}}) {
2236                my @dataitems =
2237                    getdataitems(join q(/), mkfilename($ii, $jj, $kk));
2238                if (not exists $hostserv{$ii}) {
2239                    $hostserv{$ii} = {};
2240                }
2241                if (not exists $hostserv{$ii}{$jj}) {
2242                    $hostserv{$ii}{$jj} = [];
2243                }
2244                push @{$hostserv{$ii}{$jj}}, [$kk, @dataitems];
2245            }
2246        }
2247    }
2248    #dumper(DBDEB, 'hosts', \@hosts);
2249    #dumper(DBDEB, 'hosts-services', \%hostserv);
2250    return ( host => [@hosts], hostserv => \%hostserv );
2251}
2252
2253# Create Javascript i18n string constants
2254sub printi18nscript {
2255    if ( ! defined $Config{javascript} || $Config{javascript} eq q() ) {
2256        return q();
2257    }
2258    my $rval = "var i18n = {\n";
2259    foreach my $ii (@JSLABELS) {
2260        $rval .= '  "' . $ii . '": \'' . _($ii) . "',\n";
2261    }
2262    $rval .= "};\n";
2263    return "<script type=\"text/javascript\">\n" . $rval . "</script>\n";
2264}
2265
2266# Create Javascript Arrays for client-side menu navigation
2267sub printmenudatascript {
2268    my ($hosts, $lookup) = @_;
2269
2270    if ( ! defined $Config{javascript} || $Config{javascript} eq q() ) {
2271        return q();
2272    }
2273
2274    my $rval .= "menudata = new Array();\n";
2275    for my $ii (0 .. @{$hosts} - 1) {
2276        $rval .= "menudata[$ii] = [\"$hosts->[$ii]\"\n";
2277        my @services = sortnaturally(keys %{$hsdata{$hosts->[$ii]}});
2278        #dumper(DBDEB, 'printmenudatascript: keys', \@services);
2279        foreach my $jj (@services) {
2280            my $s = $jj;
2281            $s =~ s/\\/\\\\/g;
2282            $rval .= " ,[\"$s\",";
2283            my %dsstr;
2284            foreach my $kk (@{$lookup->{$hosts->[$ii]}{$jj}}) {
2285                my $name = q();
2286                my @ds;
2287                foreach my $x (@{$kk}) {
2288                    $x =~ s/\\/\\\\/g;
2289                    if ($name eq q()) {
2290                        $name = $x;
2291                    } else {
2292                        push @ds, $x;
2293                    }
2294                }
2295                $dsstr{$name} = '["' . $name . '","' . join('","', sortnaturally(@ds)) . '"]';
2296            }
2297            my $c = 0;
2298            foreach my $dsn (sortnaturally(keys %dsstr)) {
2299                $rval .= q(,) if $c;
2300                $rval .= $dsstr{$dsn};
2301                $c = 1;
2302            }
2303            $rval .= "]\n";
2304        }
2305        $rval .= "];\n";
2306    }
2307    return "<script type=\"text/javascript\">\n" . $rval . "</script>\n";
2308}
2309
2310# Create Javascript Arrays for default service listings.
2311#
2312# sample input:
2313#  ( "net", ( "bytes-received", "bytes-transmitted" ),
2314#    "ping", ( "rta,rtaloss", "ping,loss" )
2315#  )
2316#
2317# sample output:
2318#  defaultds = new Array();
2319#  defaultds[0] = ["net", "bytes-received", "bytes-transmitted" ];
2320#  defaultds[1] = ["ping", "rta,rtaloss", "ping,loss"];
2321#
2322sub printdefaultsscript {
2323    my ($dsref) = @_;
2324
2325    if ( ! defined $Config{javascript} || $Config{javascript} eq q() ) {
2326        return q();
2327    }
2328
2329    my $rval = "defaultds = new Array();\n";
2330    if ($dsref) {
2331        my %dsdata = %{$dsref};
2332        my @keys = keys %dsdata;
2333        for my $ii (0 .. @keys - 1) {
2334            $rval .= "defaultds[$ii] = [\"$keys[$ii]\"";
2335            foreach my $ds (@{$dsdata{$keys[$ii]}}) {
2336                $rval .= ", \"$ds\"";
2337            }
2338            $rval .= "];\n";
2339        }
2340    }
2341    return "<script type=\"text/javascript\">\n" . $rval . "</script>\n";
2342}
2343
2344sub printincludescript {
2345    if ( ! defined $Config{javascript} || $Config{javascript} eq q() ) {
2346        return q();
2347    }
2348    return "<script type=\"text/javascript\" src=\"$Config{javascript}\"></script>\n";
2349}
2350
2351# emit the javascript that configures the web page.  this has to be at the
2352# end of the web page so that all elements have a chance to be instantiated
2353# before the javascript is invoked.
2354sub printinitscript {
2355    my ($host, $service, $expanded_periods) = @_;
2356    if ( ! defined $Config{javascript} || $Config{javascript} eq q() ) {
2357        return q();
2358    }
2359    return "<script type=\"text/javascript\">cfgMenus(\'$host\',\'$service\',\'$expanded_periods\');</script>\n";
2360}
2361
2362# there are 4 contexts: show, showhost, showservice, showgroup.
2363#   show displays both host and service menus.
2364#   showhost displays the host menu.
2365#   showservice displays the service menu.
2366#   showgroup displays the groups menu.
2367#
2368# primary controls consist of the host/service/group menus and the
2369# update button.  secondary controls are all the others.
2370#
2371# the host and group contexts do not require javascript updates when the
2372# menus change, since there are no dependencies in those contexts.
2373sub printcontrols {
2374    my ($cgi, $opts) = @_;
2375
2376    my $context = $opts->{call};
2377
2378    # FIXME: prolly not necessary since we fabricate the submit in javascript.
2379    my %script = qw(both show.cgi host showhost.cgi service showservice.cgi group showgroup.cgi);
2380    my $action = $Config{nagiosgraphcgiurl} . q(/) . $script{$context};
2381
2382    # preface the geometry list with a default entry no matter what
2383    my @geom = (DEFAULT, split /,/, $Config{geometries});
2384    my %geom_labels;
2385    foreach my $i (@geom) {
2386        $geom_labels{$i} = _($i);
2387    }
2388    my %period_labels;
2389    foreach my $i (@PERIOD_KEYS) {
2390        $period_labels{$i} = _($PERIOD_LABELS{$i});
2391    }
2392
2393    my $menustr = q();
2394    if ($context eq 'both') {
2395        my $host = $opts->{host};
2396        my $service = $opts->{service};
2397        $menustr = $cgi->span({-class => 'selector'},
2398                              _('Host:') . q( ) .
2399                              $cgi->popup_menu(-name => 'servidors',
2400                                               -onChange => 'hostChange()',
2401                                               -values => [$host],
2402                                               -default => $host)) . "\n";
2403        $menustr .= $cgi->span({-class => 'selector'},
2404                               _('Service:') . q( ) .
2405                               $cgi->popup_menu(-name => 'services',
2406                                                -onChange => 'serviceChange()',
2407                                                -values => [$service],
2408                                                -default => $service));
2409    } elsif ($context eq 'host') {
2410        my $host = $opts->{host};
2411        $menustr = $cgi->span({-class => 'selector'},
2412                              _('Host:') . q( ) .
2413                              $cgi->popup_menu(-name => 'servidors',
2414                                               -values => [$host],
2415                                               -default => $host));
2416    } elsif ($context eq 'service') {
2417        my $service = $opts->{service};
2418        $menustr = $cgi->span({-class => 'selector'},
2419                              _('Service:') . q( ) .
2420                              $cgi->popup_menu(-name => 'services',
2421                                               -onChange => 'serviceChange()',
2422                                               -values => [$service],
2423                                               -default => $service));
2424    } elsif ($context eq 'group') {
2425        my $group = $opts->{group};
2426        my @groups = (q(-), @{$opts->{grouplist}});
2427        $menustr = $cgi->span({-class => 'selector'},
2428                              _('Group:') . q( ) .
2429                              $cgi->popup_menu(-name => 'groups',
2430                                               -values => [@groups],
2431                                               -default => $group));
2432    }
2433
2434    return $cgi->
2435        div({-class => 'controls'}, "\n" .
2436            $cgi->start_form(-method => 'GET',
2437                             -action => $action,
2438                             -name => 'menuform'),
2439            $cgi->div({-class => 'primary_controls'}, "\n",
2440                      $menustr, "\n",
2441                      $cgi->span({-class => 'executor'},
2442                                 $cgi->button(-name => 'go',
2443                                              -label => _('Update Graphs'),
2444                                              -onClick => 'jumpto()')
2445                                 ), "\n",
2446                      ), "\n",
2447            $cgi->div({-class => 'secondary_controls'}, "\n",
2448                      $cgi->span({-class => 'controls_toggle'},
2449                                 '<button type="button" onClick="toggleControlsDisplay(this)">',
2450                                 $cgi->img({src => IMG_PLUS}),
2451                                 $cgi->img({style => 'display:none', src => IMG_MINUS}),
2452                                 '</button>'
2453                                 ), "\n",
2454                      ), "\n",
2455            $cgi->div({-id => 'secondary_controls_box', -style => 'display:none'}, "\n",
2456                      $cgi->table($cgi->Tr({-valign => 'top'}, "\n",
2457                                           $cgi->td(($context eq 'both' || $context eq 'service')
2458                                                    ? $cgi->table($cgi->Tr({-valign => 'top', -id => 'db_controls' }, "\n",
2459                                                                           $cgi->td({-class => 'control_label'}, _('Data Sets:')), "\n",
2460                                                                           $cgi->td($cgi->popup_menu(-name => 'db', -values => [], -size => DBLISTROWS, -multiple => 1)), "\n",
2461                                                                           $cgi->td($cgi->button(-name => 'clear', -label => _('Clear'), -onClick => 'clearDBSelection()')), "\n",
2462                                                                           ), "\n",
2463                                                                  ) . "\n"
2464                                                    : q()), "\n",
2465                                           $cgi->td($cgi->table($cgi->Tr({-valign => 'top'}, "\n",
2466                                                                         $cgi->td({-class => 'control_label'}, _('Periods:')), "\n",
2467                                                                         $cgi->td($cgi->popup_menu(-name => 'period', -values => [@PERIOD_KEYS], -labels => \%period_labels, -size => PERIODLISTROWS, -multiple => 1)), "\n",
2468                                                                         $cgi->td($cgi->button(-name => 'clear', -label => _('Clear'), -onClick => 'clearPeriodSelection()')), "\n",
2469                                                                         ), "\n",
2470                                                                $cgi->Tr($cgi->td({-class => 'control_label'}, _('Size:')), "\n",
2471                                                                         $cgi->td($cgi->popup_menu(-name => 'geom', -values => [@geom], -labels => \%geom_labels)), "\n",
2472                                                                         $cgi->td(q( )), "\n",
2473                                                                         ), "\n",
2474                                                                $cgi->Tr($cgi->td({-class => 'control_label'}, _('End Date:')), "\n",
2475                                                                         $cgi->td({-colspan => '2'}, $cgi->button(-name => 'enddate', -label => 'now', -onClick => 'showDateTimePicker(this)')), "\n",
2476                                                                         ), "\n",
2477                                                                ), "\n",
2478                                                    ), "\n",
2479                                           ), "\n",
2480                                  ), "\n",
2481                      ), "\n",
2482            $cgi->end_form,
2483            "\n");
2484}
2485
2486sub printgraphlinks {
2487    my ($cgi, $params, $period, $title) = @_;
2488    if (! defined $title) { $title = q(); }
2489    dumper(DBDEB, 'printgraphlinks: params', $params);
2490    dumper(DBDEB, 'printgraphlinks: period', $period);
2491
2492    my $gtitle = q();
2493    my $alttag = q();
2494    my $desc = q();
2495
2496    my $showtitle = $params->{showtitle};
2497    my $showdesc = $params->{showdesc};
2498    my $showgraphtitle = $params->{showgraphtitle};
2499
2500    # the description contains a list of the data set names.
2501    if ($showdesc) {
2502        if ($params->{db} && scalar @{$params->{db}} > 0) {
2503            foreach my $ii (sortnaturally(@{$params->{db}})) {
2504                if ($desc ne q()) { $desc .= $cgi->br(); }
2505                $desc .= getdatalabel($ii);
2506            }
2507        }
2508    }
2509    debug(DBDEB, 'printgraphlinks: desc=' . $desc);
2510
2511    # include quite a bit of information in the alt tag - it helps when
2512    # debugging configuration files.
2513    $gtitle = $params->{service} . q( ) . _('on') . q( ) . $params->{host};
2514    $alttag = _('Graph of') . q( ) . $gtitle;
2515    if ($params->{db} && scalar @{$params->{db}} > 0) {
2516        $alttag .= ' (';
2517        foreach my $ii (sortnaturally(@{$params->{db}})) {
2518            $alttag .= q( ) . $ii;
2519        }
2520        $alttag .= ' )';
2521    }
2522    debug(DBDEB, 'printgraphlinks: alttag=' . $alttag);
2523
2524    my $rrdopts = q();
2525    if ($params->{rrdopts}) {
2526        $rrdopts .= $params->{rrdopts};
2527    }
2528    if ($params->{graphonly} && index($rrdopts, '-j') == -1) {
2529        $rrdopts .= ' -j';
2530    }
2531    if ($params->{hidelegend} && index($rrdopts, '-g') == -1) {
2532        $rrdopts .= ' -g';
2533    }
2534    # the '-snow' and '-enow' formats matter - they are detected by rrdline
2535    my $soff = $period->[1] + $params->{offset};
2536    $rrdopts .= ' -snow-' . $soff;
2537    $rrdopts .= ' -enow-' . $params->{offset};
2538    if ($showgraphtitle) {
2539        if ($rrdopts !~ /(-t|--title)/) {
2540            my $t = $gtitle;
2541            $t =~ s/<br.*//g;     # use only the first line
2542            $t =~ s/<[^>]+>//g;   # punt any html markup
2543            $t =~ tr/-/:/;        # hyphens cause problems
2544            $rrdopts .= ' -t ' . $t;
2545        }
2546    }
2547    debug(DBDEB, 'printgraphlinks: rrdopts=' . $rrdopts);
2548
2549    my $url = $Config{nagiosgraphcgiurl} . '/showgraph.cgi?'
2550        . buildurl($params->{host}, $params->{service},
2551                   { geom => $params->{geom},
2552                     rrdopts => [$rrdopts],
2553                     fixedscale => $params->{fixedscale},
2554                     db => $params->{db},
2555                 });
2556    debug(DBDEB, 'printgraphlinks: url=' . $url);
2557
2558    my $titlestr = $showtitle
2559        ? $cgi->p({-class=>'graph_title'}, $title) : q();
2560    my $descstr = $desc ne q()
2561        ? $cgi->p({-class=>'graph_description'}, $desc) : q();
2562    my ($w, $h) = getgeom(\%Config, $params->{geom});
2563
2564    return $cgi->div({-class => 'graph'}, "\n",
2565                     $cgi->div({-class => 'graph_image'},
2566                               $cgi->img({-src => $url,
2567                                          -alt => $alttag,
2568                                          -onmouseover => 'ngzInit(this)',
2569                                          -graphtop => GRAPHTOP,
2570                                          -graphleft => GRAPHLEFT,
2571                                          -graphwidth => $w,
2572                                          -graphheight => $h,
2573                                          })) . "\n",
2574                     $cgi->div({-class => 'graph_details'}, "\n",
2575                               $titlestr, $titlestr ne q() ? "\n" : q(),
2576                               $descstr, $descstr ne q() ? "\n" : q(),
2577                               ));
2578}
2579
2580sub printperiodlinks {
2581    my($cgi, $params, $period, $now, $content) = @_;
2582    my (@navstr) = getperiodctrls($cgi, $params->{offset}, $period, $now);
2583    my $id = 'period_data_' . $period->[0];
2584    return $cgi->div({-class => 'period_banner'},
2585                     $cgi->span({-class => 'period_title'},
2586                                '<button type="button" class="period_toggle" id="toggle_' . $period->[0] . '" onClick="togglePeriodDisplay(\'' . $id . '\', this)">',
2587                                $cgi->img({src => IMG_PLUS}),
2588                                $cgi->img({src => IMG_MINUS}),
2589                                '</button>',
2590                                $cgi->a({ -id => $period->[0] },
2591                                        _($PERIOD_LABELS{$period->[0]}))),
2592                     $cgi->span({-class => 'period_controls'},
2593                                $navstr[0],
2594                                $cgi->span({-class => 'period_detail'},
2595                                           $navstr[1]),
2596                                $navstr[2]),
2597                     ) . "\n" .
2598           $cgi->div({-class => 'period', -id => $id }, "\n" .
2599                     $content) . "\n";
2600}
2601
2602sub printsummary {
2603    my($cgi, $opts) = @_;
2604
2605    my $s = q();
2606    if ($opts->{call} eq 'both') {
2607        $s = _('Data for host') . q( ) .
2608            $cgi->span({-class => 'item_label'},
2609                       $cgi->a({href => $opts->{hosturl}},
2610                               $opts->{host})) .
2611            ', ' .
2612            _('service') . q( ) .
2613            $cgi->span({-class => 'item_label'},
2614                       $cgi->a({href => $opts->{serviceurl}},
2615                               getlabel($opts->{service})));
2616    } elsif ($opts->{call} eq 'host') {
2617        $s = _('Data for host') . q( ) .
2618            $cgi->span({-class => 'item_label'},
2619                       $cgi->a({href => $opts->{hosturl}},
2620                               $opts->{host}));
2621    } elsif ($opts->{call} eq 'service') {
2622        $s = _('Data for service') . q( ) .
2623            $cgi->span({-class => 'item_label'},
2624                       getlabel($opts->{service}));
2625    } elsif ($opts->{call} eq 'group') {
2626        $s = _('Data for group') . q( ) .
2627            $cgi->span({-class => 'item_label'},
2628                       getlabel($opts->{group}));
2629    }
2630
2631    return $cgi->div({ -class => 'summary' },
2632                     $s . q( ) . _('as of') . q( ) .
2633                     $cgi->span({ -class => 'timestamp' },
2634                                formattime(time, 'timeformat_now')));
2635}
2636
2637sub printheader {
2638    my ($cgi, $opts) = @_;
2639
2640    my $rval = $cgi->header;
2641    $rval .= $cgi->start_html(-id => 'nagiosgraph',
2642                              -title => "nagiosgraph: $opts->{title}",
2643                              -head => $cgi->meta( { getrefresh() } ),
2644                              getstyle());
2645
2646    $rval .= printmenudatascript($authhosts{host}, $authhosts{hostserv});
2647    if ($opts->{defaultdatasets}) {
2648        $rval .= printdefaultsscript($opts->{defaultdatasets});
2649    }
2650    $rval .= printincludescript();
2651
2652    if (! $Config{hidejswarnings}) {
2653        $rval .= $cgi->div({-id => 'js_disabled', -style => ERRSTYLE},
2654                           _(JSDISABLED)) . "\n";
2655        $rval .= $cgi->div({-id => 'js_version_' . JSVERSION, -style => ERRSTYLE},
2656                           _(JSMISSING)) . "\n";
2657    }
2658
2659    $rval .= printcontrols($cgi, $opts) . "\n";
2660
2661    $rval .= (defined $Config{hidengtitle} and $Config{hidengtitle} eq 'true')
2662        ? q() : $cgi->h1('Nagiosgraph') . "\n";
2663
2664    $rval .= printsummary($cgi, $opts) . "\n";
2665
2666    return $rval;
2667}
2668
2669sub printfooter {
2670    my ($cgi,$sts,$ets) = @_;
2671    $sts ||= 0;
2672    $ets ||= 0;
2673    my $tstr = (defined $Config{showprocessingtime}
2674                && $Config{showprocessingtime} eq 'true')
2675        ? $cgi->br() . formatelapsedtime($sts, $ets)
2676        : q();
2677    return $cgi->div({-class => 'footer'}, q(), # or instead of q() $cgi->hr()
2678                     _('Created by') . q( ) .
2679                     $cgi->a({href => NAGIOSGRAPHURL },
2680                             'Nagiosgraph ' . $VERSION) . $tstr )
2681        . $cgi->end_html();
2682}
2683
2684# Full page routine ###########################################################
2685# Determine the number of graphs that will be displayed on the page
2686# and the time period they will cover.  This expects a comma-delimited
2687# or space-delimited list of period names.
2688#
2689# returns an array of period data, where each array element is a
2690# tuple of name, period, offset.
2691sub graphsizes {
2692    my $conf = shift;
2693    $conf =~ s/,/ /g; # we will split on whitespace
2694    dumper(DBDEB, 'graphsizes: period', $conf);
2695    my @unsorted;
2696    foreach my $ii (split /\s+/, $conf) {
2697        next if not exists $PERIOD_DATA{$ii};
2698        push @unsorted, $PERIOD_DATA{$ii};
2699    }
2700    if (not @unsorted) {
2701        debug(DBDEB, 'graphsizes: no period data found, using defaults');
2702        foreach my $ii (split / /, PERIODS) {
2703            push @unsorted, $PERIOD_DATA{$ii};
2704        }
2705    }
2706    my @rval = sort {$a->[1] <=> $b->[1]} @unsorted;
2707    return @rval;
2708}
2709
2710# returns three strings: a url for previous period, a label for current
2711# display, and a url for the next period.  do not permit voyages into
2712# the future.
2713sub getperiodctrls {
2714    my ($cgi, $offset, $period, $now) = @_;
2715
2716    # strip any offset from the url
2717    my $url = $ENV{REQUEST_URI} ? $ENV{REQUEST_URI} : q();
2718    $url =~ s/&*offset=[^&]*//;
2719
2720    # now calculate and inject our own offset
2721    my $x = ($offset + $period->[2]);
2722    my $p = $cgi->a({-href=>"$url&offset=$x"}, '<');
2723    my $c = getperiodlabel($now,$offset,$period->[1],$period->[0]);
2724    $x = ($offset - $period->[2]);
2725    my $n = ($x < 0 ? q() : $cgi->a({-href=>"$url&offset=$x"}, '>'));
2726
2727    return ($p, $c, $n);
2728}
2729
2730# returns a human-readable string with the start and end time relative to
2731# the current hour plus the indicated offset.  the resolution determines
2732# how much information to put into the label string.
2733sub getperiodlabel {
2734    my($now, $offset, $period, $res) = @_;
2735    my $e = $now - $offset;
2736    my $s = $e - $period;
2737    my $sstr = formattime($s, 'timeformat_' . $res);
2738    my $estr = formattime($e, 'timeformat_' . $res);
2739    return $sstr . q( - ) . $estr;
2740}
2741
2742sub formattime {
2743    my ($t, $key) = @_;
2744    return $key && defined $Config{$key}
2745        ? strftime $Config{$key}, localtime $t
2746        : scalar localtime $t;
2747}
2748
2749# read data from the perflog
2750sub readperfdata {
2751    my ($fn) = @_;
2752    debug(DBDEB, 'readperfdata(' . $fn . ')');
2753    my @lines;
2754    if (-s $fn) {
2755        my $worklog = $fn . '.nagiosgraph';
2756        if (! rename $fn, $worklog) {
2757            debug(DBCRT, "cannot process perflog: rename failed for $fn");
2758            return @lines;
2759        }
2760        if (open my $PERFLOG, '<', $worklog) {
2761            while (<$PERFLOG>) {
2762                push @lines, $_;
2763            }
2764            close $PERFLOG or debug(DBERR, "close failed for $worklog: $OS_ERROR");
2765            unlink $worklog;
2766        } else {
2767            debug(DBWRN, "cannot read perfdata from $worklog: $OS_ERROR");
2768            return @lines;
2769        }
2770    }
2771    if (not @lines) {
2772        debug(DBINF, 'empty perflog ' . $fn);
2773    } else {
2774        debug(DBINF, 'read ' . scalar @lines . ' lines from perflog');
2775    }
2776    return @lines;
2777}
2778
2779# construct the RRA strings
2780sub getrras { ## no critic (ProhibitManyArgs)
2781    my ($host, $service, $dbname, $xff, $rows, $steps, $choice) = @_;
2782    if (not $choice) {
2783        if (gethsdvalue('lasts', 0, $host, $service, $dbname)) {
2784            $choice = 'LAST';
2785        } elsif (gethsdvalue('maximums', 0, $host, $service, $dbname)) {
2786            $choice = 'MAX';
2787        } elsif (gethsdvalue('minimums', 0, $host, $service, $dbname)) {
2788            $choice = 'MIN';
2789        } else {
2790            $choice = 'AVERAGE';
2791        }
2792    }
2793    return "RRA:$choice:$xff:$steps->[0]:$rows->[0]",
2794           "RRA:$choice:$xff:$steps->[1]:$rows->[1]",
2795           "RRA:$choice:$xff:$steps->[2]:$rows->[2]",
2796           "RRA:$choice:$xff:$steps->[3]:$rows->[3]";
2797}
2798
2799# Create new rrd databases if necessary
2800sub runcreate {
2801    my $ds = shift;
2802    dumper(DBINF, 'runcreate creating RRD: DS', $ds);
2803    RRDs::create(@{$ds});
2804    my $ERR = RRDs::error();
2805    if ($ERR) {
2806        debug(DBERR, 'RRDs::create ERR ' . $ERR);
2807        dumper(DBERR, 'ds', $ds);
2808    }
2809    return;
2810}
2811
2812sub checkdatasources {
2813    my ($ds, $directory, $filenames) = @_;
2814    if (scalar @{$ds} == 3 and scalar @{$filenames} == 1) {
2815        debug(DBCRT, "no data sources defined for $directory/$filenames->[0]");
2816        return 0;
2817    }
2818    return 1;
2819}
2820
2821# ensure that the name is ok as an rrd ds name.  if not, fail loudly.  we do
2822# not try to fix the name - just complain loudly about it and bail out.
2823sub checkdsname {
2824    my ($dsname) = @_;
2825    if (length $dsname > DSNAME_MAXLEN or $dsname =~ /[^a-zA-Z0-9_-]/) {
2826        return 1;
2827    }
2828    return 0;
2829}
2830
2831sub createrrd {
2832    my ($start, $host, $service, $labels) = @_;
2833    debug(DBDEB, "createrrd($start,$host,$service,$labels->[0])");
2834    my ($directory,             # directory in which to put rrd files
2835        @filenames);            # rrd file name(s)
2836
2837    my $db = shift @{$labels};
2838    ($directory, $filenames[0]) = mkfilename($host, $service, $db);
2839    debug(DBDEB, "createrrd rrdfile is $directory/$filenames[0]");
2840    if (not -e $directory) { # ensure we can write to data directory
2841        debug(DBINF, "creating directory $directory");
2842        if ( ! mkdir $directory, 0775 ) {
2843            my $msg = "cannot create directory $directory: $OS_ERROR";
2844            debug(DBCRT, $msg);
2845            croak($msg);
2846        }
2847    }
2848    if (not -w $directory) {
2849        my $msg = 'cannot write to directory ' . $directory;
2850        debug(DBCRT, $msg);
2851        croak($msg);
2852    }
2853
2854    my $rstr = gethsdvalue2('resolution', RESOLUTIONS, $host, $service, $db);
2855    my @rows = split / /, $rstr;
2856    if (scalar @rows != 4) {
2857        my $msg = 'wrong number of values for resolution (expecting 4, got '
2858            . scalar @rows . ')';
2859        debug(DBCRT, $msg);
2860        croak($msg);
2861    }
2862
2863    my $sstr = gethsdvalue2('step', STEPS, $host, $service, $db);
2864    my @steps = split / /, $sstr;
2865    if (scalar @steps != 4) {
2866        my $msg = 'wrong number of values for step (expecting 4, got '
2867            . scalar @steps . ')';
2868        debug(DBCRT, $msg);
2869        croak($msg);
2870    }
2871
2872    my $xff = gethsdvalue2('xff', XFF, $host, $service, $db);
2873
2874    my $heartbeat = gethsdvalue2('heartbeat', HEARTBEAT, $host, $service, $db);
2875
2876    my $stepsize = gethsdvalue2('stepsize', STEPSIZE, $host, $service, $db);
2877
2878    debug(DBDEB, 'createrrd: step=' . $stepsize
2879          . ' heartbeat=' . $heartbeat
2880          . ' xff=' . $xff
2881          . ' resolutions=' . join q( ), @rows
2882          . ' steps=' . join q( ), @steps);
2883
2884    my @ds = ("$directory/$filenames[0]",
2885              '--start', $start, '--step', $stepsize,);
2886    my @dsmin = ("$directory/$filenames[0]_min",
2887                 '--start', $start, '--step', $stepsize,);
2888    my @dsmax = ("$directory/$filenames[0]_max",
2889                 '--start', $start, '--step', $stepsize,);
2890
2891    my @datasets = [];
2892    for my $ii (0 .. @{$labels} - 1) {
2893        next if not $labels->[$ii];
2894        dumper(DBDEB, "labels->[$ii]", $labels->[$ii]);
2895        if (checkdsname($labels->[$ii]->[0])) {
2896            my $msg = 'ds-name is not valid: ' . $labels->[$ii]->[0];
2897            debug(DBCRT, $msg);
2898            croak($msg);
2899        }
2900        my $ds = join q(:), ('DS',
2901                             $labels->[$ii]->[0],
2902                             $labels->[$ii]->[1],
2903                             $heartbeat,
2904                             $labels->[$ii]->[1] eq 'DERIVE' ? '0' : 'U',
2905                             'U');
2906        if (defined $Config{hostservvar}->{$host} and
2907            defined $Config{hostservvar}->{$host}->{$service} and
2908            defined $Config{hostservvar}->{$host}->{$service}->{$labels->[$ii]->[0]}) {
2909            my $fn = (mkfilename($host, $service . $labels->[$ii]->[0], $db))[1];
2910            push @filenames, $fn;
2911            push @datasets, [$ii];
2912            if (not -e "$directory/$fn") {
2913                runcreate(["$directory/$fn",
2914                           '--start', $start, '--step', $stepsize, $ds,
2915                           getrras($host,$service,$db,$xff,\@rows,\@steps)]);
2916            }
2917            if (checkminmax('min', $service, $directory, $fn)) {
2918                runcreate(["$directory/${fn}_min",
2919                           '--start', $start, '--step', $stepsize, $ds,
2920                           getrras($host,$service,$db,$xff,\@rows,\@steps,'MIN')]);
2921            }
2922            if (checkminmax('max', $service, $directory, $fn)) {
2923                runcreate(["$directory/${fn}_max",
2924                           '--start', $start, '--step', $stepsize, $ds,
2925                           getrras($host,$service,$db,$xff,\@rows,\@steps,'MAX')]);
2926            }
2927            next;
2928        } else {
2929            push @ds, $ds;
2930            push @{$datasets[0]}, $ii;
2931            if (defined $Config{withminimums}->{$service}) {
2932                push @dsmin, $ds;
2933            }
2934            if (defined $Config{withmaximums}->{$service}) {
2935                push @dsmax, $ds;
2936            }
2937        }
2938    }
2939    if (not -e "$directory/$filenames[0]" and
2940        checkdatasources(\@ds, $directory, \@filenames)) {
2941        push @ds, getrras($host, $service, $db, $xff, \@rows, \@steps);
2942        runcreate(\@ds);
2943    }
2944    createminmax('min', \@dsmin, \@filenames,
2945                 { directory => $directory,
2946                   host => $host, service => $service, db => $db,
2947                   xff => $xff, rows => \@rows, steps => \@steps });
2948    createminmax('max', \@dsmax, \@filenames,
2949                 { directory => $directory,
2950                   host => $host, service => $service, db => $db,
2951                   xff => $xff, rows => \@rows, steps => \@steps });
2952    dumper(DBDEB, 'createrrd: filenames', \@filenames);
2953    dumper(DBDEB, 'createrrd: datasets', \@datasets);
2954    return \@filenames, \@datasets;
2955}
2956
2957sub checkminmax {
2958    my ($conf, $service, $directory, $filename) = @_;
2959    if (defined $Config{'with' . $conf . 'imums'}->{$service} and
2960        not -e $directory . q(/) . $filename . q(_) . $conf) {
2961        return 1;
2962    }
2963    return 0;
2964}
2965
2966sub createminmax {
2967    my ($conf, $ds, $filenames, $opts) = @_;
2968    if (checkminmax($conf,
2969                    $opts->{service}, $opts->{directory}, $filenames->[0]) and
2970        checkdatasources($ds, $opts->{directory}, $filenames)) {
2971        my $s = $conf;
2972        $s =~ tr/[a-z]/[A-Z]/;
2973        push @{$ds}, getrras($opts->{host}, $opts->{service}, $opts->{db},
2974                             $opts->{xff}, $opts->{rows}, $opts->{steps}, $s);
2975        runcreate($ds);
2976    }
2977    return;
2978}
2979
2980# Use RRDs to update rrd file
2981sub runupdate {
2982    my $dataset = shift;
2983    dumper(DBINF, 'runupdate dataset', $dataset);
2984    RRDs::update(@{$dataset});
2985    my $ERR = RRDs::error();
2986    if ($ERR) {
2987        debug(DBERR, 'RRDs::update ERR ' . $ERR);
2988        dumper(DBERR, 'ds', $dataset);
2989    }
2990    return;
2991}
2992
2993sub rrdupdate { ## no critic (ProhibitManyArgs)
2994    my ($file, $time, $host, $service, $ds, $values) = @_;
2995    my $directory = $Config{rrddir};
2996
2997    # Select target folder depending on config settings
2998    if (defined $Config{dbseparator} && $Config{dbseparator} eq 'subdir') {
2999        $directory .= "/$host";
3000    }
3001
3002    my @dataset;
3003    push @dataset, "$directory/$file",  $time;
3004    for my $ii (0 .. @{$values} - 1) {
3005        for (@{$ds}) {
3006            if ($ii == $_) {
3007                $values->[$ii]->[2] ||= 0;
3008                $dataset[1] .= ":$values->[$ii]->[2]";
3009                last;
3010            }
3011        }
3012    }
3013    runupdate(\@dataset);
3014
3015    if (defined $Config{withminimums}->{$service}) {
3016        $dataset[0] = "$directory/${file}_min";
3017        runupdate(\@dataset);
3018    }
3019    if (defined $Config{withmaximums}->{$service}) {
3020        $dataset[0] = "$directory/${file}_max";
3021        runupdate(\@dataset);
3022    }
3023    return;
3024}
3025
3026# Read the map file and define a subroutine that parses performance data
3027sub getrules {
3028    my $file = getcfgfn(shift);
3029    debug(DBDEB, 'getrules(' . $file . ')');
3030    my @rules;
3031    if ( open my $FH, '<', $file ) {
3032        while (<$FH>) {
3033            push @rules, $_;
3034        }
3035        close $FH or debug(DBERR, "close failed for $file: $OS_ERROR");
3036    } else {
3037        my $msg = "cannot open $file: $OS_ERROR";
3038        debug(DBCRT, $msg);
3039        return $msg;
3040    }
3041    ## no critic (RequireInterpolationOfMetachars)
3042    my $code = 'sub evalrules { $_ = $_[0];' .
3043        ' my ($d, @s) = ($_);' .
3044        ' no strict "subs";' .
3045        join(q(), @rules) .
3046        ' use strict "subs";' .
3047        ' return () if ($#s > -1 && $s[0] eq "ignore");' .
3048        ' return @s; }';
3049    my $rval = eval $code; ## no critic (ProhibitStringyEval)
3050    if ($EVAL_ERROR or $rval) {
3051        my $msg = 'Map file eval error: ' . $EVAL_ERROR;
3052        debug(DBCRT, $msg);
3053        return $msg;
3054    }
3055    return q();
3056}
3057
3058# process one or more lines that are nagios perfdata format
3059sub processdata {
3060    my (@lines) = @_;
3061    my $t = $#lines + 1;
3062    debug(DBDEB, 'processdata: processing ' . $t . ' lines');
3063    my $n = 0;
3064    for my $line (@lines) {
3065        chomp $line;
3066        my @data = split /\|\|/, $line;
3067        $data[0] ||= q();
3068        $data[1] ||= q();
3069        $data[2] ||= q();
3070        $data[3] ||= q();
3071        $data[4] ||= q();
3072        if ( $data[0] eq q() ) {
3073            debug(DBWRN, "processdata: no timestamp found:\n" . $line);
3074            next;
3075        }
3076        if ( $data[1] eq q() ) {
3077            debug(DBWRN, "processdata: no host found:\n" . $line);
3078            next;
3079        }
3080        if ( $data[2] eq q() ) {
3081            debug(DBWRN, "processdata: no service found:\n" . $line);
3082            next;
3083        }
3084        my $debug = $Config{debug};
3085        getdebug('insert', $data[1], $data[2]);
3086        dumper(DBDEB, 'processdata: data', \@data);
3087        my $dstr = "hostname:$data[1]\nservicedesc:$data[2]\noutput:$data[3]\nperfdata:$data[4]";
3088        my @x = evalrules($dstr);
3089        if ( ! @x || $#x < 0 ) {
3090            debug(DBWRN, "output/perfdata not recognized:\n" . $dstr);
3091        } elsif ( $x[0] eq 'ignore' ) {
3092            debug(DBINF, "output/perfdata ignored:\n" . $dstr);
3093        } else {
3094            debug(DBINF, "processing output/perfdata:\n" . $dstr);
3095            $n += 1;
3096            for my $s ( @x ) {
3097                my ($rrds, $sets) = createrrd($data[0]-1,$data[1],$data[2],$s);
3098                next if not $rrds;
3099                for my $ii (0 .. @{$rrds} - 1) {
3100                    rrdupdate($rrds->[$ii], $data[0],
3101                              $data[1], $data[2], $sets->[$ii], $s);
3102                }
3103            }
3104        }
3105        $Config{debug} = $debug;
3106    }
3107    debug(DBINF, 'processed ' . $n . ' of ' . $t . ' lines');
3108    return;
3109}
3110
3111# return a translation for the indicated key.  if there is no translation,
3112# return the key.
3113sub _ {
3114    my ($key) = @_;
3115    return $i18n{$key} ? $i18n{$key} : $key;
3116}
3117
3118# labels use the same lookup mechanism as translations, but labels are not
3119# necessarily defined with a specific language.  we keep separate functions
3120# to make explicit the difference between a label and a translation.
3121sub getlabel {
3122    my ($key) = @_;
3123    return $Labels{$key} ? $Labels{$key} : $key;
3124}
3125
3126# get the label associated with the indicated name.  the name could be a
3127# database name, a data source name, or a db,ds pair.
3128sub getdatalabel {
3129    my ($name) = @_;
3130    my $x = getlabel($name);
3131    if ($x eq $name) {
3132        my ($db,$ds) = split /,/, $name;
3133        if ($ds) {
3134            my $y = getlabel($ds);
3135            if ($y ne $ds) {
3136                $x = $y;
3137            }
3138        } elsif ($db) {
3139            my $y = getlabel($db);
3140            if ($y ne $db) {
3141                $x = $y;
3142            }
3143        }
3144    }
3145    return $x;
3146}
3147
3148# sort a list naturally using implementation by tye at
3149# http://www.perlmonks.org/?node=442237
3150sub sortnaturally {
3151    my(@list) = @_;
3152    return @list[
3153        map { unpack 'N', substr $_,-4 }
3154        sort
3155        map {
3156            my $key = $list[$_];
3157            $key =~ s/((?<!\.)(\d+)\.\d+(?!\.)|\d+)/
3158                my $len = length( defined($2) ? $2 : $1 );
3159                pack( 'N', $len ) . $1 . ' ';
3160            /ge;
3161            $key . pack 'N', $_
3162        } 0..$#list
3163    ];
3164}
3165
31661;
3167
3168__END__
3169
3170=head1 NAME
3171
3172ngshared.pm - shared subroutines for the nagiosgraph programs
3173
3174=head1 SYNOPSIS
3175
3176B<use lib '/path/to/this/file';>
3177B<use ngshared;>
3178
3179=head1 DESCRIPTION
3180
3181A shared set of routines for reading configuration files, logging, etc.
3182
3183=head1 USAGE
3184
3185There is no direct invocation.  ngshared.pm contains functions that can be used to graph RRD data sets with data for hosts and services from Nagios.
3186
3187=head1 REQUIRED ARGUMENTS
3188
3189=head1 OPTIONS
3190
3191=head1 DIAGNOSTICS
3192
3193=head1 EXIT STATUS
3194
3195=head1 CONFIGURATION
3196
3197ngshared.pm uses B<nagiosgraph.conf> for most configuration.  ngshared.pm also includes subroutines to read from B<hostdb.conf>, B<servdb.conf>, B<groupdb.conf>, and B<rrdopts.conf> files.  These files are typically located in /etc/nagiosgraph.
3198
3199=head1 INSTALLATION
3200
3201Copy this file into a configuration directory (/etc/nagiosgraph, for example) and modify the B<use lib> line in each *.cgi file to the directory.
3202
3203=head1 DEPENDENCIES
3204
3205=over 4
3206
3207=item B<rrdtool>
3208
3209This provides the data storage and graphing system.
3210
3211=item B<RRDs>
3212
3213This provides the perl interface to rrdtool.
3214
3215=back
3216
3217=head1 BUGS AND LIMITATIONS
3218
3219=head1 INCOMPATIBILITIES
3220
3221=head1 SEE ALSO
3222
3223B<insert.pl> B<showgraph.cgi> B<show.cgi> B<showhost.cgi> B<showservice.cgi> B<showgroup.cgi> B<testcolor.cgi>
3224
3225=head1 AUTHOR
3226
3227Soren Dossing, the original author in 2005.
3228
3229Alan Brenner - alan.brenner@ithaka.org; I've updated this from the version at http://nagiosgraph.wiki.sourceforge.net/ by moving some subroutines into this shared file (ngshared.pm) for use by insert.pl and the show*.cgi files.
3230
3231Matthew Wall.  Added some graphing and display features.  General bugfixing,
3232cleanup and refactoring.  Added showgraph.cgi.  Added CSS and JavaScript for
3233graph and time period controls.
3234
3235=head1 LICENSE AND COPYRIGHT
3236
3237Copyright (C) 2005 Soren Dossing, 2009 Andrew W. Mellon Foundation
3238
3239This program is free software; you can redistribute it and/or
3240modify it under the terms of the OSI Artistic License see:
3241http://www.opensource.org/licenses/artistic-license-2.0.php
3242
3243This program is distributed in the hope that it will be useful,
3244but WITHOUT ANY WARRANTY; without even the implied warranty of
3245MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
3246