torrus/perllib/Torrus/ConfigTree.pm

   1 #  Copyright (C) 2002-2007  Stanislav Sinyagin
   2 #
   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.
   7 #
   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.
  12 #
  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.
  16
  17 # $Id: ConfigTree.pm,v 1.1 2010-12-27 00:03:41 ivan Exp $
  18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
  19
  20
  21 package Torrus::ConfigTree;
  22
  23 use Torrus::DB;
  24 use Torrus::Log;
  25 use Torrus::TimeStamp;
  26
  27 use strict;
  28
  29
  30
  31 sub new
  32 {
  33     my $self = {};
  34     my $class = shift;
  35     my %options = @_;
  36     bless $self, $class;
  37
  38     $self->{'treename'} = $options{'-TreeName'};
  39     die('ERROR: TreeName is mandatory') if not $self->{'treename'};
  40
  41     $self->{'db_config_instances'} =
  42         new Torrus::DB( 'config_instances', -WriteAccess => 1 );
  43     defined( $self->{'db_config_instances'} ) or return( undef );
  44
  45     my $i = $self->{'db_config_instances'}->get('ds:' . $self->{'treename'});
  46     if( not defined($i) )
  47     {
  48         $i = 0;
  49         $self->{'first_time_created'} = 1;
  50     }
  51
  52     my $dsConfInstance = sprintf( '%d', $i );
  53
  54     $i = $self->{'db_config_instances'}->get('other:' . $self->{'treename'});
  55     $i = 0 unless defined( $i );
  56
  57     my $otherConfInstance = sprintf( '%d', $i );
  58
  59     if( $options{'-WriteAccess'} )
  60     {
  61         $self->{'is_writing'} = 1;
  62
  63         # Acquire exlusive lock on the database and set the compiling flag
  64         {
  65             my $ok = 1;
  66             my $key = 'compiling:' . $self->{'treename'};
  67             my $cursor = $self->{'db_config_instances'}->cursor( -Write => 1 );
  68             my $compilingFlag =
  69                 $self->{'db_config_instances'}->c_get( $cursor, $key );
  70             if( $compilingFlag )
  71             {
  72                 if( $options{'-ForceWriter'} )
  73                 {
  74                     Warn('Another compiler process is probably still ' .
  75                          'running. This may lead to an unusable ' .
  76                          'database state');
  77                 }
  78                 else
  79                 {
  80                     Error('Another compiler is running for the tree ' .
  81                           $self->{'treename'});
  82                     $ok = 0;
  83                 }
  84             }
  85             else
  86             {
  87                 $self->{'db_config_instances'}->c_put( $cursor, $key, 1 );
  88             }
  89             undef $cursor;
  90             if( not $ok )
  91             {
  92                 return undef;
  93             }
  94             $self->{'iam_writer'} = 1;
  95         }
  96
  97         if( not $options{'-NoDSRebuild'} )
  98         {
  99             $dsConfInstance = sprintf( '%d', ( $dsConfInstance + 1 ) % 2 );
 100         }
 101         $otherConfInstance = sprintf( '%d', ( $otherConfInstance + 1 ) % 2 );
 102     }
 103
 104     $self->{'ds_config_instance'} = $dsConfInstance;
 105     $self->{'other_config_instance'} = $otherConfInstance;
 106
 107     $self->{'db_readers'} = new Torrus::DB('config_readers',
 108                                            -Subdir => $self->{'treename'},
 109                                            -WriteAccess => 1 );
 110     defined( $self->{'db_readers'} ) or return( undef );
 111
 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 );
 117
 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 );
 123
 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 );
 129
 130     if( $options{'-WriteAccess'} )
 131     {
 132         $self->setReady(0);
 133         $self->waitReaders();
 134
 135         if( $options{'-Rebuild'} )
 136         {
 137             $self->{'db_otherconfig'}->trunc();
 138             if( not $options{'-NoDSRebuild'} )
 139             {
 140                 $self->{'db_dsconfig'}->trunc();
 141                 $self->{'db_aliases'}->trunc();
 142             }
 143         }
 144     }
 145     else
 146     {
 147         $self->setReader();
 148
 149         if( not $self->isReady() )
 150         {
 151             if( $options{'-Wait'} )
 152             {
 153                 Warn('Configuration is not ready');
 154
 155                 my $waitingTimeout =
 156                     time() + $Torrus::Global::ConfigReadyTimeout;
 157                 my $success = 0;
 158
 159                 while( not $success and time() < $waitingTimeout )
 160                 {
 161                     $self->clearReader();
 162
 163                     Info('Sleeping ' .
 164                          $Torrus::Global::ConfigReadyRetryPeriod .
 165                          ' seconds');
 166                     sleep $Torrus::Global::ConfigReadyRetryPeriod;
 167
 168                     $self->setReader();
 169
 170                     if( $self->isReady() )
 171                     {
 172                         $success = 1;
 173                         Info('Now configuration is ready');
 174                     }
 175                     else
 176                     {
 177                         Info('Configuration is still not ready');
 178                     }
 179                 }
 180                 if( not $success )
 181                 {
 182                     Error('Configuration wait timed out');
 183                     $self->clearReader();
 184                     return undef;
 185                 }
 186             }
 187             else
 188             {
 189                 Error('Configuration is not ready');
 190                 $self->clearReader();
 191                 return undef;
 192             }
 193         }
 194     }
 195
 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 );
 202
 203     if( $options{'-Rebuild'} )
 204     {
 205         $self->{'db_paramprops'}->trunc();
 206     }
 207     else
 208     {
 209         my $cursor = $self->{'db_paramprops'}->cursor();
 210         while( my ($key, $val) =
 211                $self->{'db_paramprops'}->next( $cursor ) )
 212         {
 213             my( $param, $prop ) = split( /:/o, $key );
 214             $self->{'paramprop'}{$prop}{$param} = $val;
 215         }
 216         undef $cursor;
 217         $self->{'db_paramprops'}->closeNow();
 218         delete $self->{'db_paramprops'};
 219     }
 220
 221
 222     $self->{'db_sets'} =
 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 );
 227
 228
 229     $self->{'db_nodepcache'} =
 230         new Torrus::DB('nodepcache_' . $dsConfInstance,
 231                        -Subdir => $self->{'treename'}, -Btree => 1,
 232                        -WriteAccess => 1,
 233                        -Truncate => ($options{'-Rebuild'} and
 234                                      not $options{'-NoDSRebuild'}));
 235     defined( $self->{'db_nodepcache'} ) or return( undef );
 236
 237
 238     $self->{'db_nodeid'} =
 239         new Torrus::DB('nodeid_' . $dsConfInstance,
 240                        -Subdir => $self->{'treename'}, -Btree => 1,
 241                        -WriteAccess => 1,
 242                        -Truncate => ($options{'-Rebuild'} and
 243                                      not $options{'-NoDSRebuild'}));
 244     defined( $self->{'db_nodeid'} ) or return( undef );
 245
 246     return $self;
 247 }
 248
 249
 250 sub DESTROY
 251 {
 252     my $self = shift;
 253
 254     Debug('Destroying ConfigTree object');
 255
 256     if( $self->{'iam_writer'} )
 257     {
 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 );
 262         undef $cursor;
 263     }
 264     else
 265     {
 266         $self->clearReader();
 267     }
 268
 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'};
 275 }
 276
 277 # Manage the readinness flag
 278
 279 sub setReady
 280 {
 281     my $self = shift;
 282     my $ready = shift;
 283     $self->{'db_otherconfig'}->put( 'ConfigurationReady', $ready ? 1:0 );
 284 }
 285
 286 sub isReady
 287 {
 288     my $self = shift;
 289     return $self->{'db_otherconfig'}->get( 'ConfigurationReady' );
 290 }
 291
 292 # Manage the readers database
 293
 294 sub setReader
 295 {
 296     my $self = shift;
 297
 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,
 302                                 sprintf('%d:%d:%d',
 303                                         time(),
 304                                         $self->{'ds_config_instance'},
 305                                         $self->{'other_config_instance'}) );
 306 }
 307
 308 sub clearReader
 309 {
 310     my $self = shift;
 311
 312     if( defined( $self->{'reader_id'} ) )
 313     {
 314         Debug('Clearing reader: ' . $self->{'reader_id'});
 315         $self->{'db_readers'}->del( $self->{'reader_id'} );
 316         delete $self->{'reader_id'};
 317     }
 318 }
 319
 320
 321 sub waitReaders
 322 {
 323     my $self = shift;
 324
 325     # Let the active readers finish their job
 326     my $noReaders = 0;
 327     while( not $noReaders )
 328     {
 329         my @readers = ();
 330         my $cursor = $self->{'db_readers'}->cursor();
 331         while( my ($key, $val) = $self->{'db_readers'}->next( $cursor ) )
 332         {
 333             my( $timestamp, $dsInst, $otherInst ) = split( /:/o, $val );
 334             if( $dsInst == $self->{'ds_config_instance'} or
 335                 $otherInst == $self->{'other_config_instance'} )
 336             {
 337                 push( @readers, {
 338                     'reader' => $key,
 339                     'timestamp' => $timestamp } );
 340             }
 341         }
 342         undef $cursor;
 343         if( @readers > 0 )
 344         {
 345             Info('Waiting for ' . scalar(@readers) . ' readers:');
 346             my $recentTS = 0;
 347             foreach my $reader ( @readers )
 348             {
 349                 Info($reader->{'reader'} . ', timestamp: ' .
 350                      localtime( $reader->{'timestamp'} ));
 351                 if( $reader->{'timestamp'} > $recentTS )
 352                 {
 353                     $recentTS = $reader->{'timestamp'};
 354                 }
 355             }
 356             if( $recentTS + $Torrus::Global::ConfigReadersWaitTimeout >=
 357                 time() )
 358             {
 359                 Info('Sleeping ' . $Torrus::Global::ConfigReadersWaitPeriod  .
 360                      ' seconds');
 361                 sleep( $Torrus::Global::ConfigReadersWaitPeriod );
 362             }
 363             else
 364             {
 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'});
 370
 371                 my $cursor = $self->{'db_readers'}->cursor( -Write => 1 );
 372                 while( my ($key, $val) =
 373                        $self->{'db_readers'}->next( $cursor ) )
 374                 {
 375                     my( $timestamp, $dsInst, $otherInst ) =
 376                         split( /:/o, $val );
 377                     if( $dsInst == $self->{'ds_config_instance'} or
 378                         $otherInst == $self->{'other_config_instance'} )
 379                     {
 380                         $self->{'db_readers'}->c_del( $cursor );
 381                     }
 382                 }
 383                 undef $cursor;
 384                 $noReaders = 1;
 385             }
 386         }
 387         else
 388         {
 389             $noReaders = 1;
 390         }
 391     }
 392 }
 393
 394
 395
 396 # This should be called after Torrus::TimeStamp::init();
 397
 398 sub getTimestamp
 399 {
 400     my $self = shift;
 401     return Torrus::TimeStamp::get($self->{'treename'} . ':configuration');
 402 }
 403
 404 sub treeName
 405 {
 406     my $self = shift;
 407     return $self->{'treename'};
 408 }
 409
 410
 411 # Returns array with path components
 412
 413 sub splitPath
 414 {
 415     my $self = shift;
 416     my $path = shift;
 417     my @ret = ();
 418     while( length($path) > 0 )
 419     {
 420         my $node;
 421         $path =~ s/^([^\/]*\/?)//o; $node = $1;
 422         push(@ret, $node);
 423     }
 424     return @ret;
 425 }
 426
 427 sub nodeName
 428 {
 429     my $self = shift;
 430     my $path = shift;
 431     $path =~ s/.*\/([^\/]+)\/?$/$1/o;
 432     return $path;
 433 }
 434
 435 sub token
 436 {
 437     my $self = shift;
 438     my $path = shift;
 439
 440     my $token = $self->{'db_dsconfig'}->get( 'pt:'.$path );
 441     if( not defined( $token ) )
 442     {
 443         my $prefixLen = 1; # the leading slash is anyway there
 444         my $pathLen = length( $path );
 445         while( not defined( $token ) and $prefixLen < $pathLen )
 446         {
 447             my $result = $self->{'db_aliases'}->getBestMatch( $path );
 448             if( not defined( $result ) )
 449             {
 450                 $prefixLen = $pathLen; # exit the loop
 451             }
 452             else
 453             {
 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 );
 459             }
 460         }
 461     }
 462     return $token;
 463 }
 464
 465 sub path
 466 {
 467     my $self = shift;
 468     my $token = shift;
 469     return $self->{'db_dsconfig'}->get( 'tp:'.$token );
 470 }
 471
 472 sub nodeExists
 473 {
 474     my $self = shift;
 475     my $path = shift;
 476
 477     return defined( $self->{'db_dsconfig'}->get( 'pt:'.$path ) );
 478 }
 479
 480
 481 sub nodeType
 482 {
 483     my $self = shift;
 484     my $token = shift;
 485
 486     my $type = $self->{'nodetype_cache'}{$token};
 487     if( not defined( $type ) )
 488     {
 489         $type = $self->{'db_dsconfig'}->get( 'n:'.$token );
 490         $self->{'nodetype_cache'}{$token} = $type;
 491     }
 492     return $type;
 493 }
 494
 495
 496 sub isLeaf
 497 {
 498     my $self = shift;
 499     my $token = shift;
 500
 501     return ( $self->nodeType($token) == 1 );
 502 }
 503
 504
 505 sub isSubtree
 506 {
 507     my $self = shift;
 508     my $token = shift;
 509
 510     return( $self->nodeType($token) == 0 );
 511 }
 512
 513 # Returns the real token or undef
 514 sub isAlias
 515 {
 516     my $self = shift;
 517     my $token = shift;
 518
 519     return( ( $self->nodeType($token) == 2 ) ?
 520             $self->{'db_dsconfig'}->get( 'a:'.$token ) : undef );
 521 }
 522
 523 # Returns the list of tokens pointing to this one as an alias
 524 sub getAliases
 525 {
 526     my $self = shift;
 527     my $token = shift;
 528
 529     return $self->{'db_dsconfig'}->getListItems('ar:'.$token);
 530 }
 531
 532
 533 sub getParam
 534 {
 535     my $self = shift;
 536     my $name = shift;
 537     my $param = shift;
 538     my $fromDS = shift;
 539
 540     if( exists( $self->{'paramcache'}{$name}{$param} ) )
 541     {
 542         return $self->{'paramcache'}{$name}{$param};
 543     }
 544     else
 545     {
 546         my $db = $fromDS ? $self->{'db_dsconfig'} : $self->{'db_otherconfig'};
 547         my $val = $db->get( 'P:'.$name.':'.$param );
 548         $self->{'paramcache'}{$name}{$param} = $val;
 549         return $val;
 550     }
 551 }
 552
 553 sub retrieveNodeParam
 554 {
 555     my $self = shift;
 556     my $token = shift;
 557     my $param = shift;
 558
 559     # walk up the tree and save the grandparent's value at parent's cache
 560
 561     my $value;
 562     my $currtoken = $token;
 563     my @ancestors;
 564     my $walked = 0;
 565
 566     while( not defined($value) and defined($currtoken) )
 567     {
 568         $value = $self->getParam( $currtoken, $param, 1 );
 569         if( not defined $value )
 570         {
 571             if( $walked )
 572             {
 573                 push( @ancestors, $currtoken );
 574             }
 575             else
 576             {
 577                 $walked = 1;
 578             }
 579             # walk up to the parent
 580             $currtoken = $self->getParent($currtoken);
 581         }
 582     }
 583
 584     foreach my $ancestor ( @ancestors )
 585     {
 586         $self->{'paramcache'}{$ancestor}{$param} = $value;
 587     }
 588
 589     return $self->expandNodeParam( $token, $param, $value );
 590 }
 591
 592
 593 sub expandNodeParam
 594 {
 595     my $self = shift;
 596     my $token = shift;
 597     my $param = shift;
 598     my $value = shift;
 599
 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' ) )
 603     {
 604         $value = $self->expandSubstitutions( $token, $param, $value );
 605     }
 606     return $value;
 607 }
 608
 609
 610 sub expandSubstitutions
 611 {
 612     my $self = shift;
 613     my $token = shift;
 614     my $param = shift;
 615     my $value = shift;
 616
 617     my $ok = 1;
 618     my $changed = 1;
 619
 620     while( $changed and $ok )
 621     {
 622         $changed = 0;
 623
 624         # Substitute definitions
 625         if( index($value, '$') >= 0 )
 626         {
 627             if( not $value =~ /\$(\w+)/o )
 628             {
 629                 my $path = $self->path($token);
 630                 Error("Incorrect definition reference: $value in $path");
 631                 $ok = 0;
 632             }
 633             else
 634             {
 635                 my $dname = $1;
 636                 my $dvalue = $self->getDefinition($dname);
 637                 if( not defined( $dvalue ) )
 638                 {
 639                     my $path = $self->path($token);
 640                     Error("Cannot find definition $dname in $path");
 641                     $ok = 0;
 642                 }
 643                 else
 644                 {
 645                     $value =~ s/\$$dname/$dvalue/g;
 646                     $changed = 1;
 647                 }
 648             }
 649         }
 650
 651         # Substitute parameter references
 652         if( index($value, '%') >= 0 and $ok )
 653         {
 654             if( not $value =~ /\%([a-zA-Z0-9\-_]+)\%/o )
 655             {
 656                 Error("Incorrect parameter reference: $value");
 657                 $ok = 0;
 658             }
 659             else
 660             {
 661                 my $pname = $1;
 662                 my $pval = $self->getNodeParam( $token, $pname );
 663
 664                 if( not defined( $pval ) )
 665                 {
 666                     my $path = $self->path($token);
 667                     Error("Cannot expand parameter reference %".
 668                           $pname."% in ".$path);
 669                     $ok = 0;
 670                 }
 671                 else
 672                 {
 673                     $value =~ s/\%$pname\%/$pval/g;
 674                     $changed = 1;
 675                 }
 676             }
 677         }
 678     }
 679
 680     if( ref( $Torrus::ConfigTree::nodeParamHook ) )
 681     {
 682         $value = &{$Torrus::ConfigTree::nodeParamHook}( $self, $token,
 683                                                         $param, $value );
 684     }
 685
 686     return $value;
 687 }
 688
 689
 690 sub getNodeParam
 691 {
 692     my $self = shift;
 693     my $token = shift;
 694     my $param = shift;
 695     my $noclimb = shift;
 696
 697     my $value;
 698     if( $noclimb )
 699     {
 700         $value = $self->getParam( $token, $param, 1 );
 701         return $self->expandNodeParam( $token, $param, $value );
 702     }
 703
 704     if( $self->{'is_writing'} )
 705     {
 706         return $self->retrieveNodeParam( $token, $param );
 707     }
 708
 709     my $cachekey = $token.':'.$param;
 710     my $cacheval = $self->{'db_nodepcache'}->get( $cachekey );
 711     if( defined( $cacheval ) )
 712     {
 713         my $status = substr( $cacheval, 0, 1 );
 714         if( $status eq 'U' )
 715         {
 716             return undef;
 717         }
 718         else
 719         {
 720             return substr( $cacheval, 1 );
 721         }
 722     }
 723
 724     $value = $self->retrieveNodeParam( $token, $param );
 725
 726     if( defined( $value ) )
 727     {
 728         $self->{'db_nodepcache'}->put( $cachekey, 'D'.$value );
 729     }
 730     else
 731     {
 732         $self->{'db_nodepcache'}->put( $cachekey, 'U' );
 733     }
 734
 735     return $value;
 736 }
 737
 738
 739 sub getParamNames
 740 {
 741     my $self = shift;
 742     my $name = shift;
 743     my $fromDS = shift;
 744
 745     my $db = $fromDS ? $self->{'db_dsconfig'} : $self->{'db_otherconfig'};
 746
 747     return $db->getListItems('Pl:'.$name);
 748 }
 749
 750
 751 sub getParams
 752 {
 753     my $self = shift;
 754     my $name = shift;
 755     my $fromDS = shift;
 756
 757     my $ret = {};
 758     foreach my $param ( $self->getParamNames( $name, $fromDS ) )
 759     {
 760         $ret->{$param} = $self->getParam( $name, $param, $fromDS );
 761     }
 762     return $ret;
 763 }
 764
 765 sub getParent
 766 {
 767     my $self = shift;
 768     my $token = shift;
 769     if( exists( $self->{'parentcache'}{$token} ) )
 770     {
 771         return $self->{'parentcache'}{$token};
 772     }
 773     else
 774     {
 775         my $parent = $self->{'db_dsconfig'}->get( 'p:'.$token );
 776         $self->{'parentcache'}{$token} = $parent;
 777         return $parent;
 778     }
 779 }
 780
 781
 782 sub getChildren
 783 {
 784     my $self = shift;
 785     my $token = shift;
 786
 787     if( (my $alias = $self->isAlias($token)) )
 788     {
 789         return $self->getChildren($alias);
 790     }
 791     else
 792     {
 793         return $self->{'db_dsconfig'}->getListItems( 'c:'.$token );
 794     }
 795 }
 796
 797 sub getParamProperty
 798 {
 799     my $self = shift;
 800     my $param = shift;
 801     my $prop = shift;
 802
 803     return $self->{'paramprop'}{$prop}{$param};
 804 }
 805
 806
 807 sub getParamProperties
 808 {
 809     my $self = shift;
 810
 811     return $self->{'paramprop'};
 812 }
 813
 814 # Recognize the regexp patterns within a path,
 815 # like /Netflow/Exporters/.*/.*/bps.
 816 # Each pattern is applied against direct child names only.
 817 #
 818 sub getNodesByPattern
 819 {
 820     my $self = shift;
 821     my $pattern = shift;
 822
 823     if( $pattern !~ /^\//o )
 824     {
 825         Error("Incorrect pattern: $pattern");
 826         return undef;
 827     }
 828
 829     my @retlist = ();
 830     foreach my $nodepattern ( $self->splitPath($pattern) )
 831     {
 832         my @next_retlist = ();
 833
 834         # Cut the trailing slash, if any
 835         my $patternname = $nodepattern;
 836         $patternname =~ s/\/$//o;
 837
 838         if( $patternname =~ /\W/o )
 839         {
 840             foreach my $candidate ( @retlist )
 841             {
 842                 # This is a pattern, let's get all matching children
 843                 foreach my $child ( $self->getChildren( $candidate ) )
 844                 {
 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 )
 850                     {
 851                         push( @next_retlist, $child );
 852                     }
 853                 }
 854             }
 855
 856         }
 857         elsif( length($patternname) == 0 )
 858         {
 859             @next_retlist = ( $self->token('/') );
 860         }
 861         else
 862         {
 863             foreach my $candidate ( @retlist )
 864             {
 865                 my $proposal = $self->path($candidate).$nodepattern;
 866                 if( defined( my $proptoken = $self->token($proposal) ) )
 867                 {
 868                     push( @next_retlist, $proptoken );
 869                 }
 870             }
 871         }
 872         @retlist = @next_retlist;
 873     }
 874     return @retlist;
 875 }
 876
 877 #
 878 # Recognizes absolute or relative path, '..' as the parent subtree
 879 #
 880 sub getRelative
 881 {
 882     my $self = shift;
 883     my $token = shift;
 884     my $relPath = shift;
 885
 886     if( $relPath =~ /^\//o )
 887     {
 888         return $self->token( $relPath );
 889     }
 890     else
 891     {
 892         if( length( $relPath ) > 0 )
 893         {
 894             $token = $self->getParent( $token );
 895         }
 896
 897         while( length( $relPath ) > 0 )
 898         {
 899             if( $relPath =~ /^\.\.\//o )
 900             {
 901                 $relPath =~ s/^\.\.\///o;
 902                 if( $token ne $self->token('/') )
 903                 {
 904                     $token = $self->getParent( $token );
 905                 }
 906             }
 907             else
 908             {
 909                 my $childName;
 910                 $relPath =~ s/^([^\/]*\/?)//o; $childName = $1;
 911                 my $path = $self->path( $token );
 912                 $token = $self->token( $path . $childName );
 913                 if( not defined $token )
 914                 {
 915                     return undef;
 916                 }
 917             }
 918         }
 919         return $token;
 920     }
 921 }
 922
 923
 924 sub getNodeByNodeid
 925 {
 926     my $self = shift;
 927     my $nodeid = shift;
 928
 929     return $self->{'db_nodeid'}->get( $nodeid );
 930 }
 931
 932 # Returns arrayref or undef.
 933 # Each element is an arrayref to [nodeid, token] pair
 934 sub searchNodeidPrefix
 935 {
 936     my $self = shift;
 937     my $prefix = shift;
 938
 939     return $self->{'db_nodeid'}->searchPrefix( $prefix );
 940 }
 941
 942
 943 # Returns arrayref or undef.
 944 # Each element is an arrayref to [nodeid, token] pair
 945 sub searchNodeidSubstring
 946 {
 947     my $self = shift;
 948     my $substring = shift;
 949
 950     return $self->{'db_nodeid'}->searchSubstring( $substring );
 951 }
 952
 953
 954
 955 sub getDefaultView
 956 {
 957     my $self = shift;
 958     my $token = shift;
 959
 960     my $view;
 961     if( $self->isTset($token) )
 962     {
 963         if( $token eq 'SS' )
 964         {
 965             $view = $self->getParam('SS', 'default-tsetlist-view');
 966         }
 967         else
 968         {
 969             $view = $self->getParam($token, 'default-tset-view');
 970             if( not defined( $view ) )
 971             {
 972                 $view = $self->getParam('SS', 'default-tset-view');
 973             }
 974         }
 975     }
 976     elsif( $self->isSubtree($token) )
 977     {
 978         $view = $self->getNodeParam($token, 'default-subtree-view');
 979     }
 980     else
 981     {
 982         # This must be leaf
 983         $view = $self->getNodeParam($token, 'default-leaf-view');
 984     }
 985
 986     if( not defined( $view ) )
 987     {
 988         Error("Cannot find default view for $token");
 989     }
 990     return $view;
 991 }
 992
 993
 994 sub getInstanceParam
 995 {
 996     my $self = shift;
 997     my $type = shift;
 998     my $name = shift;
 999     my $param = shift;
1000
1001     if( $type eq 'node' )
1002     {
1003         return $self->getNodeParam($name, $param);
1004     }
1005     else
1006     {
1007         return $self->getParam($name, $param);
1008     }
1009 }
1010
1011
1012 sub getViewNames
1013 {
1014     my $self = shift;
1015     return $self->{'db_otherconfig'}->getListItems( 'V:' );
1016 }
1017
1018
1019 sub viewExists
1020 {
1021     my $self = shift;
1022     my $vname = shift;
1023     return $self->searchOtherList('V:', $vname);
1024 }
1025
1026
1027 sub getMonitorNames
1028 {
1029     my $self = shift;
1030     return $self->{'db_otherconfig'}->getListItems( 'M:' );
1031 }
1032
1033 sub monitorExists
1034 {
1035     my $self = shift;
1036     my $mname = shift;
1037     return $self->searchOtherList('M:', $mname);
1038 }
1039
1040
1041 sub getActionNames
1042 {
1043     my $self = shift;
1044     return $self->{'db_otherconfig'}->getListItems( 'A:' );
1045 }
1046
1047
1048 sub actionExists
1049 {
1050     my $self = shift;
1051     my $mname = shift;
1052     return $self->searchOtherList('A:', $mname);
1053 }
1054
1055
1056 # Search for a value in comma-separated list
1057 sub searchOtherList
1058 {
1059     my $self = shift;
1060     my $key = shift;
1061     my $name = shift;
1062
1063     return $self->{'db_otherconfig'}->searchList($key, $name);
1064 }
1065
1066 # Token sets manipulation
1067
1068 sub isTset
1069 {
1070     my $self = shift;
1071     my $token = shift;
1072     return substr($token, 0, 1) eq 'S';
1073 }
1074
1075 sub addTset
1076 {
1077     my $self = shift;
1078     my $tset = shift;
1079     $self->{'db_sets'}->addToList('S:', $tset);
1080 }
1081
1082
1083 sub tsetExists
1084 {
1085     my $self = shift;
1086     my $tset = shift;
1087     return $self->{'db_sets'}->searchList('S:', $tset);
1088 }
1089
1090 sub getTsets
1091 {
1092     my $self = shift;
1093     return $self->{'db_sets'}->getListItems('S:');
1094 }
1095
1096 sub tsetMembers
1097 {
1098     my $self = shift;
1099     my $tset = shift;
1100
1101     return $self->{'db_sets'}->getListItems('s:'.$tset);
1102 }
1103
1104 sub tsetMemberOrigin
1105 {
1106     my $self = shift;
1107     my $tset = shift;
1108     my $token = shift;
1109
1110     return $self->{'db_sets'}->get('o:'.$tset.':'.$token);
1111 }
1112
1113 sub tsetAddMember
1114 {
1115     my $self = shift;
1116     my $tset = shift;
1117     my $token = shift;
1118     my $origin = shift;
1119
1120     $self->{'db_sets'}->addToList('s:'.$tset, $token);
1121     $self->{'db_sets'}->put('o:'.$tset.':'.$token, $origin);
1122 }
1123
1124
1125 sub tsetDelMember
1126 {
1127     my $self = shift;
1128     my $tset = shift;
1129     my $token = shift;
1130
1131     $self->{'db_sets'}->delFromList('s:'.$tset, $token);
1132     $self->{'db_sets'}->del('o:'.$tset.':'.$token);
1133 }
1134
1135 # Definitions manipulation
1136
1137 sub getDefinition
1138 {
1139     my $self = shift;
1140     my $name = shift;
1141     return $self->{'db_dsconfig'}->get( 'd:'.$name );
1142 }
1143
1144 sub getDefinitionNames
1145 {
1146     my $self = shift;
1147     return $self->{'db_dsconfig'}->getListItems( 'D:' );
1148 }
1149
1150
1151 1;
1152
1153
1154 # Local Variables:
1155 # mode: perl
1156 # indent-tabs-mode: nil
1157 # perl-indent-level: 4
1158 # End: