1 # Copyright (C) 2002-2007 Stanislav Sinyagin
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with this program; if not, write to the Free Software
15 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
17 # $Id: ConfigTree.pm,v 1.1 2010-12-27 00:03:41 ivan Exp $
18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
21 package Torrus::ConfigTree;
25 use Torrus::TimeStamp;
38 $self->{'treename'} = $options{'-TreeName'};
39 die('ERROR: TreeName is mandatory') if not $self->{'treename'};
41 $self->{'db_config_instances'} =
42 new Torrus::DB( 'config_instances', -WriteAccess => 1 );
43 defined( $self->{'db_config_instances'} ) or return( undef );
45 my $i = $self->{'db_config_instances'}->get('ds:' . $self->{'treename'});
49 $self->{'first_time_created'} = 1;
52 my $dsConfInstance = sprintf( '%d', $i );
54 $i = $self->{'db_config_instances'}->get('other:' . $self->{'treename'});
55 $i = 0 unless defined( $i );
57 my $otherConfInstance = sprintf( '%d', $i );
59 if( $options{'-WriteAccess'} )
61 $self->{'is_writing'} = 1;
63 # Acquire exlusive lock on the database and set the compiling flag
66 my $key = 'compiling:' . $self->{'treename'};
67 my $cursor = $self->{'db_config_instances'}->cursor( -Write => 1 );
69 $self->{'db_config_instances'}->c_get( $cursor, $key );
72 if( $options{'-ForceWriter'} )
74 Warn('Another compiler process is probably still ' .
75 'running. This may lead to an unusable ' .
80 Error('Another compiler is running for the tree ' .
87 $self->{'db_config_instances'}->c_put( $cursor, $key, 1 );
94 $self->{'iam_writer'} = 1;
97 if( not $options{'-NoDSRebuild'} )
99 $dsConfInstance = sprintf( '%d', ( $dsConfInstance + 1 ) % 2 );
101 $otherConfInstance = sprintf( '%d', ( $otherConfInstance + 1 ) % 2 );
104 $self->{'ds_config_instance'} = $dsConfInstance;
105 $self->{'other_config_instance'} = $otherConfInstance;
107 $self->{'db_readers'} = new Torrus::DB('config_readers',
108 -Subdir => $self->{'treename'},
110 defined( $self->{'db_readers'} ) or return( undef );
112 $self->{'db_dsconfig'} =
113 new Torrus::DB('ds_config_' . $dsConfInstance,
114 -Subdir => $self->{'treename'}, -Btree => 1,
115 -WriteAccess => $options{'-WriteAccess'});
116 defined( $self->{'db_dsconfig'} ) or return( undef );
118 $self->{'db_otherconfig'} =
119 new Torrus::DB('other_config_' . $otherConfInstance,
120 -Subdir => $self->{'treename'}, -Btree => 1,
121 -WriteAccess => $options{'-WriteAccess'});
122 defined( $self->{'db_otherconfig'} ) or return( undef );
124 $self->{'db_aliases'} =
125 new Torrus::DB('aliases_' . $dsConfInstance,
126 -Subdir => $self->{'treename'}, -Btree => 1,
127 -WriteAccess => $options{'-WriteAccess'});
128 defined( $self->{'db_aliases'} ) or return( undef );
130 if( $options{'-WriteAccess'} )
133 $self->waitReaders();
135 if( $options{'-Rebuild'} )
137 $self->{'db_otherconfig'}->trunc();
138 if( not $options{'-NoDSRebuild'} )
140 $self->{'db_dsconfig'}->trunc();
141 $self->{'db_aliases'}->trunc();
149 if( not $self->isReady() )
151 if( $options{'-Wait'} )
153 Warn('Configuration is not ready');
156 time() + $Torrus::Global::ConfigReadyTimeout;
159 while( not $success and time() < $waitingTimeout )
161 $self->clearReader();
164 $Torrus::Global::ConfigReadyRetryPeriod .
166 sleep $Torrus::Global::ConfigReadyRetryPeriod;
170 if( $self->isReady() )
173 Info('Now configuration is ready');
177 Info('Configuration is still not ready');
182 Error('Configuration wait timed out');
183 $self->clearReader();
189 Error('Configuration is not ready');
190 $self->clearReader();
196 # Read the parameter properties into memory
197 $self->{'db_paramprops'} =
198 new Torrus::DB('paramprops_' . $dsConfInstance,
199 -Subdir => $self->{'treename'}, -Btree => 1,
200 -WriteAccess => $options{'-WriteAccess'});
201 defined( $self->{'db_paramprops'} ) or return( undef );
203 if( $options{'-Rebuild'} )
205 $self->{'db_paramprops'}->trunc();
209 my $cursor = $self->{'db_paramprops'}->cursor();
210 while( my ($key, $val) =
211 $self->{'db_paramprops'}->next( $cursor ) )
213 my( $param, $prop ) = split( /:/o, $key );
214 $self->{'paramprop'}{$prop}{$param} = $val;
217 $self->{'db_paramprops'}->closeNow();
218 delete $self->{'db_paramprops'};
223 new Torrus::DB('tokensets_' . $dsConfInstance,
224 -Subdir => $self->{'treename'}, -Btree => 0,
225 -WriteAccess => 1, -Truncate => $options{'-Rebuild'});
226 defined( $self->{'db_sets'} ) or return( undef );
229 $self->{'db_nodepcache'} =
230 new Torrus::DB('nodepcache_' . $dsConfInstance,
231 -Subdir => $self->{'treename'}, -Btree => 1,
233 -Truncate => ($options{'-Rebuild'} and
234 not $options{'-NoDSRebuild'}));
235 defined( $self->{'db_nodepcache'} ) or return( undef );
238 $self->{'db_nodeid'} =
239 new Torrus::DB('nodeid_' . $dsConfInstance,
240 -Subdir => $self->{'treename'}, -Btree => 1,
242 -Truncate => ($options{'-Rebuild'} and
243 not $options{'-NoDSRebuild'}));
244 defined( $self->{'db_nodeid'} ) or return( undef );
254 Debug('Destroying ConfigTree object');
256 if( $self->{'iam_writer'} )
258 # Acquire exlusive lock on the database and clear the compiling flag
259 my $cursor = $self->{'db_config_instances'}->cursor( -Write => 1 );
260 $self->{'db_config_instances'}->c_put
261 ( $cursor, 'compiling:' . $self->{'treename'}, 0 );
266 $self->clearReader();
269 undef $self->{'db_dsconfig'};
270 undef $self->{'db_otherconfig'};
271 undef $self->{'db_aliases'};
272 undef $self->{'db_sets'};
273 undef $self->{'db_nodepcache'};
274 undef $self->{'db_readers'};
277 # Manage the readinness flag
283 $self->{'db_otherconfig'}->put( 'ConfigurationReady', $ready ? 1:0 );
289 return $self->{'db_otherconfig'}->get( 'ConfigurationReady' );
292 # Manage the readers database
298 my $readerId = 'pid=' . $$ . ',rand=' . sprintf('%.10d', rand(1e9));
299 Debug('Setting up reader: ' . $readerId);
300 $self->{'reader_id'} = $readerId;
301 $self->{'db_readers'}->put( $readerId,
304 $self->{'ds_config_instance'},
305 $self->{'other_config_instance'}) );
312 if( defined( $self->{'reader_id'} ) )
314 Debug('Clearing reader: ' . $self->{'reader_id'});
315 $self->{'db_readers'}->del( $self->{'reader_id'} );
316 delete $self->{'reader_id'};
325 # Let the active readers finish their job
327 while( not $noReaders )
330 my $cursor = $self->{'db_readers'}->cursor();
331 while( my ($key, $val) = $self->{'db_readers'}->next( $cursor ) )
333 my( $timestamp, $dsInst, $otherInst ) = split( /:/o, $val );
334 if( $dsInst == $self->{'ds_config_instance'} or
335 $otherInst == $self->{'other_config_instance'} )
339 'timestamp' => $timestamp } );
345 Info('Waiting for ' . scalar(@readers) . ' readers:');
347 foreach my $reader ( @readers )
349 Info($reader->{'reader'} . ', timestamp: ' .
350 localtime( $reader->{'timestamp'} ));
351 if( $reader->{'timestamp'} > $recentTS )
353 $recentTS = $reader->{'timestamp'};
356 if( $recentTS + $Torrus::Global::ConfigReadersWaitTimeout >=
359 Info('Sleeping ' . $Torrus::Global::ConfigReadersWaitPeriod .
361 sleep( $Torrus::Global::ConfigReadersWaitPeriod );
365 # the readers are too long active. we ignore them now
366 Warn('Readers wait timed out. Flushing the readers list for ' .
367 'DS config instance ' . $self->{'ds_config_instance'} .
368 ' and Other config instance ' .
369 $self->{'other_config_instance'});
371 my $cursor = $self->{'db_readers'}->cursor( -Write => 1 );
372 while( my ($key, $val) =
373 $self->{'db_readers'}->next( $cursor ) )
375 my( $timestamp, $dsInst, $otherInst ) =
377 if( $dsInst == $self->{'ds_config_instance'} or
378 $otherInst == $self->{'other_config_instance'} )
380 $self->{'db_readers'}->c_del( $cursor );
396 # This should be called after Torrus::TimeStamp::init();
401 return Torrus::TimeStamp::get($self->{'treename'} . ':configuration');
407 return $self->{'treename'};
411 # Returns array with path components
418 while( length($path) > 0 )
421 $path =~ s/^([^\/]*\/?)//o; $node = $1;
431 $path =~ s/.*\/([^\/]+)\/?$/$1/o;
440 my $token = $self->{'db_dsconfig'}->get( 'pt:'.$path );
441 if( not defined( $token ) )
443 my $prefixLen = 1; # the leading slash is anyway there
444 my $pathLen = length( $path );
445 while( not defined( $token ) and $prefixLen < $pathLen )
447 my $result = $self->{'db_aliases'}->getBestMatch( $path );
448 if( not defined( $result ) )
450 $prefixLen = $pathLen; # exit the loop
454 # Found a partial match
455 $prefixLen = length( $result->{'key'} );
456 my $aliasTarget = $self->path( $result->{'value'} );
457 $path = $aliasTarget . substr( $path, $prefixLen );
458 $token = $self->{'db_dsconfig'}->get( 'pt:'.$path );
469 return $self->{'db_dsconfig'}->get( 'tp:'.$token );
477 return defined( $self->{'db_dsconfig'}->get( 'pt:'.$path ) );
486 my $type = $self->{'nodetype_cache'}{$token};
487 if( not defined( $type ) )
489 $type = $self->{'db_dsconfig'}->get( 'n:'.$token );
490 $self->{'nodetype_cache'}{$token} = $type;
501 return ( $self->nodeType($token) == 1 );
510 return( $self->nodeType($token) == 0 );
513 # Returns the real token or undef
519 return( ( $self->nodeType($token) == 2 ) ?
520 $self->{'db_dsconfig'}->get( 'a:'.$token ) : undef );
523 # Returns the list of tokens pointing to this one as an alias
529 return $self->{'db_dsconfig'}->getListItems('ar:'.$token);
540 if( exists( $self->{'paramcache'}{$name}{$param} ) )
542 return $self->{'paramcache'}{$name}{$param};
546 my $db = $fromDS ? $self->{'db_dsconfig'} : $self->{'db_otherconfig'};
547 my $val = $db->get( 'P:'.$name.':'.$param );
548 $self->{'paramcache'}{$name}{$param} = $val;
553 sub retrieveNodeParam
559 # walk up the tree and save the grandparent's value at parent's cache
562 my $currtoken = $token;
566 while( not defined($value) and defined($currtoken) )
568 $value = $self->getParam( $currtoken, $param, 1 );
569 if( not defined $value )
573 push( @ancestors, $currtoken );
579 # walk up to the parent
580 $currtoken = $self->getParent($currtoken);
584 foreach my $ancestor ( @ancestors )
586 $self->{'paramcache'}{$ancestor}{$param} = $value;
589 return $self->expandNodeParam( $token, $param, $value );
600 # %parameter_substitutions% in ds-path-* in multigraph leaves
601 # are expanded by the Writer post-processing
602 if( defined $value and $self->getParamProperty( $param, 'expand' ) )
604 $value = $self->expandSubstitutions( $token, $param, $value );
610 sub expandSubstitutions
620 while( $changed and $ok )
624 # Substitute definitions
625 if( index($value, '$') >= 0 )
627 if( not $value =~ /\$(\w+)/o )
629 my $path = $self->path($token);
630 Error("Incorrect definition reference: $value in $path");
636 my $dvalue = $self->getDefinition($dname);
637 if( not defined( $dvalue ) )
639 my $path = $self->path($token);
640 Error("Cannot find definition $dname in $path");
645 $value =~ s/\$$dname/$dvalue/g;
651 # Substitute parameter references
652 if( index($value, '%') >= 0 and $ok )
654 if( not $value =~ /\%([a-zA-Z0-9\-_]+)\%/o )
656 Error("Incorrect parameter reference: $value");
662 my $pval = $self->getNodeParam( $token, $pname );
664 if( not defined( $pval ) )
666 my $path = $self->path($token);
667 Error("Cannot expand parameter reference %".
668 $pname."% in ".$path);
673 $value =~ s/\%$pname\%/$pval/g;
680 if( ref( $Torrus::ConfigTree::nodeParamHook ) )
682 $value = &{$Torrus::ConfigTree::nodeParamHook}( $self, $token,
700 $value = $self->getParam( $token, $param, 1 );
701 return $self->expandNodeParam( $token, $param, $value );
704 if( $self->{'is_writing'} )
706 return $self->retrieveNodeParam( $token, $param );
709 my $cachekey = $token.':'.$param;
710 my $cacheval = $self->{'db_nodepcache'}->get( $cachekey );
711 if( defined( $cacheval ) )
713 my $status = substr( $cacheval, 0, 1 );
720 return substr( $cacheval, 1 );
724 $value = $self->retrieveNodeParam( $token, $param );
726 if( defined( $value ) )
728 $self->{'db_nodepcache'}->put( $cachekey, 'D'.$value );
732 $self->{'db_nodepcache'}->put( $cachekey, 'U' );
745 my $db = $fromDS ? $self->{'db_dsconfig'} : $self->{'db_otherconfig'};
747 return $db->getListItems('Pl:'.$name);
758 foreach my $param ( $self->getParamNames( $name, $fromDS ) )
760 $ret->{$param} = $self->getParam( $name, $param, $fromDS );
769 if( exists( $self->{'parentcache'}{$token} ) )
771 return $self->{'parentcache'}{$token};
775 my $parent = $self->{'db_dsconfig'}->get( 'p:'.$token );
776 $self->{'parentcache'}{$token} = $parent;
787 if( (my $alias = $self->isAlias($token)) )
789 return $self->getChildren($alias);
793 return $self->{'db_dsconfig'}->getListItems( 'c:'.$token );
803 return $self->{'paramprop'}{$prop}{$param};
807 sub getParamProperties
811 return $self->{'paramprop'};
814 # Recognize the regexp patterns within a path,
815 # like /Netflow/Exporters/.*/.*/bps.
816 # Each pattern is applied against direct child names only.
818 sub getNodesByPattern
823 if( $pattern !~ /^\//o )
825 Error("Incorrect pattern: $pattern");
830 foreach my $nodepattern ( $self->splitPath($pattern) )
832 my @next_retlist = ();
834 # Cut the trailing slash, if any
835 my $patternname = $nodepattern;
836 $patternname =~ s/\/$//o;
838 if( $patternname =~ /\W/o )
840 foreach my $candidate ( @retlist )
842 # This is a pattern, let's get all matching children
843 foreach my $child ( $self->getChildren( $candidate ) )
845 # Cut the trailing slash and leading path
846 my $childname = $self->path($child);
847 $childname =~ s/\/$//o;
848 $childname =~ s/.*\/([^\/]+)$/$1/o;
849 if( $childname =~ $patternname )
851 push( @next_retlist, $child );
857 elsif( length($patternname) == 0 )
859 @next_retlist = ( $self->token('/') );
863 foreach my $candidate ( @retlist )
865 my $proposal = $self->path($candidate).$nodepattern;
866 if( defined( my $proptoken = $self->token($proposal) ) )
868 push( @next_retlist, $proptoken );
872 @retlist = @next_retlist;
878 # Recognizes absolute or relative path, '..' as the parent subtree
886 if( $relPath =~ /^\//o )
888 return $self->token( $relPath );
892 if( length( $relPath ) > 0 )
894 $token = $self->getParent( $token );
897 while( length( $relPath ) > 0 )
899 if( $relPath =~ /^\.\.\//o )
901 $relPath =~ s/^\.\.\///o;
902 if( $token ne $self->token('/') )
904 $token = $self->getParent( $token );
910 $relPath =~ s/^([^\/]*\/?)//o; $childName = $1;
911 my $path = $self->path( $token );
912 $token = $self->token( $path . $childName );
913 if( not defined $token )
929 return $self->{'db_nodeid'}->get( $nodeid );
932 # Returns arrayref or undef.
933 # Each element is an arrayref to [nodeid, token] pair
934 sub searchNodeidPrefix
939 return $self->{'db_nodeid'}->searchPrefix( $prefix );
943 # Returns arrayref or undef.
944 # Each element is an arrayref to [nodeid, token] pair
945 sub searchNodeidSubstring
948 my $substring = shift;
950 return $self->{'db_nodeid'}->searchSubstring( $substring );
961 if( $self->isTset($token) )
965 $view = $self->getParam('SS', 'default-tsetlist-view');
969 $view = $self->getParam($token, 'default-tset-view');
970 if( not defined( $view ) )
972 $view = $self->getParam('SS', 'default-tset-view');
976 elsif( $self->isSubtree($token) )
978 $view = $self->getNodeParam($token, 'default-subtree-view');
983 $view = $self->getNodeParam($token, 'default-leaf-view');
986 if( not defined( $view ) )
988 Error("Cannot find default view for $token");
1001 if( $type eq 'node' )
1003 return $self->getNodeParam($name, $param);
1007 return $self->getParam($name, $param);
1015 return $self->{'db_otherconfig'}->getListItems( 'V:' );
1023 return $self->searchOtherList('V:', $vname);
1030 return $self->{'db_otherconfig'}->getListItems( 'M:' );
1037 return $self->searchOtherList('M:', $mname);
1044 return $self->{'db_otherconfig'}->getListItems( 'A:' );
1052 return $self->searchOtherList('A:', $mname);
1056 # Search for a value in comma-separated list
1063 return $self->{'db_otherconfig'}->searchList($key, $name);
1066 # Token sets manipulation
1072 return substr($token, 0, 1) eq 'S';
1079 $self->{'db_sets'}->addToList('S:', $tset);
1087 return $self->{'db_sets'}->searchList('S:', $tset);
1093 return $self->{'db_sets'}->getListItems('S:');
1101 return $self->{'db_sets'}->getListItems('s:'.$tset);
1104 sub tsetMemberOrigin
1110 return $self->{'db_sets'}->get('o:'.$tset.':'.$token);
1120 $self->{'db_sets'}->addToList('s:'.$tset, $token);
1121 $self->{'db_sets'}->put('o:'.$tset.':'.$token, $origin);
1131 $self->{'db_sets'}->delFromList('s:'.$tset, $token);
1132 $self->{'db_sets'}->del('o:'.$tset.':'.$token);
1135 # Definitions manipulation
1141 return $self->{'db_dsconfig'}->get( 'd:'.$name );
1144 sub getDefinitionNames
1147 return $self->{'db_dsconfig'}->getListItems( 'D:' );
1156 # indent-tabs-mode: nil
1157 # perl-indent-level: 4