torrus/perllib/Torrus/DB.pm

   1 #  Copyright (C) 2002  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: DB.pm,v 1.1 2010-12-27 00:03:39 ivan Exp $
  18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
  19
  20 package Torrus::DB;
  21
  22 use Torrus::Log;
  23 use BerkeleyDB;
  24 use strict;
  25
  26
  27 # This is an abstraction layer for BerkeleyDB database operations
  28 #
  29 # Database opening:
  30 #    my $db = new Torrus::DB('db_name',
  31 #                          [ -Btree => 1, ]
  32 #                          [ -WriteAccess => 1, ]
  33 #                          [ -Truncate    => 1, ]
  34 #                          [ -Subdir      => 'dirname' ]);
  35 #    Defaults: Hash, read-only, no truncate.
  36 #
  37 # Database closing:
  38 #    undef $db;
  39 #
  40 # Database cleaning:
  41 #    $status = $db->trunc();
  42 #
  43
  44 END
  45 {
  46     &Torrus::DB::cleanupEnvironment();
  47 }
  48
  49 sub new
  50 {
  51     my $self = {};
  52     my $class = shift;
  53     my $dbname = shift;
  54     my %options = @_;
  55     bless $self, $class;
  56
  57     if( not defined($Torrus::DB::env) )
  58     {
  59         if( not defined $Torrus::Global::dbHome )
  60         {
  61             Error('$Torrus::Global::dbHome must be defined ' .
  62                   'in torrus_config.pl');
  63             return undef;
  64         }
  65         elsif( not -d $Torrus::Global::dbHome )
  66         {
  67             Error("No such directory: $Torrus::Global::dbHome" );
  68             return undef;
  69         }
  70         else
  71         {
  72             $Torrus::DB::dbEnvErrFile =
  73                 $Torrus::Global::logDir . '/dbenv_errlog_' . $$;
  74
  75             Debug("Creating BerkeleyDB::Env");
  76             umask 0002;
  77             $Torrus::DB::env =
  78                 new BerkeleyDB::Env(-Home  => $Torrus::Global::dbHome,
  79                                     -Flags => (DB_CREATE |
  80                                                DB_INIT_CDB | DB_INIT_MPOOL),
  81                                     -Mode  => 0664,
  82                                     -ErrFile => $Torrus::DB::dbEnvErrFile);
  83             if( not defined($Torrus::DB::env) )
  84             {
  85                 Error("Cannot create BerkeleyDB Environment: ".
  86                       $BerkeleyDB::Error);
  87                 return undef;
  88             }
  89         }
  90     }
  91
  92     my $filename = $dbname.'.db';
  93
  94     if( $options{'-Subdir'} )
  95     {
  96         my $dirname = $Torrus::Global::dbHome . '/' . $Torrus::DB::dbSub;
  97         if( not -d $dirname and not mkdir( $dirname ) )
  98         {
  99             Error("Cannot create directory $dirname: $!");
 100             return undef;
 101         }
 102         $dirname .= '/' . $options{'-Subdir'};
 103         if( not -d $dirname and not mkdir( $dirname ) )
 104         {
 105             Error("Cannot create directory $dirname: $!");
 106             return undef;
 107         }
 108         $filename =
 109             $Torrus::DB::dbSub . '/' . $options{'-Subdir'} . '/' . $filename;
 110     }
 111
 112     # we need this in DESTROY debug message
 113     $self->{'dbname'} = $filename;
 114
 115     my %hash;
 116
 117     my $accmethod = $options{'-Btree'} ?
 118         'BerkeleyDB::Btree':'BerkeleyDB::Hash';
 119
 120     my $flags = DB_RDONLY;
 121
 122     if( $options{'-WriteAccess'} )
 123     {
 124         $flags = DB_CREATE;
 125     }
 126
 127     my $property = 0;
 128     if( $options{'-Duplicates'} )
 129     {
 130         $property = DB_DUP | DB_DUPSORT;
 131     }
 132
 133     if( not exists( $Torrus::DB::dbPool{$filename} ) )
 134     {
 135         Debug('Opening ' . $self->{'dbname'});
 136
 137         my $dbh = new $accmethod (
 138                                   -Filename => $filename,
 139                                   -Flags    => $flags,
 140                                   -Property => $property,
 141                                   -Mode     => 0664,
 142                                   -Env      => $Torrus::DB::env );
 143         if( not $dbh )
 144         {
 145             Error("Cannot open database $filename: $! $BerkeleyDB::Error");
 146             return undef;
 147         }
 148
 149         $Torrus::DB::dbPool{$filename} = { 'dbh'        => $dbh,
 150                                            'accmethod'  => $accmethod,
 151                                            'flags'      => $flags };
 152
 153         $self->{'dbh'} = $dbh;
 154     }
 155     else
 156     {
 157         my $ref = $Torrus::DB::dbPool{$filename};
 158         if( $ref->{'accmethod'} eq $accmethod and $ref->{'flags'} eq $flags )
 159         {
 160             $self->{'dbh'} = $ref->{'dbh'};
 161         }
 162         else
 163         {
 164             Error('Database in dbPool has different flags: ' .
 165                   $self->{'dbname'});
 166             return undef;
 167         }
 168     }
 169
 170     if( $options{'-Truncate'} )
 171     {
 172         $self->trunc();
 173     }
 174
 175     if( $options{'-Delayed'} )
 176     {
 177         $self->{'delay_list_commit'} = 1;
 178     }
 179
 180     return $self;
 181 }
 182
 183
 184 # It is strongly inadvisable to do anything inside a signal handler when DB
 185 # operation is in progress
 186
 187 our $interrupted = 0;
 188
 189 my $signalHandlersSet = 0;
 190 my $safeSignals = 0;
 191
 192
 193
 194
 195
 196 sub setSignalHandlers
 197 {
 198     if( $signalHandlersSet )
 199     {
 200         return;
 201     }
 202
 203     $SIG{'TERM'} = sub {
 204         if( $safeSignals )
 205         {
 206             Warn('Received SIGTERM. Scheduling to exit.');
 207             $interrupted = 1;
 208         }
 209         else
 210         {
 211             Warn('Received SIGTERM. Stopping the process.');
 212             exit(1);
 213         }
 214     };
 215
 216     $SIG{'INT'} = sub {
 217         if( $safeSignals )
 218         {
 219             Warn('Received SIGINT. Scheduling to exit.');
 220             $interrupted = 1;
 221         }
 222         else
 223         {
 224             Warn('Received SIGINT. Stopping the process');
 225             exit(1);
 226         }
 227     };
 228
 229
 230     $SIG{'PIPE'} = sub {
 231         if( $safeSignals )
 232         {
 233             Warn('Received SIGPIPE. Scheduling to exit.');
 234             $interrupted = 1;
 235         }
 236         else
 237         {
 238             Warn('Received SIGPIPE. Stopping the process');
 239             exit(1);
 240         }
 241     };
 242
 243     $SIG{'QUIT'} = sub {
 244         if( $safeSignals )
 245         {
 246             Warn('Received SIGQUIT. Scheduling to exit.');
 247             $interrupted = 1;
 248         }
 249         else
 250         {
 251             Warn('Received SIGQUIT. Stopping the process');
 252             exit(1);
 253         }
 254     };
 255
 256     $signalHandlersSet = 1;
 257 }
 258
 259
 260 sub setSafeSignalHandlers
 261 {
 262     setSignalHandlers();
 263     $safeSignals = 1;
 264 }
 265
 266
 267 sub setUnsafeSignalHandlers
 268 {
 269     setSignalHandlers();
 270     $safeSignals = 0;
 271 }
 272
 273
 274 # If we were previously interrupted, gracefully exit now
 275
 276 sub checkInterrupted
 277 {
 278     if( $interrupted )
 279     {
 280         Warn('Stopping the process');
 281         exit(1);
 282     }
 283 }
 284
 285
 286
 287 sub closeNow
 288 {
 289     my $self = shift;
 290
 291     my $filename = $self->{'dbname'};
 292     Debug('Explicitly closing ' . $filename);
 293     delete $Torrus::DB::dbPool{$filename};
 294     $self->{'dbh'}->db_close();
 295     delete $self->{'dbh'};
 296 }
 297
 298 sub cleanupEnvironment
 299 {
 300     if( defined( $Torrus::DB::env ) )
 301     {
 302         foreach my $filename ( sort keys %Torrus::DB::dbPool )
 303         {
 304             Debug('Closing ' . $filename);
 305             $Torrus::DB::dbPool{$filename}->{'dbh'}->db_close();
 306             delete $Torrus::DB::dbPool{$filename};
 307         }
 308
 309         Debug("Destroying BerkeleyDB::Env");
 310         $Torrus::DB::env->close();
 311         $Torrus::DB::env = undef;
 312
 313         if( -z $Torrus::DB::dbEnvErrFile )
 314         {
 315             unlink $Torrus::DB::dbEnvErrFile;
 316         }
 317     }
 318 }
 319
 320
 321 sub delay
 322 {
 323     my $self = shift;
 324     $self->{'delay_list_commit'} = 1;
 325 }
 326
 327
 328
 329 sub trunc
 330 {
 331     my $self = shift;
 332
 333     Debug('Truncating ' . $self->{'dbname'});
 334     my $count = 0;
 335     return $self->{'dbh'}->truncate($count) == 0;
 336 }
 337
 338
 339 sub put
 340 {
 341     my $self = shift;
 342     my $key = shift;
 343     my $val = shift;
 344
 345     ref( $self->{'dbh'} ) or die( 'Fatal error: ' . $self->{'dbname'} );
 346     return $self->{'dbh'}->db_put($key, $val) == 0;
 347 }
 348
 349 sub get
 350 {
 351     my $self = shift;
 352     my $key = shift;
 353     my $val = undef;
 354
 355     $self->{'dbh'}->db_get($key, $val);
 356     return $val;
 357 }
 358
 359
 360 sub del
 361 {
 362     my $self = shift;
 363     my $key = shift;
 364     my $val = undef;
 365
 366     return $self->{'dbh'}->db_del($key) == 0;
 367 }
 368
 369
 370 sub cursor
 371 {
 372     my $self = shift;
 373     my %options = @_;
 374
 375     return $self->{'dbh'}->db_cursor( $options{'-Write'} ? DB_WRITECURSOR:0 );
 376 }
 377
 378
 379 sub next
 380 {
 381     my $self = shift;
 382     my $cursor = shift;
 383     my $key = '';
 384     my $val = '';
 385
 386     if( $cursor->c_get($key, $val, DB_NEXT) == 0 )
 387     {
 388         return ($key, $val);
 389     }
 390     else
 391     {
 392         return ();
 393     }
 394 }
 395
 396 sub c_del
 397 {
 398     my $self = shift;
 399     my $cursor = shift;
 400
 401     my $cnt = 0;
 402     $cursor->c_del( $cnt );
 403 }
 404
 405
 406 sub c_get
 407 {
 408     my $self = shift;
 409     my $cursor = shift;
 410     my $key = shift;
 411     my $val = undef;
 412
 413     if( $cursor->c_get( $key, $val, DB_SET ) == 0 )
 414     {
 415         return $val;
 416     }
 417     else
 418     {
 419         return undef;
 420     }
 421 }
 422
 423 sub c_put
 424 {
 425     my $self = shift;
 426     my $cursor = shift;
 427     my $key = shift;
 428     my $val = shift;
 429
 430     return ( $cursor->c_put( $key, $val, DB_KEYFIRST ) == 0 );
 431 }
 432
 433
 434
 435 # Btree best match. We assume that the searchKey is longer or equal
 436 # than the matched key in the database.
 437 #
 438 # If none found, returns undef.
 439 # If found, returns a hash with keys
 440 # "exact" => true when exact match found
 441 # "key"   => key as is stored in the database
 442 # "value" => value from the matched database entry
 443 # The found key is shorter or equal than searchKey, and is a prefix
 444 # of the searchKey
 445
 446 sub getBestMatch
 447 {
 448     my $self = shift;
 449     my $searchKey = shift;
 450
 451     my $key = $searchKey;
 452     my $searchLen = length( $searchKey );
 453     my $val = '';
 454     my $ret = {};
 455     my $ok = 0;
 456
 457     my $cursor = $self->{'dbh'}->db_cursor();
 458
 459     if( $cursor->c_get( $key, $val, DB_SET_RANGE ) == 0 )
 460     {
 461         if( $key eq $searchKey )
 462         {
 463             $ok = 1;
 464             $ret->{'exact'} = 1;
 465         }
 466         else
 467         {
 468             # the returned key/data pair is the smallest data item greater
 469             # than or equal to the specified data item.
 470             # The previous entry should be what we search for.
 471             if( $cursor->c_get( $key, $val, DB_PREV ) == 0 )
 472             {
 473                 if( length( $key ) < $searchLen and
 474                     index( $searchKey, $key ) == 0 )
 475                 {
 476                     $ok = 1;
 477                     $ret->{'key'} = $key;
 478                     $ret->{'value'} = $val;
 479                 }
 480             }
 481         }
 482     }
 483     else
 484     {
 485         if ( $cursor->c_get( $key, $val, DB_LAST ) == 0 )
 486         {
 487             if( length( $key ) < $searchLen and
 488                 index( $searchKey, $key ) == 0 )
 489             {
 490                 $ok = 1;
 491                 $ret->{'key'} = $key;
 492                 $ret->{'value'} = $val;
 493             }
 494         }
 495     }
 496
 497     return( $ok ? $ret : undef );
 498 }
 499
 500
 501 # Search the keys that match the specified prefix.
 502 # Return value is an array of [key,val] pairs or undef
 503 # Returned keys may be duplicated if the DB is created with -Duplicates
 504
 505 sub searchPrefix
 506 {
 507     my $self = shift;
 508     my $prefix = shift;
 509
 510     my $ret = [];
 511     my $ok = 0;
 512
 513     my $key = $prefix;
 514     my $val = '';
 515
 516     my $cursor = $self->{'dbh'}->db_cursor();
 517
 518     if( $cursor->c_get( $key, $val, DB_SET_RANGE ) == 0 )
 519     {
 520         # the returned key/data pair is the smallest data item greater
 521         # than or equal to the specified data item.
 522         my $finished = 0;
 523         while( not $finished )
 524         {
 525             if( index( $key, $prefix ) == 0 )
 526             {
 527                 $ok = 1;
 528                 push( @{$ret}, [ $key, $val ] );
 529
 530                 if( $cursor->c_get($key, $val, DB_NEXT) != 0 )
 531                 {
 532                     $finished = 1;
 533                 }
 534             }
 535             else
 536             {
 537                 $finished = 1;
 538             }
 539         }
 540     }
 541
 542     undef $cursor;
 543
 544     return( $ok ? $ret : undef );
 545 }
 546
 547
 548 # Search the keys that match the specified substring.
 549 # Return value is an array of [key,val] pairs or undef
 550 # Returned keys may be duplicated if the DB is created with -Duplicates
 551
 552 sub searchSubstring
 553 {
 554     my $self = shift;
 555     my $substring = shift;
 556
 557     my $ret = [];
 558     my $ok = 0;
 559
 560     my $key = '';
 561     my $val = '';
 562
 563     my $cursor = $self->{'dbh'}->db_cursor();
 564
 565     while( $cursor->c_get($key, $val, DB_NEXT) == 0 )
 566     {
 567         if( index( $key, $substring ) >= 0 )
 568         {
 569             $ok = 1;
 570             push( @{$ret}, [ $key, $val ] );
 571         }
 572     }
 573
 574     undef $cursor;
 575
 576     return( $ok ? $ret : undef );
 577 }
 578
 579
 580
 581
 582
 583 # Comma-separated list manipulation
 584
 585 sub _populateListCache
 586 {
 587     my $self = shift;
 588     my $key = shift;
 589
 590     if( not exists( $self->{'listcache'}{$key} ) )
 591     {
 592         my $ref = {};
 593         my $values = $self->get($key);
 594         if( defined( $values ) )
 595         {
 596             foreach my $val (split(/,/o, $values))
 597             {
 598                 $ref->{$val} = 1;
 599             }
 600         }
 601         $self->{'listcache'}{$key} = $ref;
 602     }
 603 }
 604
 605
 606 sub _storeListCache
 607 {
 608     my $self = shift;
 609     my $key = shift;
 610
 611     if( not $self->{'delay_list_commit'} )
 612     {
 613         $self->put($key, join(',', keys %{$self->{'listcache'}{$key}}));
 614     }
 615 }
 616
 617
 618 sub addToList
 619 {
 620     my $self = shift;
 621     my $key = shift;
 622     my $newval = shift;
 623
 624     $self->_populateListCache($key);
 625
 626     $self->{'listcache'}{$key}{$newval} = 1;
 627
 628     $self->_storeListCache($key);
 629 }
 630
 631
 632 sub searchList
 633 {
 634     my $self = shift;
 635     my $key = shift;
 636     my $name = shift;
 637
 638     $self->_populateListCache($key);
 639     return $self->{'listcache'}{$key}{$name};
 640 }
 641
 642
 643 sub delFromList
 644 {
 645     my $self = shift;
 646     my $key = shift;
 647     my $name = shift;
 648
 649     $self->_populateListCache($key);
 650     if( $self->{'listcache'}{$key}{$name} )
 651     {
 652         delete $self->{'listcache'}{$key}{$name};
 653     }
 654
 655     $self->_storeListCache($key);
 656 }
 657
 658
 659 sub getListItems
 660 {
 661     my $self = shift;
 662     my $key = shift;
 663
 664     $self->_populateListCache($key);
 665     return keys %{$self->{'listcache'}{$key}};
 666 }
 667
 668
 669
 670 sub deleteList
 671 {
 672     my $self = shift;
 673     my $key = shift;
 674
 675     delete $self->{'listcache'}{$key};
 676     $self->del($key);
 677 }
 678
 679
 680 sub commit
 681 {
 682     my $self = shift;
 683
 684     if( $self->{'delay_list_commit'} and
 685         defined( $self->{'listcache'} ) )
 686     {
 687         while( my($key, $list) = each %{$self->{'listcache'}} )
 688         {
 689             $self->put($key, join(',', keys %{$list}));
 690         }
 691     }
 692 }
 693
 694
 695
 696 1;
 697
 698
 699 # Local Variables:
 700 # mode: perl
 701 # indent-tabs-mode: nil
 702 # perl-indent-level: 4
 703 # End: