--- /dev/null
+# Copyright (C) 2002-2007 Stanislav Sinyagin
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+# $Id: ConfigTree.pm,v 1.1 2010-12-27 00:03:41 ivan Exp $
+# Stanislav Sinyagin <ssinyagin@yahoo.com>
+
+
+package Torrus::ConfigTree;
+
+use Torrus::DB;
+use Torrus::Log;
+use Torrus::TimeStamp;
+
+use strict;
+
+
+
+sub new
+{
+ my $self = {};
+ my $class = shift;
+ my %options = @_;
+ bless $self, $class;
+
+ $self->{'treename'} = $options{'-TreeName'};
+ die('ERROR: TreeName is mandatory') if not $self->{'treename'};
+
+ $self->{'db_config_instances'} =
+ new Torrus::DB( 'config_instances', -WriteAccess => 1 );
+ defined( $self->{'db_config_instances'} ) or return( undef );
+
+ my $i = $self->{'db_config_instances'}->get('ds:' . $self->{'treename'});
+ if( not defined($i) )
+ {
+ $i = 0;
+ $self->{'first_time_created'} = 1;
+ }
+
+ my $dsConfInstance = sprintf( '%d', $i );
+
+ $i = $self->{'db_config_instances'}->get('other:' . $self->{'treename'});
+ $i = 0 unless defined( $i );
+
+ my $otherConfInstance = sprintf( '%d', $i );
+
+ if( $options{'-WriteAccess'} )
+ {
+ $self->{'is_writing'} = 1;
+
+ # Acquire exlusive lock on the database and set the compiling flag
+ {
+ my $ok = 1;
+ my $key = 'compiling:' . $self->{'treename'};
+ my $cursor = $self->{'db_config_instances'}->cursor( -Write => 1 );
+ my $compilingFlag =
+ $self->{'db_config_instances'}->c_get( $cursor, $key );
+ if( $compilingFlag )
+ {
+ if( $options{'-ForceWriter'} )
+ {
+ Warn('Another compiler process is probably still ' .
+ 'running. This may lead to an unusable ' .
+ 'database state');
+ }
+ else
+ {
+ Error('Another compiler is running for the tree ' .
+ $self->{'treename'});
+ $ok = 0;
+ }
+ }
+ else
+ {
+ $self->{'db_config_instances'}->c_put( $cursor, $key, 1 );
+ }
+ undef $cursor;
+ if( not $ok )
+ {
+ return undef;
+ }
+ $self->{'iam_writer'} = 1;
+ }
+
+ if( not $options{'-NoDSRebuild'} )
+ {
+ $dsConfInstance = sprintf( '%d', ( $dsConfInstance + 1 ) % 2 );
+ }
+ $otherConfInstance = sprintf( '%d', ( $otherConfInstance + 1 ) % 2 );
+ }
+
+ $self->{'ds_config_instance'} = $dsConfInstance;
+ $self->{'other_config_instance'} = $otherConfInstance;
+
+ $self->{'db_readers'} = new Torrus::DB('config_readers',
+ -Subdir => $self->{'treename'},
+ -WriteAccess => 1 );
+ defined( $self->{'db_readers'} ) or return( undef );
+
+ $self->{'db_dsconfig'} =
+ new Torrus::DB('ds_config_' . $dsConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 1,
+ -WriteAccess => $options{'-WriteAccess'});
+ defined( $self->{'db_dsconfig'} ) or return( undef );
+
+ $self->{'db_otherconfig'} =
+ new Torrus::DB('other_config_' . $otherConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 1,
+ -WriteAccess => $options{'-WriteAccess'});
+ defined( $self->{'db_otherconfig'} ) or return( undef );
+
+ $self->{'db_aliases'} =
+ new Torrus::DB('aliases_' . $dsConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 1,
+ -WriteAccess => $options{'-WriteAccess'});
+ defined( $self->{'db_aliases'} ) or return( undef );
+
+ if( $options{'-WriteAccess'} )
+ {
+ $self->setReady(0);
+ $self->waitReaders();
+
+ if( $options{'-Rebuild'} )
+ {
+ $self->{'db_otherconfig'}->trunc();
+ if( not $options{'-NoDSRebuild'} )
+ {
+ $self->{'db_dsconfig'}->trunc();
+ $self->{'db_aliases'}->trunc();
+ }
+ }
+ }
+ else
+ {
+ $self->setReader();
+
+ if( not $self->isReady() )
+ {
+ if( $options{'-Wait'} )
+ {
+ Warn('Configuration is not ready');
+
+ my $waitingTimeout =
+ time() + $Torrus::Global::ConfigReadyTimeout;
+ my $success = 0;
+
+ while( not $success and time() < $waitingTimeout )
+ {
+ $self->clearReader();
+
+ Info('Sleeping ' .
+ $Torrus::Global::ConfigReadyRetryPeriod .
+ ' seconds');
+ sleep $Torrus::Global::ConfigReadyRetryPeriod;
+
+ $self->setReader();
+
+ if( $self->isReady() )
+ {
+ $success = 1;
+ Info('Now configuration is ready');
+ }
+ else
+ {
+ Info('Configuration is still not ready');
+ }
+ }
+ if( not $success )
+ {
+ Error('Configuration wait timed out');
+ $self->clearReader();
+ return undef;
+ }
+ }
+ else
+ {
+ Error('Configuration is not ready');
+ $self->clearReader();
+ return undef;
+ }
+ }
+ }
+
+ # Read the parameter properties into memory
+ $self->{'db_paramprops'} =
+ new Torrus::DB('paramprops_' . $dsConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 1,
+ -WriteAccess => $options{'-WriteAccess'});
+ defined( $self->{'db_paramprops'} ) or return( undef );
+
+ if( $options{'-Rebuild'} )
+ {
+ $self->{'db_paramprops'}->trunc();
+ }
+ else
+ {
+ my $cursor = $self->{'db_paramprops'}->cursor();
+ while( my ($key, $val) =
+ $self->{'db_paramprops'}->next( $cursor ) )
+ {
+ my( $param, $prop ) = split( /:/o, $key );
+ $self->{'paramprop'}{$prop}{$param} = $val;
+ }
+ undef $cursor;
+ $self->{'db_paramprops'}->closeNow();
+ delete $self->{'db_paramprops'};
+ }
+
+
+ $self->{'db_sets'} =
+ new Torrus::DB('tokensets_' . $dsConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 0,
+ -WriteAccess => 1, -Truncate => $options{'-Rebuild'});
+ defined( $self->{'db_sets'} ) or return( undef );
+
+
+ $self->{'db_nodepcache'} =
+ new Torrus::DB('nodepcache_' . $dsConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 1,
+ -WriteAccess => 1,
+ -Truncate => ($options{'-Rebuild'} and
+ not $options{'-NoDSRebuild'}));
+ defined( $self->{'db_nodepcache'} ) or return( undef );
+
+
+ $self->{'db_nodeid'} =
+ new Torrus::DB('nodeid_' . $dsConfInstance,
+ -Subdir => $self->{'treename'}, -Btree => 1,
+ -WriteAccess => 1,
+ -Truncate => ($options{'-Rebuild'} and
+ not $options{'-NoDSRebuild'}));
+ defined( $self->{'db_nodeid'} ) or return( undef );
+
+ return $self;
+}
+
+
+sub DESTROY
+{
+ my $self = shift;
+
+ Debug('Destroying ConfigTree object');
+
+ if( $self->{'iam_writer'} )
+ {
+ # Acquire exlusive lock on the database and clear the compiling flag
+ my $cursor = $self->{'db_config_instances'}->cursor( -Write => 1 );
+ $self->{'db_config_instances'}->c_put
+ ( $cursor, 'compiling:' . $self->{'treename'}, 0 );
+ undef $cursor;
+ }
+ else
+ {
+ $self->clearReader();
+ }
+
+ undef $self->{'db_dsconfig'};
+ undef $self->{'db_otherconfig'};
+ undef $self->{'db_aliases'};
+ undef $self->{'db_sets'};
+ undef $self->{'db_nodepcache'};
+ undef $self->{'db_readers'};
+}
+
+# Manage the readinness flag
+
+sub setReady
+{
+ my $self = shift;
+ my $ready = shift;
+ $self->{'db_otherconfig'}->put( 'ConfigurationReady', $ready ? 1:0 );
+}
+
+sub isReady
+{
+ my $self = shift;
+ return $self->{'db_otherconfig'}->get( 'ConfigurationReady' );
+}
+
+# Manage the readers database
+
+sub setReader
+{
+ my $self = shift;
+
+ my $readerId = 'pid=' . $$ . ',rand=' . sprintf('%.10d', rand(1e9));
+ Debug('Setting up reader: ' . $readerId);
+ $self->{'reader_id'} = $readerId;
+ $self->{'db_readers'}->put( $readerId,
+ sprintf('%d:%d:%d',
+ time(),
+ $self->{'ds_config_instance'},
+ $self->{'other_config_instance'}) );
+}
+
+sub clearReader
+{
+ my $self = shift;
+
+ if( defined( $self->{'reader_id'} ) )
+ {
+ Debug('Clearing reader: ' . $self->{'reader_id'});
+ $self->{'db_readers'}->del( $self->{'reader_id'} );
+ delete $self->{'reader_id'};
+ }
+}
+
+
+sub waitReaders
+{
+ my $self = shift;
+
+ # Let the active readers finish their job
+ my $noReaders = 0;
+ while( not $noReaders )
+ {
+ my @readers = ();
+ my $cursor = $self->{'db_readers'}->cursor();
+ while( my ($key, $val) = $self->{'db_readers'}->next( $cursor ) )
+ {
+ my( $timestamp, $dsInst, $otherInst ) = split( /:/o, $val );
+ if( $dsInst == $self->{'ds_config_instance'} or
+ $otherInst == $self->{'other_config_instance'} )
+ {
+ push( @readers, {
+ 'reader' => $key,
+ 'timestamp' => $timestamp } );
+ }
+ }
+ undef $cursor;
+ if( @readers > 0 )
+ {
+ Info('Waiting for ' . scalar(@readers) . ' readers:');
+ my $recentTS = 0;
+ foreach my $reader ( @readers )
+ {
+ Info($reader->{'reader'} . ', timestamp: ' .
+ localtime( $reader->{'timestamp'} ));
+ if( $reader->{'timestamp'} > $recentTS )
+ {
+ $recentTS = $reader->{'timestamp'};
+ }
+ }
+ if( $recentTS + $Torrus::Global::ConfigReadersWaitTimeout >=
+ time() )
+ {
+ Info('Sleeping ' . $Torrus::Global::ConfigReadersWaitPeriod .
+ ' seconds');
+ sleep( $Torrus::Global::ConfigReadersWaitPeriod );
+ }
+ else
+ {
+ # the readers are too long active. we ignore them now
+ Warn('Readers wait timed out. Flushing the readers list for ' .
+ 'DS config instance ' . $self->{'ds_config_instance'} .
+ ' and Other config instance ' .
+ $self->{'other_config_instance'});
+
+ my $cursor = $self->{'db_readers'}->cursor( -Write => 1 );
+ while( my ($key, $val) =
+ $self->{'db_readers'}->next( $cursor ) )
+ {
+ my( $timestamp, $dsInst, $otherInst ) =
+ split( /:/o, $val );
+ if( $dsInst == $self->{'ds_config_instance'} or
+ $otherInst == $self->{'other_config_instance'} )
+ {
+ $self->{'db_readers'}->c_del( $cursor );
+ }
+ }
+ undef $cursor;
+ $noReaders = 1;
+ }
+ }
+ else
+ {
+ $noReaders = 1;
+ }
+ }
+}
+
+
+
+# This should be called after Torrus::TimeStamp::init();
+
+sub getTimestamp
+{
+ my $self = shift;
+ return Torrus::TimeStamp::get($self->{'treename'} . ':configuration');
+}
+
+sub treeName
+{
+ my $self = shift;
+ return $self->{'treename'};
+}
+
+
+# Returns array with path components
+
+sub splitPath
+{
+ my $self = shift;
+ my $path = shift;
+ my @ret = ();
+ while( length($path) > 0 )
+ {
+ my $node;
+ $path =~ s/^([^\/]*\/?)//o; $node = $1;
+ push(@ret, $node);
+ }
+ return @ret;
+}
+
+sub nodeName
+{
+ my $self = shift;
+ my $path = shift;
+ $path =~ s/.*\/([^\/]+)\/?$/$1/o;
+ return $path;
+}
+
+sub token
+{
+ my $self = shift;
+ my $path = shift;
+
+ my $token = $self->{'db_dsconfig'}->get( 'pt:'.$path );
+ if( not defined( $token ) )
+ {
+ my $prefixLen = 1; # the leading slash is anyway there
+ my $pathLen = length( $path );
+ while( not defined( $token ) and $prefixLen < $pathLen )
+ {
+ my $result = $self->{'db_aliases'}->getBestMatch( $path );
+ if( not defined( $result ) )
+ {
+ $prefixLen = $pathLen; # exit the loop
+ }
+ else
+ {
+ # Found a partial match
+ $prefixLen = length( $result->{'key'} );
+ my $aliasTarget = $self->path( $result->{'value'} );
+ $path = $aliasTarget . substr( $path, $prefixLen );
+ $token = $self->{'db_dsconfig'}->get( 'pt:'.$path );
+ }
+ }
+ }
+ return $token;
+}
+
+sub path
+{
+ my $self = shift;
+ my $token = shift;
+ return $self->{'db_dsconfig'}->get( 'tp:'.$token );
+}
+
+sub nodeExists
+{
+ my $self = shift;
+ my $path = shift;
+
+ return defined( $self->{'db_dsconfig'}->get( 'pt:'.$path ) );
+}
+
+
+sub nodeType
+{
+ my $self = shift;
+ my $token = shift;
+
+ my $type = $self->{'nodetype_cache'}{$token};
+ if( not defined( $type ) )
+ {
+ $type = $self->{'db_dsconfig'}->get( 'n:'.$token );
+ $self->{'nodetype_cache'}{$token} = $type;
+ }
+ return $type;
+}
+
+
+sub isLeaf
+{
+ my $self = shift;
+ my $token = shift;
+
+ return ( $self->nodeType($token) == 1 );
+}
+
+
+sub isSubtree
+{
+ my $self = shift;
+ my $token = shift;
+
+ return( $self->nodeType($token) == 0 );
+}
+
+# Returns the real token or undef
+sub isAlias
+{
+ my $self = shift;
+ my $token = shift;
+
+ return( ( $self->nodeType($token) == 2 ) ?
+ $self->{'db_dsconfig'}->get( 'a:'.$token ) : undef );
+}
+
+# Returns the list of tokens pointing to this one as an alias
+sub getAliases
+{
+ my $self = shift;
+ my $token = shift;
+
+ return $self->{'db_dsconfig'}->getListItems('ar:'.$token);
+}
+
+
+sub getParam
+{
+ my $self = shift;
+ my $name = shift;
+ my $param = shift;
+ my $fromDS = shift;
+
+ if( exists( $self->{'paramcache'}{$name}{$param} ) )
+ {
+ return $self->{'paramcache'}{$name}{$param};
+ }
+ else
+ {
+ my $db = $fromDS ? $self->{'db_dsconfig'} : $self->{'db_otherconfig'};
+ my $val = $db->get( 'P:'.$name.':'.$param );
+ $self->{'paramcache'}{$name}{$param} = $val;
+ return $val;
+ }
+}
+
+sub retrieveNodeParam
+{
+ my $self = shift;
+ my $token = shift;
+ my $param = shift;
+
+ # walk up the tree and save the grandparent's value at parent's cache
+
+ my $value;
+ my $currtoken = $token;
+ my @ancestors;
+ my $walked = 0;
+
+ while( not defined($value) and defined($currtoken) )
+ {
+ $value = $self->getParam( $currtoken, $param, 1 );
+ if( not defined $value )
+ {
+ if( $walked )
+ {
+ push( @ancestors, $currtoken );
+ }
+ else
+ {
+ $walked = 1;
+ }
+ # walk up to the parent
+ $currtoken = $self->getParent($currtoken);
+ }
+ }
+
+ foreach my $ancestor ( @ancestors )
+ {
+ $self->{'paramcache'}{$ancestor}{$param} = $value;
+ }
+
+ return $self->expandNodeParam( $token, $param, $value );
+}
+
+
+sub expandNodeParam
+{
+ my $self = shift;
+ my $token = shift;
+ my $param = shift;
+ my $value = shift;
+
+ # %parameter_substitutions% in ds-path-* in multigraph leaves
+ # are expanded by the Writer post-processing
+ if( defined $value and $self->getParamProperty( $param, 'expand' ) )
+ {
+ $value = $self->expandSubstitutions( $token, $param, $value );
+ }
+ return $value;
+}
+
+
+sub expandSubstitutions
+{
+ my $self = shift;
+ my $token = shift;
+ my $param = shift;
+ my $value = shift;
+
+ my $ok = 1;
+ my $changed = 1;
+
+ while( $changed and $ok )
+ {
+ $changed = 0;
+
+ # Substitute definitions
+ if( index($value, '$') >= 0 )
+ {
+ if( not $value =~ /\$(\w+)/o )
+ {
+ my $path = $self->path($token);
+ Error("Incorrect definition reference: $value in $path");
+ $ok = 0;
+ }
+ else
+ {
+ my $dname = $1;
+ my $dvalue = $self->getDefinition($dname);
+ if( not defined( $dvalue ) )
+ {
+ my $path = $self->path($token);
+ Error("Cannot find definition $dname in $path");
+ $ok = 0;
+ }
+ else
+ {
+ $value =~ s/\$$dname/$dvalue/g;
+ $changed = 1;
+ }
+ }
+ }
+
+ # Substitute parameter references
+ if( index($value, '%') >= 0 and $ok )
+ {
+ if( not $value =~ /\%([a-zA-Z0-9\-_]+)\%/o )
+ {
+ Error("Incorrect parameter reference: $value");
+ $ok = 0;
+ }
+ else
+ {
+ my $pname = $1;
+ my $pval = $self->getNodeParam( $token, $pname );
+
+ if( not defined( $pval ) )
+ {
+ my $path = $self->path($token);
+ Error("Cannot expand parameter reference %".
+ $pname."% in ".$path);
+ $ok = 0;
+ }
+ else
+ {
+ $value =~ s/\%$pname\%/$pval/g;
+ $changed = 1;
+ }
+ }
+ }
+ }
+
+ if( ref( $Torrus::ConfigTree::nodeParamHook ) )
+ {
+ $value = &{$Torrus::ConfigTree::nodeParamHook}( $self, $token,
+ $param, $value );
+ }
+
+ return $value;
+}
+
+
+sub getNodeParam
+{
+ my $self = shift;
+ my $token = shift;
+ my $param = shift;
+ my $noclimb = shift;
+
+ my $value;
+ if( $noclimb )
+ {
+ $value = $self->getParam( $token, $param, 1 );
+ return $self->expandNodeParam( $token, $param, $value );
+ }
+
+ if( $self->{'is_writing'} )
+ {
+ return $self->retrieveNodeParam( $token, $param );
+ }
+
+ my $cachekey = $token.':'.$param;
+ my $cacheval = $self->{'db_nodepcache'}->get( $cachekey );
+ if( defined( $cacheval ) )
+ {
+ my $status = substr( $cacheval, 0, 1 );
+ if( $status eq 'U' )
+ {
+ return undef;
+ }
+ else
+ {
+ return substr( $cacheval, 1 );
+ }
+ }
+
+ $value = $self->retrieveNodeParam( $token, $param );
+
+ if( defined( $value ) )
+ {
+ $self->{'db_nodepcache'}->put( $cachekey, 'D'.$value );
+ }
+ else
+ {
+ $self->{'db_nodepcache'}->put( $cachekey, 'U' );
+ }
+
+ return $value;
+}
+
+
+sub getParamNames
+{
+ my $self = shift;
+ my $name = shift;
+ my $fromDS = shift;
+
+ my $db = $fromDS ? $self->{'db_dsconfig'} : $self->{'db_otherconfig'};
+
+ return $db->getListItems('Pl:'.$name);
+}
+
+
+sub getParams
+{
+ my $self = shift;
+ my $name = shift;
+ my $fromDS = shift;
+
+ my $ret = {};
+ foreach my $param ( $self->getParamNames( $name, $fromDS ) )
+ {
+ $ret->{$param} = $self->getParam( $name, $param, $fromDS );
+ }
+ return $ret;
+}
+
+sub getParent
+{
+ my $self = shift;
+ my $token = shift;
+ if( exists( $self->{'parentcache'}{$token} ) )
+ {
+ return $self->{'parentcache'}{$token};
+ }
+ else
+ {
+ my $parent = $self->{'db_dsconfig'}->get( 'p:'.$token );
+ $self->{'parentcache'}{$token} = $parent;
+ return $parent;
+ }
+}
+
+
+sub getChildren
+{
+ my $self = shift;
+ my $token = shift;
+
+ if( (my $alias = $self->isAlias($token)) )
+ {
+ return $self->getChildren($alias);
+ }
+ else
+ {
+ return $self->{'db_dsconfig'}->getListItems( 'c:'.$token );
+ }
+}
+
+sub getParamProperty
+{
+ my $self = shift;
+ my $param = shift;
+ my $prop = shift;
+
+ return $self->{'paramprop'}{$prop}{$param};
+}
+
+
+sub getParamProperties
+{
+ my $self = shift;
+
+ return $self->{'paramprop'};
+}
+
+# Recognize the regexp patterns within a path,
+# like /Netflow/Exporters/.*/.*/bps.
+# Each pattern is applied against direct child names only.
+#
+sub getNodesByPattern
+{
+ my $self = shift;
+ my $pattern = shift;
+
+ if( $pattern !~ /^\//o )
+ {
+ Error("Incorrect pattern: $pattern");
+ return undef;
+ }
+
+ my @retlist = ();
+ foreach my $nodepattern ( $self->splitPath($pattern) )
+ {
+ my @next_retlist = ();
+
+ # Cut the trailing slash, if any
+ my $patternname = $nodepattern;
+ $patternname =~ s/\/$//o;
+
+ if( $patternname =~ /\W/o )
+ {
+ foreach my $candidate ( @retlist )
+ {
+ # This is a pattern, let's get all matching children
+ foreach my $child ( $self->getChildren( $candidate ) )
+ {
+ # Cut the trailing slash and leading path
+ my $childname = $self->path($child);
+ $childname =~ s/\/$//o;
+ $childname =~ s/.*\/([^\/]+)$/$1/o;
+ if( $childname =~ $patternname )
+ {
+ push( @next_retlist, $child );
+ }
+ }
+ }
+
+ }
+ elsif( length($patternname) == 0 )
+ {
+ @next_retlist = ( $self->token('/') );
+ }
+ else
+ {
+ foreach my $candidate ( @retlist )
+ {
+ my $proposal = $self->path($candidate).$nodepattern;
+ if( defined( my $proptoken = $self->token($proposal) ) )
+ {
+ push( @next_retlist, $proptoken );
+ }
+ }
+ }
+ @retlist = @next_retlist;
+ }
+ return @retlist;
+}
+
+#
+# Recognizes absolute or relative path, '..' as the parent subtree
+#
+sub getRelative
+{
+ my $self = shift;
+ my $token = shift;
+ my $relPath = shift;
+
+ if( $relPath =~ /^\//o )
+ {
+ return $self->token( $relPath );
+ }
+ else
+ {
+ if( length( $relPath ) > 0 )
+ {
+ $token = $self->getParent( $token );
+ }
+
+ while( length( $relPath ) > 0 )
+ {
+ if( $relPath =~ /^\.\.\//o )
+ {
+ $relPath =~ s/^\.\.\///o;
+ if( $token ne $self->token('/') )
+ {
+ $token = $self->getParent( $token );
+ }
+ }
+ else
+ {
+ my $childName;
+ $relPath =~ s/^([^\/]*\/?)//o; $childName = $1;
+ my $path = $self->path( $token );
+ $token = $self->token( $path . $childName );
+ if( not defined $token )
+ {
+ return undef;
+ }
+ }
+ }
+ return $token;
+ }
+}
+
+
+sub getNodeByNodeid
+{
+ my $self = shift;
+ my $nodeid = shift;
+
+ return $self->{'db_nodeid'}->get( $nodeid );
+}
+
+# Returns arrayref or undef.
+# Each element is an arrayref to [nodeid, token] pair
+sub searchNodeidPrefix
+{
+ my $self = shift;
+ my $prefix = shift;
+
+ return $self->{'db_nodeid'}->searchPrefix( $prefix );
+}
+
+
+# Returns arrayref or undef.
+# Each element is an arrayref to [nodeid, token] pair
+sub searchNodeidSubstring
+{
+ my $self = shift;
+ my $substring = shift;
+
+ return $self->{'db_nodeid'}->searchSubstring( $substring );
+}
+
+
+
+sub getDefaultView
+{
+ my $self = shift;
+ my $token = shift;
+
+ my $view;
+ if( $self->isTset($token) )
+ {
+ if( $token eq 'SS' )
+ {
+ $view = $self->getParam('SS', 'default-tsetlist-view');
+ }
+ else
+ {
+ $view = $self->getParam($token, 'default-tset-view');
+ if( not defined( $view ) )
+ {
+ $view = $self->getParam('SS', 'default-tset-view');
+ }
+ }
+ }
+ elsif( $self->isSubtree($token) )
+ {
+ $view = $self->getNodeParam($token, 'default-subtree-view');
+ }
+ else
+ {
+ # This must be leaf
+ $view = $self->getNodeParam($token, 'default-leaf-view');
+ }
+
+ if( not defined( $view ) )
+ {
+ Error("Cannot find default view for $token");
+ }
+ return $view;
+}
+
+
+sub getInstanceParam
+{
+ my $self = shift;
+ my $type = shift;
+ my $name = shift;
+ my $param = shift;
+
+ if( $type eq 'node' )
+ {
+ return $self->getNodeParam($name, $param);
+ }
+ else
+ {
+ return $self->getParam($name, $param);
+ }
+}
+
+
+sub getViewNames
+{
+ my $self = shift;
+ return $self->{'db_otherconfig'}->getListItems( 'V:' );
+}
+
+
+sub viewExists
+{
+ my $self = shift;
+ my $vname = shift;
+ return $self->searchOtherList('V:', $vname);
+}
+
+
+sub getMonitorNames
+{
+ my $self = shift;
+ return $self->{'db_otherconfig'}->getListItems( 'M:' );
+}
+
+sub monitorExists
+{
+ my $self = shift;
+ my $mname = shift;
+ return $self->searchOtherList('M:', $mname);
+}
+
+
+sub getActionNames
+{
+ my $self = shift;
+ return $self->{'db_otherconfig'}->getListItems( 'A:' );
+}
+
+
+sub actionExists
+{
+ my $self = shift;
+ my $mname = shift;
+ return $self->searchOtherList('A:', $mname);
+}
+
+
+# Search for a value in comma-separated list
+sub searchOtherList
+{
+ my $self = shift;
+ my $key = shift;
+ my $name = shift;
+
+ return $self->{'db_otherconfig'}->searchList($key, $name);
+}
+
+# Token sets manipulation
+
+sub isTset
+{
+ my $self = shift;
+ my $token = shift;
+ return substr($token, 0, 1) eq 'S';
+}
+
+sub addTset
+{
+ my $self = shift;
+ my $tset = shift;
+ $self->{'db_sets'}->addToList('S:', $tset);
+}
+
+
+sub tsetExists
+{
+ my $self = shift;
+ my $tset = shift;
+ return $self->{'db_sets'}->searchList('S:', $tset);
+}
+
+sub getTsets
+{
+ my $self = shift;
+ return $self->{'db_sets'}->getListItems('S:');
+}
+
+sub tsetMembers
+{
+ my $self = shift;
+ my $tset = shift;
+
+ return $self->{'db_sets'}->getListItems('s:'.$tset);
+}
+
+sub tsetMemberOrigin
+{
+ my $self = shift;
+ my $tset = shift;
+ my $token = shift;
+
+ return $self->{'db_sets'}->get('o:'.$tset.':'.$token);
+}
+
+sub tsetAddMember
+{
+ my $self = shift;
+ my $tset = shift;
+ my $token = shift;
+ my $origin = shift;
+
+ $self->{'db_sets'}->addToList('s:'.$tset, $token);
+ $self->{'db_sets'}->put('o:'.$tset.':'.$token, $origin);
+}
+
+
+sub tsetDelMember
+{
+ my $self = shift;
+ my $tset = shift;
+ my $token = shift;
+
+ $self->{'db_sets'}->delFromList('s:'.$tset, $token);
+ $self->{'db_sets'}->del('o:'.$tset.':'.$token);
+}
+
+# Definitions manipulation
+
+sub getDefinition
+{
+ my $self = shift;
+ my $name = shift;
+ return $self->{'db_dsconfig'}->get( 'd:'.$name );
+}
+
+sub getDefinitionNames
+{
+ my $self = shift;
+ return $self->{'db_dsconfig'}->getListItems( 'D:' );
+}
+
+
+1;
+
+
+# Local Variables:
+# mode: perl
+# indent-tabs-mode: nil
+# perl-indent-level: 4
+# End:
projects / freeside.git / blobdiff