1 |
dpavlin |
1 |
#!/usr/bin/perl |
2 |
|
|
############################################################ |
3 |
|
|
# |
4 |
|
|
# $Id: rrd-browse.cgi 692 2006-06-26 19:11:14Z nicolaw $ |
5 |
|
|
# rrd-browse.cgi - Graph browser CGI script for RRD::Simple |
6 |
|
|
# |
7 |
|
|
# Copyright 2006,2007 Nicola Worthington |
8 |
|
|
# |
9 |
|
|
# Licensed under the Apache License, Version 2.0 (the "License"); |
10 |
|
|
# you may not use this file except in compliance with the License. |
11 |
|
|
# You may obtain a copy of the License at |
12 |
|
|
# |
13 |
|
|
# http://www.apache.org/licenses/LICENSE-2.0 |
14 |
|
|
# |
15 |
|
|
# Unless required by applicable law or agreed to in writing, software |
16 |
|
|
# distributed under the License is distributed on an "AS IS" BASIS, |
17 |
|
|
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
18 |
|
|
# See the License for the specific language governing permissions and |
19 |
|
|
# limitations under the License. |
20 |
|
|
# |
21 |
|
|
############################################################ |
22 |
|
|
# vim:ts=4:sw=4:tw=78 |
23 |
|
|
|
24 |
|
|
# User defined constants |
25 |
dpavlin |
4 |
use constant BASEDIR => '/var/www/rrd'; |
26 |
dpavlin |
1 |
use constant RRDURL => ''; |
27 |
|
|
|
28 |
|
|
# Caching |
29 |
|
|
use constant CACHE => 1; |
30 |
|
|
use constant DEFAULT_EXPIRES => '60 minutes'; |
31 |
|
|
|
32 |
|
|
# When is an RRD file regarded as stale? |
33 |
|
|
use constant STALE_THRESHOLD => 60*60; # 60 minutes |
34 |
|
|
|
35 |
|
|
############################################################ |
36 |
|
|
|
37 |
|
|
|
38 |
|
|
|
39 |
|
|
|
40 |
|
|
use 5.6.1; |
41 |
|
|
use warnings; |
42 |
|
|
use strict; |
43 |
|
|
use CGI; |
44 |
|
|
use CGI::Carp qw(fatalsToBrowser); |
45 |
|
|
use HTML::Template::Expr; |
46 |
|
|
use File::Basename qw(basename); |
47 |
|
|
use Config::General qw(); |
48 |
|
|
use File::Spec::Functions qw(tmpdir catdir catfile); |
49 |
|
|
use vars qw(%LIST_CACHE %GRAPH_CACHE %SLURP_CACHE |
50 |
|
|
$CACHE_ROOT $CACHE $FRESHEN_CACHE %STALERRD_CACHE); |
51 |
|
|
|
52 |
|
|
# Enable some basic caching. |
53 |
|
|
# See notes about $tmpl_cache a little further |
54 |
|
|
# down in this code. |
55 |
|
|
if (CACHE) { |
56 |
|
|
# Cache calls to list_dir() and graph_def() |
57 |
|
|
require Memoize; |
58 |
|
|
Memoize::memoize('list_dir', LIST_CACHE => [HASH => \%LIST_CACHE]); |
59 |
|
|
Memoize::memoize('graph_def', SCALAR_CACHE => [HASH => \%GRAPH_CACHE]); |
60 |
|
|
Memoize::memoize('stale_rrd', SCALAR_CACHE => [HASH => \%STALERRD_CACHE]); |
61 |
|
|
|
62 |
|
|
# This isn't really necessary unless you're viewing the same page many |
63 |
|
|
# times over in defail view - i don't think that the extra memory utilisation |
64 |
|
|
# is worth the small improvement in rendering time. |
65 |
|
|
#Memoize::memoize('slurp', SCALAR_CACHE => [HASH => \%SLURP_CACHE]); |
66 |
|
|
|
67 |
|
|
# Try some caching on disk |
68 |
|
|
unless (defined($CACHE) && ref($CACHE)) { |
69 |
|
|
$CACHE_ROOT = catdir(tmpdir(), 'rrd-browse.cgi'); |
70 |
|
|
mkdir($CACHE_ROOT,0700) unless -d $CACHE_ROOT; |
71 |
|
|
eval { |
72 |
|
|
require Cache::File; |
73 |
|
|
$CACHE = Cache::File->new( |
74 |
|
|
cache_root => $CACHE_ROOT, |
75 |
|
|
default_expires => DEFAULT_EXPIRES |
76 |
|
|
); |
77 |
|
|
}; |
78 |
|
|
warn $@ if $@; |
79 |
|
|
}; |
80 |
|
|
} |
81 |
|
|
|
82 |
|
|
|
83 |
|
|
# Grab CGI paramaters |
84 |
|
|
my $cgi = new CGI; |
85 |
|
|
my %q = $cgi->Vars; |
86 |
|
|
my $cache_key = $cgi->self_url(-absolute => 1, -query_string => 1, -path_info => 1); |
87 |
|
|
|
88 |
|
|
# cd to the righr location and define directories |
89 |
|
|
my %dir = map { ( $_ => BASEDIR."/$_" ) } qw(data etc graphs cgi-bin thumbnails); |
90 |
|
|
chdir $dir{'cgi-bin'} || die sprintf("Unable to chdir to '%s': %s", $dir{'cgi-bin'}, $!); |
91 |
|
|
|
92 |
|
|
# Create the initial %tmpl data hash |
93 |
|
|
my %tmpl = %ENV; |
94 |
|
|
$tmpl{template} = defined $q{template} && -f $q{template} ? $q{template} : 'index.tmpl'; |
95 |
|
|
die "Uh uh uh! Who's a naughty boy?\n" if $tmpl{template} =~ /^\s*\// || $tmpl{template} =~ /\.\./ || $tmpl{template} !~ /\.tmpl$/i; |
96 |
|
|
$tmpl{PERIOD} = defined $q{PERIOD} && $q{PERIOD} =~ /^(daily|weekly|monthly|annual)$/i ? lc($q{PERIOD}) : 'daily'; |
97 |
|
|
$tmpl{title} = ucfirst(basename($tmpl{template},'.tmpl')); $tmpl{title} =~ s/[_\-]/ /g; |
98 |
|
|
$tmpl{self_url} = $cgi->self_url(-absolute => 1, -query_string => 0, -path_info => 0); |
99 |
|
|
$tmpl{rrd_url} = RRDURL; |
100 |
|
|
|
101 |
|
|
# Go read a bunch of stuff from disk to pump in to %tmpl in a moment |
102 |
|
|
my $gdefs = read_graph_data("$dir{etc}/graph.defs"); |
103 |
|
|
my @graphs = list_dir($dir{graphs}); |
104 |
|
|
# my @thumbnails = list_dir($dir{thumbnails}); # Not used anywhere |
105 |
|
|
|
106 |
|
|
|
107 |
|
|
# Build up the data in %tmpl by host |
108 |
|
|
# The $tmpl_cache structure could be cached in theory, but |
109 |
|
|
# the process of thawing actually uses LOTS of memory if |
110 |
|
|
# the source structure was quite sizable to start with. For |
111 |
|
|
# this reason, I'm *NOT* actually caching this structure |
112 |
|
|
# anymore, and am opting to cache the HTML output on a per |
113 |
|
|
# URL basis. This means there's less chance of a cache hit, |
114 |
|
|
# but it means you don't use 715MB of memory if you have |
115 |
|
|
# 100 or so servers with an average of 25 graphs per host. |
116 |
|
|
my $tmpl_cache = { |
117 |
|
|
graph_tmpl => {}, |
118 |
|
|
hosts => [], |
119 |
|
|
graphs => [], |
120 |
|
|
}; |
121 |
|
|
|
122 |
|
|
|
123 |
|
|
# Pull in the HTML cache (mentioned above) |
124 |
|
|
my $html = { last_update => 0, html => '' }; |
125 |
|
|
|
126 |
|
|
# Check if we should force an update on the cache |
127 |
|
|
if ($q{FRESHEN_CACHE}) { |
128 |
|
|
$FRESHEN_CACHE = 1 ; |
129 |
|
|
} |
130 |
|
|
|
131 |
|
|
# Check the mtimes of each directory for any modifications |
132 |
|
|
# and thereby a requirement to freshen our caches |
133 |
|
|
if (!defined($FRESHEN_CACHE) && !$FRESHEN_CACHE) { |
134 |
|
|
while (my ($k,$dir) = each %dir) { |
135 |
|
|
if (!defined $html->{last_update} || (stat($dir))[9] > $html->{last_update}) { |
136 |
|
|
$FRESHEN_CACHE = 1; |
137 |
|
|
warn "$k($dir) has been modified since the cache was last updated; forcing an update now\n"; |
138 |
|
|
} |
139 |
|
|
} |
140 |
|
|
} |
141 |
|
|
|
142 |
|
|
# Output from the cache if possible |
143 |
|
|
if (!$FRESHEN_CACHE) { |
144 |
|
|
eval { $html = $CACHE->thaw($cache_key); }; |
145 |
|
|
warn $@ if $@; |
146 |
|
|
if ($html->{html}) { |
147 |
|
|
#warn "Using cached version '$cache_key'\n"; |
148 |
|
|
$html->{html} =~ s/[ \t][ \t]+/ /g unless $q{DEBUG}; |
149 |
|
|
print $cgi->header(-content => 'text/html'), $html->{html}; |
150 |
|
|
exit; |
151 |
|
|
} |
152 |
|
|
} else { |
153 |
|
|
%LIST_CACHE = (); |
154 |
|
|
%GRAPH_CACHE = (); |
155 |
|
|
%STALERRD_CACHE = (); |
156 |
|
|
%SLURP_CACHE = (); |
157 |
|
|
} |
158 |
|
|
|
159 |
|
|
|
160 |
|
|
####################################### |
161 |
|
|
# |
162 |
|
|
# This section of code is REALLY slow and |
163 |
|
|
# ineffecient. A basic work around of caching |
164 |
|
|
# pages based on the URL has been implemented |
165 |
|
|
# to try and avoid having to execute this code |
166 |
|
|
# at all. This is a poor work around. I need |
167 |
|
|
# to optimise this code. If you have any |
168 |
|
|
# patches to help, please send them to |
169 |
|
|
# nicolaw@cpan.org. |
170 |
|
|
# |
171 |
|
|
####################################### |
172 |
|
|
for my $host (sort by_domain list_dir($dir{data})) { |
173 |
|
|
my $path = catfile($dir{data},$host); |
174 |
|
|
next unless -d $path || (-l $path && -d readlink($path)); |
175 |
|
|
|
176 |
|
|
# NEECHI-HACK! |
177 |
|
|
# This is removing some templating logic from the HTML::Template .tmpl file |
178 |
|
|
# themsevles and bringing it in to this loop in order to save a number of |
179 |
|
|
# loop cycles and speed up the pre-processing before we render the HTML. |
180 |
|
|
next if defined($q{HOST}) && $q{HOST} ne $host; |
181 |
|
|
next if defined($q{LIKE}) && $tmpl{template} =~ /^by_host\.[^\.]+$/i && $host !~ /$q{LIKE}/i; |
182 |
|
|
|
183 |
|
|
(my $node = $host) =~ s/\..*//; |
184 |
|
|
(my $domain = $host) =~ s/^.*?\.//; |
185 |
|
|
(my $domain2 = $domain) =~ s/[^a-zA-Z0-9\_]/_/g; |
186 |
|
|
(my $host2 = $host) =~ s/[^a-zA-Z0-9\_]/_/g; |
187 |
|
|
|
188 |
|
|
my %host = ( |
189 |
|
|
host => $host, |
190 |
|
|
host2 => $host2, |
191 |
|
|
node => $node, |
192 |
|
|
domain => $domain, |
193 |
|
|
domain2 => $domain2, |
194 |
|
|
); |
195 |
|
|
|
196 |
|
|
# Build a hash of potential files that users can slurp() or include |
197 |
|
|
# in their output template on a per host basis. |
198 |
|
|
for my $file (grep(/\.(?:te?xt|s?html?|xslt?|xml|css|tmpl)$/i, |
199 |
|
|
glob("$dir{data}/$host/include*.*"))) { |
200 |
|
|
(my $base = basename($file)) =~ s/\./_/g; |
201 |
|
|
$host{$base} = $file; |
202 |
|
|
} |
203 |
|
|
|
204 |
|
|
if (!grep(/^$host$/,@graphs)) { |
205 |
|
|
$host{no_graphs} = 1; |
206 |
|
|
push @{$tmpl_cache->{hosts}}, \%host; |
207 |
|
|
|
208 |
|
|
} else { |
209 |
|
|
my $all_host_rrds_stale = 1; |
210 |
|
|
|
211 |
|
|
for (qw(thumbnails graphs)) { |
212 |
|
|
eval { |
213 |
|
|
my @ary = (); |
214 |
|
|
for my $img (sort alpha_period |
215 |
|
|
grep(/\.(png|jpe?g|gif)$/i,list_dir("$dir{$_}/$host"))) { |
216 |
|
|
my ($graph) = ($img =~ /^(.+)\-\w+\.\w+$/); |
217 |
|
|
|
218 |
|
|
# NEECHI-HACK! |
219 |
|
|
# This is another nasty hack that removed some of the logic from the |
220 |
|
|
# HTML::Template code by pre-excluding specific data from the template |
221 |
|
|
# data and thereby speeding up the rendering of the HTML. |
222 |
|
|
next if defined($q{GRAPH}) && $q{GRAPH} ne $graph; |
223 |
|
|
next if defined($q{LIKE}) |
224 |
|
|
&& $tmpl{template} =~ /^by_graph\.[^\.]+$/i |
225 |
|
|
&& $graph !~ /$q{LIKE}/i; |
226 |
|
|
|
227 |
|
|
my %hash = ( |
228 |
|
|
src => "$tmpl{rrd_url}/$_/$host/$img", |
229 |
|
|
period => ($img =~ /.*-(\w+)\.\w+$/), |
230 |
|
|
graph => $graph, |
231 |
|
|
); |
232 |
|
|
|
233 |
|
|
my $gdef = graph_def($gdefs,$hash{graph}); |
234 |
|
|
$hash{title} = defined $gdef->{title} ? $gdef->{title} : $hash{graph}; |
235 |
|
|
|
236 |
|
|
# Is the RRD file that generated this image considered stale? |
237 |
|
|
my ($stale, $last_modified) = stale_rrd(catfile($dir{data},$host,"$graph.rrd")); |
238 |
|
|
if (defined($stale) && $stale) { |
239 |
|
|
$hash{stale} = $last_modified; |
240 |
|
|
} else { |
241 |
|
|
$all_host_rrds_stale = 0; |
242 |
|
|
} |
243 |
|
|
|
244 |
|
|
# Include the path on disk to the .txt file that is generated by the |
245 |
|
|
# output of the RRD::Simple->graph() method while generating the graphs |
246 |
|
|
$hash{txt} = catfile($dir{graphs},$host,"$img.txt") |
247 |
|
|
if $_ eq 'graphs' |
248 |
|
|
&& -e catfile($dir{graphs},$host,"$img.txt") |
249 |
|
|
&& (stat(_))[7] > 5; |
250 |
|
|
|
251 |
|
|
push @ary, \%hash; |
252 |
|
|
|
253 |
|
|
# By graph later |
254 |
|
|
if ($_ eq 'thumbnails' && defined $hash{graph}) { |
255 |
|
|
# && defined $hash{period} && $hash{period} eq 'daily') { |
256 |
|
|
my %hash2 = %hash; |
257 |
|
|
delete $hash2{title}; |
258 |
|
|
$hash2{host} = $host; |
259 |
|
|
if (defined $hash{period} && $hash{period} eq 'daily') { |
260 |
|
|
$tmpl_cache->{hosts_per_graph}->{$hash{graph}} = 0 |
261 |
|
|
unless defined $tmpl_cache->{hosts_per_graph}->{$hash{graph}}; |
262 |
|
|
$tmpl_cache->{hosts_per_graph}->{$hash{graph}}++; |
263 |
|
|
} |
264 |
|
|
push @{$tmpl_cache->{graph_tmpl}->{"$hash{graph}\t$hash{title}"}}, \%hash2; |
265 |
|
|
} |
266 |
|
|
} |
267 |
|
|
$host{$_} = \@ary; |
268 |
|
|
}; |
269 |
|
|
warn $@ if $@; |
270 |
|
|
} |
271 |
|
|
|
272 |
|
|
if ($all_host_rrds_stale) { |
273 |
|
|
$host{stale} = 1; |
274 |
|
|
} |
275 |
|
|
$host{total_graphs} = grep(/^daily$/, map { $_->{period} } @{$host{graphs}}); |
276 |
|
|
push @{$tmpl_cache->{hosts}}, \%host; |
277 |
|
|
} |
278 |
|
|
} |
279 |
|
|
|
280 |
|
|
# Merge cache data in |
281 |
|
|
$tmpl{hosts} = $tmpl_cache->{hosts}; |
282 |
|
|
|
283 |
|
|
# Merge by-graph cache data in |
284 |
|
|
for (sort keys %{$tmpl_cache->{graph_tmpl}}) { |
285 |
|
|
my ($graph,$title) = split(/\t/,$_); |
286 |
|
|
push @{$tmpl{graphs}}, { |
287 |
|
|
graph => $graph, |
288 |
|
|
graph_title => $title, |
289 |
|
|
total_hosts => $tmpl_cache->{hosts_per_graph}->{$graph}, |
290 |
|
|
thumbnails => $tmpl_cache->{graph_tmpl}->{$_}, |
291 |
|
|
}; |
292 |
|
|
} |
293 |
|
|
|
294 |
|
|
# Render the output |
295 |
|
|
if (exists $q{DEBUG} && $q{DEBUG} eq 'insecure') { |
296 |
|
|
require Data::Dumper; |
297 |
|
|
$tmpl{DEBUG} = Data::Dumper::Dumper(\%tmpl); |
298 |
|
|
} |
299 |
|
|
my $template = HTML::Template::Expr->new( |
300 |
|
|
filename => $tmpl{template}, |
301 |
|
|
|
302 |
|
|
# This caching doesn't work properly with |
303 |
|
|
# HTML::Template::Expr |
304 |
|
|
#cache => 1, |
305 |
|
|
#shared_cache => 1, |
306 |
|
|
#file_cache => 1, |
307 |
|
|
#file_cache_dir => $CACHE_ROOT, |
308 |
|
|
#file_cache_dir_mode => 0700, |
309 |
|
|
|
310 |
|
|
associate => $cgi, |
311 |
|
|
case_sensitive => 1, |
312 |
|
|
loop_context_vars => 1, |
313 |
|
|
max_includes => 5, |
314 |
|
|
global_vars => 1, |
315 |
|
|
die_on_bad_params => 0, |
316 |
|
|
functions => { |
317 |
|
|
slurp => \&slurp, |
318 |
dpavlin |
4 |
table => \&table, |
319 |
dpavlin |
1 |
like => sub { return defined($_[0]) && defined($_[1]) && $_[0] =~ /$_[1]/i ? 1 : 0; }, |
320 |
|
|
not => sub { return !$_[0]; }, |
321 |
|
|
equal_or_like => sub { |
322 |
|
|
return 1 if (!defined($_[1]) || !length($_[1])) && (!defined($_[2]) || !length($_[2])); |
323 |
|
|
#(warn "$_[0] eq $_[1]\n" && return 1) if defined $_[1] && "$_[0]" eq "$_[1]"; |
324 |
|
|
(return 1) if defined $_[1] && "$_[0]" eq "$_[1]"; |
325 |
|
|
return 1 if defined $_[2] && "$_[0]" =~ /$_[2]/; |
326 |
|
|
return 0; |
327 |
|
|
}, |
328 |
|
|
}, |
329 |
|
|
); |
330 |
|
|
$template->param(\%tmpl); |
331 |
|
|
|
332 |
|
|
$html->{html} = $template->output(); |
333 |
|
|
$html->{html} =~ s/[ \t][ \t]+/ /g unless $q{DEBUG}; |
334 |
|
|
$html->{last_update} = time; |
335 |
|
|
eval { $CACHE->freeze($cache_key, $html); }; |
336 |
|
|
warn $@ if $@; |
337 |
|
|
print $cgi->header(-content => 'text/html'), $html->{html}; |
338 |
|
|
|
339 |
|
|
exit; |
340 |
|
|
|
341 |
|
|
|
342 |
|
|
# Is the RRD file that generated this image considered stale? |
343 |
|
|
sub stale_rrd { |
344 |
|
|
my $rrd_file = shift; |
345 |
|
|
return unless defined $rrd_file && $rrd_file; |
346 |
|
|
my $rrd_mtime = (stat($rrd_file))[9]; |
347 |
|
|
|
348 |
|
|
if (defined(wantarray)) { |
349 |
|
|
my $modified = scalar(localtime($rrd_mtime)); |
350 |
|
|
if (wantarray) { |
351 |
|
|
return (1, $modified) if time - $rrd_mtime >= STALE_THRESHOLD; |
352 |
|
|
return (0, $modified); |
353 |
|
|
} else { |
354 |
|
|
return 1 if time - $rrd_mtime >= STALE_THRESHOLD; |
355 |
|
|
return 0; |
356 |
|
|
} |
357 |
|
|
} |
358 |
|
|
|
359 |
|
|
return; |
360 |
|
|
} |
361 |
|
|
|
362 |
|
|
# Slurp in a file from disk, yum yum |
363 |
|
|
sub slurp { |
364 |
|
|
my $rtn = $_[0]; |
365 |
|
|
if (open(FH,'<',$_[0])) { |
366 |
|
|
local $/ = undef; |
367 |
|
|
$rtn = <FH>; |
368 |
|
|
close(FH); |
369 |
|
|
} |
370 |
|
|
return $rtn; |
371 |
|
|
} |
372 |
|
|
|
373 |
dpavlin |
4 |
sub table { |
374 |
|
|
my $file = shift; |
375 |
|
|
my @rows = split(/[\n\r]+/, slurp($file)); |
376 |
|
|
use Data::Dump qw/dump/; |
377 |
|
|
warn dump( @rows ); |
378 |
|
|
return |
379 |
|
|
qq|<tr><th colspan=4>| . shift(@rows) . qq|</th><tr>| |
380 |
|
|
. qq|<tr><th></th><th>min</th><th>max</th><th>last</th></tr>| |
381 |
|
|
. join("\n", map { |
382 |
|
|
qq|<tr><td>| |
383 |
|
|
. join(qq|</td><td align=right>|, split(/,?\s+\w+:\s+/, $_)) |
384 |
|
|
. qq|</tr><td>| |
385 |
|
|
} @rows |
386 |
|
|
) |
387 |
|
|
; |
388 |
|
|
} |
389 |
|
|
|
390 |
dpavlin |
1 |
# Sort by domain |
391 |
|
|
sub by_domain { |
392 |
|
|
sub split_domain { |
393 |
|
|
local $_ = shift || ''; |
394 |
|
|
if (/(.*)\.(\w\w\w+)$/) { |
395 |
|
|
return ($2,$1); |
396 |
|
|
} elsif (/(.*)\.(\w+\.\w\w)$/) { |
397 |
|
|
return ($2,$1); |
398 |
|
|
} |
399 |
|
|
return ($_,''); |
400 |
|
|
} |
401 |
|
|
my @A = split_domain($a); |
402 |
|
|
my @B = split_domain($b); |
403 |
|
|
|
404 |
|
|
($A[0] cmp $B[0]) |
405 |
|
|
|| |
406 |
|
|
($A[1] cmp $B[1]) |
407 |
|
|
} |
408 |
|
|
|
409 |
|
|
# Sort by time period |
410 |
|
|
sub alpha_period { |
411 |
|
|
my %order = qw(daily 0 weekly 1 monthly 2 annual 3 3year 4); |
412 |
|
|
($a =~ /^(.+)\-/)[0] cmp ($b =~ /^(.+)\-/)[0] |
413 |
|
|
|| |
414 |
|
|
$order{($a =~ /^.+\-(\w+)\./)[0]} <=> $order{($b =~ /^.+\-(\w+)\./)[0]} |
415 |
|
|
} |
416 |
|
|
|
417 |
|
|
# Return a list of items in a directory |
418 |
|
|
sub list_dir { |
419 |
|
|
my $dir = shift; |
420 |
|
|
opendir(DH,$dir) || die "Unable to open file handle for directory '$dir': $!"; |
421 |
|
|
my @items = grep(!/^\./,readdir(DH)); |
422 |
|
|
closedir(DH) || die "Unable to close file handle for directory '$dir': $!"; |
423 |
|
|
return @items; |
424 |
|
|
} |
425 |
|
|
|
426 |
|
|
# Pull out the most relevent graph definition |
427 |
|
|
sub graph_def { |
428 |
|
|
my ($gdefs,$graph) = @_; |
429 |
|
|
return {} unless defined $graph; |
430 |
|
|
|
431 |
|
|
my $rtn = {}; |
432 |
|
|
for (keys %{$gdefs->{graph}}) { |
433 |
|
|
my $graph_key = qr(^$_$); |
434 |
|
|
if ($graph =~ /$graph_key/) { |
435 |
|
|
$rtn = { %{$gdefs->{graph}->{$_}} }; |
436 |
|
|
my ($var) = $graph =~ /_([^_]+)$/; |
437 |
|
|
for my $key (keys %{$rtn}) { |
438 |
|
|
$rtn->{$key} =~ s/\$1/$var/g; |
439 |
|
|
} |
440 |
|
|
last; |
441 |
|
|
} |
442 |
|
|
} |
443 |
|
|
|
444 |
|
|
return $rtn; |
445 |
|
|
} |
446 |
|
|
|
447 |
|
|
# Read in the graph definition config file |
448 |
|
|
sub read_graph_data { |
449 |
|
|
my $filename = shift || undef; |
450 |
|
|
|
451 |
|
|
my %config = (); |
452 |
|
|
eval { |
453 |
|
|
my $conf = new Config::General( |
454 |
|
|
-ConfigFile => $filename, |
455 |
|
|
-LowerCaseNames => 1, |
456 |
|
|
-UseApacheInclude => 1, |
457 |
|
|
-IncludeRelative => 1, |
458 |
|
|
# -DefaultConfig => \%default, |
459 |
|
|
-MergeDuplicateBlocks => 1, |
460 |
|
|
-AllowMultiOptions => 1, |
461 |
|
|
-MergeDuplicateOptions => 1, |
462 |
|
|
-AutoTrue => 1, |
463 |
|
|
); |
464 |
|
|
%config = $conf->getall; |
465 |
|
|
}; |
466 |
|
|
warn $@ if $@; |
467 |
|
|
|
468 |
|
|
return \%config; |
469 |
|
|
} |
470 |
|
|
|
471 |
|
|
1; |
472 |
|
|
|
473 |
|
|
|