开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 数据库系统 > MySQL数据库 > 查看源码
BerkeleyDB.pm
资源名称：mysql-3.23.35.tar.gz　[点击查看]
上传用户：tsgydb
上传日期：2007-04-14
资源大小：10674k
文件大小：25k
源码类别：

MySQL数据库

开发平台：

Visual C++

BerkeleyDB.pm：源码内容
  2. package BerkeleyDB;
  5. #     Copyright (c) 1997-2001 Paul Marquess. All rights reserved.
  6. #     This program is free software; you can redistribute it and/or
  7. #     modify it under the same terms as Perl itself.
  8. #
  10. # The documentation for this module is at the bottom of this file,
  11. # after the line __END__.
  13. BEGIN { require 5.004_04 }
  15. use strict;
  16. use Carp;
  17. use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
  19. $VERSION = '0.13';
  21. require Exporter;
  22. require DynaLoader;
  23. require AutoLoader;
  24. use IO ;
  26. @ISA = qw(Exporter DynaLoader);
  27. # Items to export into callers namespace by default. Note: do not export
  28. # names by default without a very good reason. Use EXPORT_OK instead.
  29. # Do not simply export all your public functions/methods/constants.
  30. @EXPORT = qw(
  32. DB_AFTER
  33. DB_APPEND
  34. DB_ARCH_ABS
  35. DB_ARCH_DATA
  36. DB_ARCH_LOG
  37. DB_BEFORE
  38. DB_BTREE
  39. DB_BTREEMAGIC
  40. DB_BTREEOLDVER
  41. DB_BTREEVERSION
  42. DB_CHECKPOINT
  43. DB_CONSUME
  44. DB_CREATE
  45. DB_CURLSN
  46. DB_CURRENT
  47. DB_DBT_MALLOC
  48. DB_DBT_PARTIAL
  49. DB_DBT_USERMEM
  50. DB_DELETED
  51. DB_DELIMITER
  52. DB_DUP
  53. DB_DUPSORT
  54. DB_ENV_APPINIT
  55. DB_ENV_STANDALONE
  56. DB_ENV_THREAD
  57. DB_EXCL
  58. DB_FILE_ID_LEN
  59. DB_FIRST
  60. DB_FIXEDLEN
  61. DB_FLUSH
  62. DB_FORCE
  63. DB_GET_BOTH
  64. DB_GET_RECNO
  65. DB_HASH
  66. DB_HASHMAGIC
  67. DB_HASHOLDVER
  68. DB_HASHVERSION
  69. DB_INCOMPLETE
  70. DB_INIT_CDB
  71. DB_INIT_LOCK
  72. DB_INIT_LOG
  73. DB_INIT_MPOOL
  74. DB_INIT_TXN
  75. DB_JOIN_ITEM
  76. DB_KEYEMPTY
  77. DB_KEYEXIST
  78. DB_KEYFIRST
  79. DB_KEYLAST
  80. DB_LAST
  81. DB_LOCKMAGIC
  82. DB_LOCKVERSION
  83. DB_LOCK_CONFLICT
  84. DB_LOCK_DEADLOCK
  85. DB_LOCK_DEFAULT
  86. DB_LOCK_GET
  87. DB_LOCK_NORUN
  88. DB_LOCK_NOTGRANTED
  89. DB_LOCK_NOTHELD
  90. DB_LOCK_NOWAIT
  91. DB_LOCK_OLDEST
  92. DB_LOCK_RANDOM
  93. DB_LOCK_RIW_N
  94. DB_LOCK_RW_N
  95. DB_LOCK_YOUNGEST
  96. DB_LOGMAGIC
  97. DB_LOGOLDVER
  98. DB_MAX_PAGES
  99. DB_MAX_RECORDS
  100. DB_MPOOL_CLEAN
  101. DB_MPOOL_CREATE
  102. DB_MPOOL_DIRTY
  103. DB_MPOOL_DISCARD
  104. DB_MPOOL_LAST
  105. DB_MPOOL_NEW
  106. DB_MPOOL_PRIVATE
  107. DB_MUTEXDEBUG
  108. DB_MUTEXLOCKS
  109. DB_NEEDSPLIT
  110. DB_NEXT
  111. DB_NEXT_DUP
  112. DB_NOMMAP
  113. DB_NOOVERWRITE
  114. DB_NOSYNC
  115. DB_NOTFOUND
  116. DB_PAD
  117. DB_PAGEYIELD
  118. DB_POSITION
  119. DB_PREV
  120. DB_PRIVATE
  121. DB_QUEUE
  122. DB_RDONLY
  123. DB_RECNO
  124. DB_RECNUM
  125. DB_RECORDCOUNT
  126. DB_RECOVER
  127. DB_RECOVER_FATAL
  128. DB_REGISTERED
  129. DB_RENUMBER
  130. DB_RMW
  131. DB_RUNRECOVERY
  132. DB_SEQUENTIAL
  133. DB_SET
  134. DB_SET_RANGE
  135. DB_SET_RECNO
  136. DB_SNAPSHOT
  137. DB_SWAPBYTES
  138. DB_TEMPORARY
  139. DB_THREAD
  140. DB_TRUNCATE
  141. DB_TXNMAGIC
  142. DB_TXNVERSION
  143. DB_TXN_BACKWARD_ROLL
  144. DB_TXN_CKP
  145. DB_TXN_FORWARD_ROLL
  146. DB_TXN_LOCK_2PL
  147. DB_TXN_LOCK_MASK
  148. DB_TXN_LOCK_OPTIMIST
  149. DB_TXN_LOCK_OPTIMISTIC
  150. DB_TXN_LOG_MASK
  151. DB_TXN_LOG_REDO
  152. DB_TXN_LOG_UNDO
  153. DB_TXN_LOG_UNDOREDO
  154. DB_TXN_NOSYNC
  155. DB_TXN_NOWAIT
  156. DB_TXN_OPENFILES
  157. DB_TXN_REDO
  158. DB_TXN_SYNC
  159. DB_TXN_UNDO
  160. DB_USE_ENVIRON
  161. DB_USE_ENVIRON_ROOT
  162. DB_VERSION_MAJOR
  163. DB_VERSION_MINOR
  164. DB_VERSION_PATCH
  165. DB_WRITECURSOR
  166. );
  168. sub AUTOLOAD {
  169.     # This AUTOLOAD is used to 'autoload' constants from the constant()
  170.     # XS function.  If a constant is not found then control is passed
  171.     # to the AUTOLOAD in AutoLoader.
  173.     my $constname;
  174.     ($constname = $AUTOLOAD) =~ s/.*:://;
  175.     my $val = constant($constname, @_ ? $_[0] : 0);
  176.     if ($! != 0) {
  177. if ($! =~ /Invalid/) {
  178.     $AutoLoader::AUTOLOAD = $AUTOLOAD;
  179.     goto &AutoLoader::AUTOLOAD;
  180. }
  181. else {
  182. croak "Your vendor has not defined BerkeleyDB macro $constname";
  183. }
  184.     }
  185.     eval "sub $AUTOLOAD { $val }";
  186.     goto &$AUTOLOAD;
  187. }
  189. bootstrap BerkeleyDB $VERSION;
  191. # Preloaded methods go here.
  194. sub ParseParameters($@)
  195. {
  196.     my ($default, @rest) = @_ ;
  197.     my (%got) = %$default ;
  198.     my (@Bad) ;
  199.     my ($key, $value) ;
  200.     my $sub = (caller(1))[3] ;
  201.     my %options = () ;
  202.     local ($Carp::CarpLevel) = 1 ;
  204.     # allow the options to be passed as a hash reference or
  205.     # as the complete hash.
  206.     if (@rest == 1) {
  208.         croak "$sub: parameter is not a reference to a hash"
  209.             if ref $rest[0] ne "HASH" ;
  211.         %options = %{ $rest[0] } ;
  212.     }
  213.     elsif (@rest >= 2) {
  214.         %options = @rest ;
  215.     }
  217.     while (($key, $value) = each %options)
  218.     {
  219. $key =~ s/^-// ;
  221.         if (exists $default->{$key})
  222.           { $got{$key} = $value }
  223.         else
  224.   { push (@Bad, $key) }
  225.     }
  226.     
  227.     if (@Bad) {
  228.         my ($bad) = join(", ", @Bad) ;
  229.         croak "unknown key value(s) @Bad" ;
  230.     }
  232.     return %got ;
  233. }
  235. use UNIVERSAL qw( isa ) ;
  237. sub env_remove
  238. {
  239.     # Usage:
  240.     #
  241.     # $env = new BerkeleyDB::Env
  242.     # [ -Home => $path, ]
  243.     # [ -Config => { name => value, name => value }
  244.     # [ -Flags => DB_INIT_LOCK| ]
  245.     # ;
  247.     my $got = BerkeleyDB::ParseParameters({
  248. Home => undef,
  249. Flags      => 0,
  250. Config => undef,
  251. }, @_) ;
  253.     if (defined $got->{ErrFile}) {
  254. if (!isaFilehandle($got->{ErrFile})) {
  255.     my $handle = new IO::File ">$got->{ErrFile}"
  256. or croak "Cannot open file $got->{ErrFile}: $!n" ;
  257.     $got->{ErrFile} = $handle ;
  258. }
  259.     }
  261.     
  262.     if (defined $got->{Config}) {
  263.      croak("Config parameter must be a hash reference")
  264.             if ! ref $got->{Config} eq 'HASH' ;
  266.         @BerkeleyDB::a = () ;
  267. my $k = "" ; my $v = "" ;
  268. while (($k, $v) = each %{$got->{Config}}) {
  269.     push @BerkeleyDB::a, "$kt$v" ;
  270. }
  272.         $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) 
  273.     if @BerkeleyDB::a ;
  274.     }
  276.     return _env_remove($got) ;
  277. }
  279. sub db_remove
  280. {
  281.     my $got = BerkeleyDB::ParseParameters(
  282.       {
  283. Filename  => undef,
  284. Subname => undef,
  285. Flags => 0,
  286. Env => undef,
  287.       }, @_) ;
  289.     croak("Must specify a filename")
  290. if ! defined $got->{Filename} ;
  292.     croak("Env not of type BerkeleyDB::Env")
  293. if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  295.     return _db_remove($got);
  296. }
  298. package BerkeleyDB::Env ;
  300. use UNIVERSAL qw( isa ) ;
  301. use Carp ;
  302. use vars qw( %valid_config_keys ) ;
  304. sub isaFilehandle
  305. {
  306.     my $fh = shift ;
  308.     return ((isa($fh,'GLOB') or isa($fh,'GLOB')) and defined fileno($fh) )
  310. }
  312. %valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR ) ;
  314. sub new
  315. {
  316.     # Usage:
  317.     #
  318.     # $env = new BerkeleyDB::Env
  319.     # [ -Home => $path, ]
  320.     # [ -Mode => mode, ]
  321.     # [ -Config => { name => value, name => value }
  322.     # [ -ErrFile    => filename or filehandle, ]
  323.     # [ -ErrPrefix  => "string", ]
  324.     # [ -Flags => DB_INIT_LOCK| ]
  325.     # [ -Cachesize => number ]
  326.     # [ -LockDetect =>  ]
  327.     # [ -Verbose => boolean ]
  328.     # ;
  330.     my $pkg = shift ;
  331.     my $got = BerkeleyDB::ParseParameters({
  332. Home => undef,
  333. Server => undef,
  334. Mode => 0666,
  335. ErrFile   => undef,
  336. ErrPrefix  => undef,
  337. Flags      => 0,
  338. Cachesize      => 0,
  339. LockDetect      => 0,
  340. Verbose => 0,
  341. Config => undef,
  342. }, @_) ;
  344.     if (defined $got->{ErrFile}) {
  345. if (!isaFilehandle($got->{ErrFile})) {
  346.     my $handle = new IO::File ">$got->{ErrFile}"
  347. or croak "Cannot open file $got->{ErrFile}: $!n" ;
  348.     $got->{ErrFile} = $handle ;
  349. }
  350.     }
  352.     
  353.     my %config ;
  354.     if (defined $got->{Config}) {
  355.      croak("Config parameter must be a hash reference")
  356.             if ! ref $got->{Config} eq 'HASH' ;
  358. %config = %{ $got->{Config} } ;
  359.         @BerkeleyDB::a = () ;
  360. my $k = "" ; my $v = "" ;
  361. while (($k, $v) = each %config) {
  362.     if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ) {
  363.         $BerkeleyDB::Error = "illegal name-value pair: $k $vn" ; 
  364.                 croak $BerkeleyDB::Error ;
  365.     }
  366.     push @BerkeleyDB::a, "$kt$v" ;
  367. }
  369.         $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) 
  370.     if @BerkeleyDB::a ;
  371.     }
  373.     my ($addr) = _db_appinit($pkg, $got) ;
  374.     my $obj ;
  375.     $obj = bless [$addr] , $pkg if $addr ;
  376.     if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) {
  377. my ($k, $v);
  378. while (($k, $v) = each %config) {
  379.     if ($k eq 'DB_DATA_DIR')
  380.       { $obj->set_data_dir($v) }
  381.     elsif ($k eq 'DB_LOG_DIR')
  382.       { $obj->set_lg_dir($v) }
  383.     elsif ($k eq 'DB_TEMP_DIR')
  384.       { $obj->set_tmp_dir($v) }
  385.     else {
  386.       $BerkeleyDB::Error = "illegal name-value pair: $k $vn" ; 
  387.               croak $BerkeleyDB::Error 
  388.             }
  389. }
  390.     }
  391.     return $obj ;
  392. }
  395. sub TxnMgr
  396. {
  397.     my $env = shift ;
  398.     my ($addr) = $env->_TxnMgr() ;
  399.     my $obj ;
  400.     $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ;
  401.     return $obj ;
  402. }
  404. sub txn_begin
  405. {
  406.     my $env = shift ;
  407.     my ($addr) = $env->_txn_begin(@_) ;
  408.     my $obj ;
  409.     $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ;
  410.     return $obj ;
  411. }
  413. sub DESTROY
  414. {
  415.     my $self = shift ;
  416.     $self->_DESTROY() ;
  417. }
  419. package BerkeleyDB::Hash ;
  421. use vars qw(@ISA) ;
  422. @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
  423. use UNIVERSAL qw( isa ) ;
  424. use Carp ;
  426. sub new
  427. {
  428.     my $self = shift ;
  429.     my $got = BerkeleyDB::ParseParameters(
  430.       {
  431. # Generic Stuff
  432. Filename  => undef,
  433. Subname => undef,
  434. #Flags => BerkeleyDB::DB_CREATE(),
  435. Flags => 0,
  436. Property => 0,
  437. Mode => 0666,
  438. Cachesize  => 0,
  439. Lorder  => 0,
  440. Pagesize  => 0,
  441. Env => undef,
  442. #Tie  => undef,
  443. Txn => undef,
  445. # Hash specific
  446. Ffactor => 0,
  447. Nelem  => 0,
  448. Hash  => undef,
  449. DupCompare => undef,
  451. # BerkeleyDB specific
  452. ReadKey => undef,
  453. WriteKey => undef,
  454. ReadValue => undef,
  455. WriteValue => undef,
  456.       }, @_) ;
  458.     croak("Env not of type BerkeleyDB::Env")
  459. if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  461.     croak("Txn not of type BerkeleyDB::Txn")
  462. if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
  464.     croak("-Tie needs a reference to a hash")
  465. if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
  467.     my ($addr) = _db_open_hash($self, $got);
  468.     my $obj ;
  469.     if ($addr) {
  470.         $obj = bless [$addr] , $self ;
  471. push @{ $obj }, $got->{Env} if $got->{Env} ;
  472.         $obj->Txn($got->{Txn}) if $got->{Txn} ;
  473.     }
  474.     return $obj ;
  475. }
  477. *TIEHASH = &new ;
  479.  
  480. package BerkeleyDB::Btree ;
  482. use vars qw(@ISA) ;
  483. @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
  484. use UNIVERSAL qw( isa ) ;
  485. use Carp ;
  487. sub new
  488. {
  489.     my $self = shift ;
  490.     my $got = BerkeleyDB::ParseParameters(
  491.       {
  492. # Generic Stuff
  493. Filename  => undef,
  494. Subname => undef,
  495. #Flags => BerkeleyDB::DB_CREATE(),
  496. Flags => 0,
  497. Property => 0,
  498. Mode => 0666,
  499. Cachesize  => 0,
  500. Lorder  => 0,
  501. Pagesize  => 0,
  502. Env => undef,
  503. #Tie  => undef,
  504. Txn => undef,
  506. # Btree specific
  507. Minkey => 0,
  508. Compare => undef,
  509. DupCompare => undef,
  510. Prefix  => undef,
  511.       }, @_) ;
  513.     croak("Env not of type BerkeleyDB::Env")
  514. if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  516.     croak("Txn not of type BerkeleyDB::Txn")
  517. if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
  519.     croak("-Tie needs a reference to a hash")
  520. if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
  522.     my ($addr) = _db_open_btree($self, $got);
  523.     my $obj ;
  524.     if ($addr) {
  525.         $obj = bless [$addr] , $self ;
  526. push @{ $obj }, $got->{Env} if $got->{Env} ;
  527.         $obj->Txn($got->{Txn}) if $got->{Txn} ;
  528.     }
  529.     return $obj ;
  530. }
  532. *BerkeleyDB::Btree::TIEHASH = &BerkeleyDB::Btree::new ;
  535. package BerkeleyDB::Recno ;
  537. use vars qw(@ISA) ;
  538. @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
  539. use UNIVERSAL qw( isa ) ;
  540. use Carp ;
  542. sub new
  543. {
  544.     my $self = shift ;
  545.     my $got = BerkeleyDB::ParseParameters(
  546.       {
  547. # Generic Stuff
  548. Filename  => undef,
  549. Subname => undef,
  550. #Flags => BerkeleyDB::DB_CREATE(),
  551. Flags => 0,
  552. Property => 0,
  553. Mode => 0666,
  554. Cachesize  => 0,
  555. Lorder  => 0,
  556. Pagesize  => 0,
  557. Env => undef,
  558. #Tie  => undef,
  559. Txn => undef,
  561. # Recno specific
  562. Delim => undef,
  563. Len => undef,
  564. Pad => undef,
  565. Source  => undef,
  566. ArrayBase  => 1, # lowest index in array
  567.       }, @_) ;
  569.     croak("Env not of type BerkeleyDB::Env")
  570. if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  572.     croak("Txn not of type BerkeleyDB::Txn")
  573. if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
  575.     croak("Tie needs a reference to an array")
  576. if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
  578.     croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
  579. if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;
  582.     $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;
  584.     my ($addr) = _db_open_recno($self, $got);
  585.     my $obj ;
  586.     if ($addr) {
  587.         $obj = bless [$addr] , $self ;
  588. push @{ $obj }, $got->{Env} if $got->{Env} ;
  589.         $obj->Txn($got->{Txn}) if $got->{Txn} ;
  590.     }
  591.     return $obj ;
  592. }
  594. *BerkeleyDB::Recno::TIEARRAY = &BerkeleyDB::Recno::new ;
  595. *BerkeleyDB::Recno::db_stat = &BerkeleyDB::Btree::db_stat ;
  597. package BerkeleyDB::Queue ;
  599. use vars qw(@ISA) ;
  600. @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
  601. use UNIVERSAL qw( isa ) ;
  602. use Carp ;
  604. sub new
  605. {
  606.     my $self = shift ;
  607.     my $got = BerkeleyDB::ParseParameters(
  608.       {
  609. # Generic Stuff
  610. Filename  => undef,
  611. Subname => undef,
  612. #Flags => BerkeleyDB::DB_CREATE(),
  613. Flags => 0,
  614. Property => 0,
  615. Mode => 0666,
  616. Cachesize  => 0,
  617. Lorder  => 0,
  618. Pagesize  => 0,
  619. Env => undef,
  620. #Tie  => undef,
  621. Txn => undef,
  623. # Queue specific
  624. Len => undef,
  625. Pad => undef,
  626. ArrayBase  => 1, # lowest index in array
  627. ExtentSize      => undef,
  628.       }, @_) ;
  630.     croak("Env not of type BerkeleyDB::Env")
  631. if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  633.     croak("Txn not of type BerkeleyDB::Txn")
  634. if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
  636.     croak("Tie needs a reference to an array")
  637. if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
  639.     croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
  640. if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;
  643.     my ($addr) = _db_open_queue($self, $got);
  644.     my $obj ;
  645.     if ($addr) {
  646.         $obj = bless [$addr] , $self ;
  647. push @{ $obj }, $got->{Env} if $got->{Env} ;
  648.         $obj->Txn($got->{Txn}) if $got->{Txn} ;
  649.     }
  650.     return $obj ;
  651. }
  653. *BerkeleyDB::Queue::TIEARRAY = &BerkeleyDB::Queue::new ;
  655. ## package BerkeleyDB::Text ;
  656. ## 
  657. ## use vars qw(@ISA) ;
  658. ## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
  659. ## use UNIVERSAL qw( isa ) ;
  660. ## use Carp ;
  661. ## 
  662. ## sub new
  663. ## {
  664. ##     my $self = shift ;
  665. ##     my $got = BerkeleyDB::ParseParameters(
  666. ##        {
  667. ##  # Generic Stuff
  668. ##  Filename  => undef,
  669. ##  #Flags => BerkeleyDB::DB_CREATE(),
  670. ##  Flags => 0,
  671. ##  Property => 0,
  672. ##  Mode => 0666,
  673. ##  Cachesize  => 0,
  674. ##  Lorder  => 0,
  675. ##  Pagesize  => 0,
  676. ##  Env => undef,
  677. ##  #Tie  => undef,
  678. ##  Txn => undef,
  679. ## 
  680. ##  # Recno specific
  681. ##  Delim => undef,
  682. ##  Len => undef,
  683. ##  Pad => undef,
  684. ##  Btree  => undef,
  685. ##        }, @_) ;
  686. ## 
  687. ##     croak("Env not of type BerkeleyDB::Env")
  688. ##  if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  689. ## 
  690. ##     croak("Txn not of type BerkeleyDB::Txn")
  691. ##  if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
  692. ## 
  693. ##     croak("-Tie needs a reference to an array")
  694. ##  if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
  695. ## 
  696. ##     # rearange for recno
  697. ##     $got->{Source} = $got->{Filename} if defined $got->{Filename} ;
  698. ##     delete $got->{Filename} ;
  699. ##     $got->{Fname} = $got->{Btree} if defined $got->{Btree} ;
  700. ##     return BerkeleyDB::Recno::_db_open_recno($self, $got);
  701. ## }
  702. ## 
  703. ## *BerkeleyDB::Text::TIEARRAY = &BerkeleyDB::Text::new ;
  704. ## *BerkeleyDB::Text::db_stat = &BerkeleyDB::Btree::db_stat ;
  706. package BerkeleyDB::Unknown ;
  708. use vars qw(@ISA) ;
  709. @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
  710. use UNIVERSAL qw( isa ) ;
  711. use Carp ;
  713. sub new
  714. {
  715.     my $self = shift ;
  716.     my $got = BerkeleyDB::ParseParameters(
  717.       {
  718. # Generic Stuff
  719. Filename  => undef,
  720. Subname => undef,
  721. #Flags => BerkeleyDB::DB_CREATE(),
  722. Flags => 0,
  723. Property => 0,
  724. Mode => 0666,
  725. Cachesize  => 0,
  726. Lorder  => 0,
  727. Pagesize  => 0,
  728. Env => undef,
  729. #Tie  => undef,
  730. Txn => undef,
  732.       }, @_) ;
  734.     croak("Env not of type BerkeleyDB::Env")
  735. if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
  737.     croak("Txn not of type BerkeleyDB::Txn")
  738. if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
  740.     croak("-Tie needs a reference to a hash")
  741. if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;
  743.     my ($addr, $type) = _db_open_unknown($got);
  744.     my $obj ;
  745.     if ($addr) {
  746.         $obj = bless [$addr], "BerkeleyDB::$type" ;
  747. push @{ $obj }, $got->{Env} if $got->{Env} ;
  748.         $obj->Txn($got->{Txn}) if $got->{Txn} ;
  749.     }
  750.     return $obj ;
  751. }
  754. package BerkeleyDB::_tiedHash ;
  756. use Carp ;
  758. #sub TIEHASH  
  759. #{ 
  760. #    my $self = shift ;
  761. #    my $db_object = shift ;
  762. #
  763. #print "Tiehash REF=[$self] [" . (ref $self) . "]n" ;
  764. #
  765. #    return bless { Obj => $db_object}, $self ; 
  766. #}
  768. sub Tie
  769. {
  770.     # Usage:
  771.     #
  772.     #   $db->Tie %hash ;
  773.     #
  775.     my $self = shift ;
  777.     #print "Tie method REF=[$self] [" . (ref $self) . "]n" ;
  779.     croak("usage $x->Tie \%hashn") unless @_ ;
  780.     my $ref  = shift ; 
  782.     croak("Tie needs a reference to a hash")
  783. if defined $ref and $ref !~ /HASH/ ;
  785.     #tie %{ $ref }, ref($self), $self ; 
  786.     tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ; 
  787.     return undef ;
  788. }
  790.  
  791. sub TIEHASH  
  792. { 
  793.     my $self = shift ;
  794.     my $db_object = shift ;
  795.     #return bless $db_object, 'BerkeleyDB::Common' ; 
  796.     return $db_object ;
  797. }
  799. sub STORE
  800. {
  801.     my $self = shift ;
  802.     my $key  = shift ;
  803.     my $value = shift ;
  805.     $self->db_put($key, $value) ;
  806. }
  808. sub FETCH
  809. {
  810.     my $self = shift ;
  811.     my $key  = shift ;
  812.     my $value = undef ;
  813.     $self->db_get($key, $value) ;
  815.     return $value ;
  816. }
  818. sub EXISTS
  819. {
  820.     my $self = shift ;
  821.     my $key  = shift ;
  822.     my $value = undef ;
  823.     $self->db_get($key, $value) == 0 ;
  824. }
  826. sub DELETE
  827. {
  828.     my $self = shift ;
  829.     my $key  = shift ;
  830.     $self->db_del($key) ;
  831. }
  833. sub CLEAR
  834. {
  835.     my $self = shift ;
  836.     my ($key, $value) = (0, 0) ;
  837.     my $cursor = $self->db_cursor() ;
  838.     while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0) 
  839. { $cursor->c_del() }
  840.     #1 while $cursor->c_del() == 0 ;
  841.     # cursor will self-destruct
  842. }
  844. #sub DESTROY
  845. #{
  846. #    my $self = shift ;
  847. #    print "BerkeleyDB::_tieHash::DESTROYn" ;
  848. #    $self->{Cursor}->c_close() if $self->{Cursor} ;
  849. #}
  851. package BerkeleyDB::_tiedArray ;
  853. use Carp ;
  855. sub Tie
  856. {
  857.     # Usage:
  858.     #
  859.     #   $db->Tie @array ;
  860.     #
  862.     my $self = shift ;
  864.     #print "Tie method REF=[$self] [" . (ref $self) . "]n" ;
  866.     croak("usage $x->Tie \%hashn") unless @_ ;
  867.     my $ref  = shift ; 
  869.     croak("Tie needs a reference to an array")
  870. if defined $ref and $ref !~ /ARRAY/ ;
  872.     #tie %{ $ref }, ref($self), $self ; 
  873.     tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ; 
  874.     return undef ;
  875. }
  877.  
  878. #sub TIEARRAY  
  879. #{ 
  880. #    my $self = shift ;
  881. #    my $db_object = shift ;
  882. #
  883. #print "Tiearray REF=[$self] [" . (ref $self) . "]n" ;
  884. #
  885. #    return bless { Obj => $db_object}, $self ; 
  886. #}
  888. sub TIEARRAY  
  889. { 
  890.     my $self = shift ;
  891.     my $db_object = shift ;
  892.     #return bless $db_object, 'BerkeleyDB::Common' ; 
  893.     return $db_object ;
  894. }
  896. sub STORE
  897. {
  898.     my $self = shift ;
  899.     my $key  = shift ;
  900.     my $value = shift ;
  902.     $self->db_put($key, $value) ;
  903. }
  905. sub FETCH
  906. {
  907.     my $self = shift ;
  908.     my $key  = shift ;
  909.     my $value = undef ;
  910.     $self->db_get($key, $value) ;
  912.     return $value ;
  913. }
  915. *CLEAR =    &BerkeleyDB::_tiedHash::CLEAR ;
  916. *FIRSTKEY = &BerkeleyDB::_tiedHash::FIRSTKEY ;
  917. *NEXTKEY =  &BerkeleyDB::_tiedHash::NEXTKEY ;
  919. sub EXTEND {} # don't do anything with EXTEND
  922. sub SHIFT
  923. {
  924.     my $self = shift;
  925.     my ($key, $value) = (0, 0) ;
  926.     my $cursor = $self->db_cursor() ;
  927.     return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ;
  928.     return undef if $cursor->c_del() != 0 ;
  930.     return $value ;
  931. }
  934. sub UNSHIFT
  935. {
  936.     my $self = shift;
  937.     croak "unshift is unsupported with Queue databases"
  938.         if $self->type == BerkeleyDB::DB_QUEUE() ;
  939.     if (@_)
  940.     {
  941.         my ($key, $value) = (0, 0) ;
  942.         my $cursor = $self->db_cursor() ;
  943.         if ($cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) == 0) 
  944.         {
  945.             foreach $value (reverse @_)
  946.             {
  947.         $key = 0 ;
  948.         $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ;
  949.             }
  950.         }
  951.     }
  952. }
  954. sub PUSH
  955. {
  956.     my $self = shift;
  957.     if (@_)
  958.     {
  959.         my ($key, $value) = (0, 0) ;
  960.         my $cursor = $self->db_cursor() ;
  961.         if ($cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) == 0)
  962. {
  963.             foreach $value (@_)
  964.     {
  965.         ++ $key ;
  966.         $self->db_put($key, $value) ;
  967.     }
  968. }
  970. # can use this when DB_APPEND is fixed.
  971. #        foreach $value (@_)
  972. #        {
  973. #     my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ;
  974. #print "[$status]n" ;
  975. #        }
  976.     }
  977. }
  979. sub POP
  980. {
  981.     my $self = shift;
  982.     my ($key, $value) = (0, 0) ;
  983.     my $cursor = $self->db_cursor() ;
  984.     return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ;
  985.     return undef if $cursor->c_del() != 0 ;
  987.     return $value ;
  988. }
  990. sub SPLICE
  991. {
  992.     my $self = shift;
  993.     croak "SPLICE is not implemented yet" ;
  994. }
  996. *shift = &SHIFT ;
  997. *unshift = &UNSHIFT ;
  998. *push = &PUSH ;
  999. *pop = &POP ;
  1000. *clear = &CLEAR ;
  1001. *length = &FETCHSIZE ;
  1003. sub STORESIZE
  1004. {
  1005.     croak "STORESIZE is not implemented yet" ;
  1006. #print "STORESIZE @_n" ;
  1007. #    my $self = shift;
  1008. #    my $length = shift ;
  1009. #    my $current_length = $self->FETCHSIZE() ;
  1010. #print "length is $current_lengthn";
  1011. #
  1012. #    if ($length < $current_length) {
  1013. #print "Make smaller $length < $current_lengthn" ;
  1014. #        my $key ;
  1015. #        for ($key = $current_length - 1 ; $key >= $length ; -- $key)
  1016. #          { $self->db_del($key) }
  1017. #    }
  1018. #    elsif ($length > $current_length) {
  1019. #print "Make larger $length > $current_lengthn" ;
  1020. #        $self->db_put($length-1, "") ;
  1021. #    }
  1022. #    else { print "stay the samen" }
  1024. }
  1028. #sub DESTROY
  1029. #{
  1030. #    my $self = shift ;
  1031. #    print "BerkeleyDB::_tieArray::DESTROYn" ;
  1032. #}
  1035. package BerkeleyDB::Common ;
  1038. use Carp ;
  1040. sub DESTROY
  1041. {
  1042.     my $self = shift ;
  1043.     $self->_DESTROY() ;
  1044. }
  1046. sub Txn
  1047. {
  1048.     my $self = shift ;
  1049.     my $txn  = shift ;
  1050.     #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]n" ;
  1051.     if ($txn) {
  1052.         $self->_Txn($txn) ;
  1053.         push @{ $txn }, $self ;
  1054.     }
  1055.     else {
  1056.         $self->_Txn() ;
  1057.     }
  1058.     #print "end BerkeleyDB::Common::Txn n";
  1059. }
  1062. sub get_dup
  1063. {
  1064.     croak "Usage: $db->get_dup(key [,flag])n"
  1065.         unless @_ == 2 or @_ == 3 ;
  1066.  
  1067.     my $db        = shift ;
  1068.     my $key       = shift ;
  1069.     my $flag   = shift ;
  1070.     my $value    = 0 ;
  1071.     my $origkey   = $key ;
  1072.     my $wantarray = wantarray ;
  1073.     my %values   = () ;
  1074.     my @values    = () ;
  1075.     my $counter   = 0 ;
  1076.     my $status    = 0 ;
  1077.     my $cursor    = $db->db_cursor() ;
  1078.  
  1079.     # iterate through the database until either EOF ($status == 0)
  1080.     # or a different key is encountered ($key ne $origkey).
  1081.     for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ;
  1082.  $status == 0 and $key eq $origkey ;
  1083.          $status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) {
  1084.         # save the value or count number of matches
  1085.         if ($wantarray) {
  1086.     if ($flag)
  1087.                 { ++ $values{$value} }
  1088.     else
  1089.                 { push (@values, $value) }
  1090. }
  1091.         else
  1092.             { ++ $counter }
  1093.      
  1094.     }
  1095.  
  1096.     return ($wantarray ? ($flag ? %values : @values) : $counter) ;
  1097. }
  1099. sub db_cursor
  1100. {
  1101.     my $db = shift ;
  1102.     my ($addr) = $db->_db_cursor(@_) ;
  1103.     my $obj ;
  1104.     $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
  1105.     return $obj ;
  1106. }
  1108. sub db_join
  1109. {
  1110.     croak 'Usage: $db->BerkeleyDB::Common::db_join([cursors], flags=0)'
  1111. if @_ < 2 || @_ > 3 ;
  1112.     my $db = shift ;
  1113.     my ($addr) = $db->_db_join(@_) ;
  1114.     my $obj ;
  1115.     $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
  1116.     return $obj ;
  1117. }
  1119. package BerkeleyDB::Cursor ;
  1121. sub c_close
  1122. {
  1123.     my $cursor = shift ;
  1124.     $cursor->[1] = "" ;
  1125.     return $cursor->_c_close() ;
  1126. }
  1128. sub c_dup
  1129. {
  1130.     my $cursor = shift ;
  1131.     my ($addr) = $cursor->_c_dup(@_) ;
  1132.     my $obj ;
  1133.     $obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ;
  1134.     return $obj ;
  1135. }
  1137. sub DESTROY
  1138. {
  1139.     my $self = shift ;
  1140.     $self->_DESTROY() ;
  1141. }
  1143. package BerkeleyDB::TxnMgr ;
  1145. sub DESTROY
  1146. {
  1147.     my $self = shift ;
  1148.     $self->_DESTROY() ;
  1149. }
  1151. sub txn_begin
  1152. {
  1153.     my $txnmgr = shift ;
  1154.     my ($addr) = $txnmgr->_txn_begin(@_) ;
  1155.     my $obj ;
  1156.     $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ;
  1157.     return $obj ;
  1158. }
  1160. package BerkeleyDB::Txn ;
  1162. sub Txn
  1163. {
  1164.     my $self = shift ;
  1165.     my $db ;
  1166.     # keep a reference to each db in the txn object
  1167.     foreach $db (@_) {
  1168.         $db->_Txn($self) ;
  1169. push @{ $self}, $db ;
  1170.     }
  1171. }
  1173. sub txn_commit
  1174. {
  1175.     my $self = shift ;
  1176.     $self->disassociate() ;
  1177.     my $status = $self->_txn_commit() ;
  1178.     return $status ;
  1179. }
  1181. sub txn_abort
  1182. {
  1183.     my $self = shift ;
  1184.     $self->disassociate() ;
  1185.     my $status = $self->_txn_abort() ;
  1186.     return $status ;
  1187. }
  1189. sub disassociate
  1190. {
  1191.     my $self = shift ;
  1192.     my $db ;
  1193.     while ( @{ $self } > 2) {
  1194.         $db = pop @{ $self } ;
  1195.         $db->Txn() ;
  1196.     }
  1197.     #print "end disassociaten" ;
  1198. }
  1201. sub DESTROY
  1202. {
  1203.     my $self = shift ;
  1205.     $self->disassociate() ;
  1206.     # first close the close the transaction
  1207.     $self->_DESTROY() ;
  1208. }
  1210. package BerkeleyDB::Term ;
  1212. END
  1213. {
  1214.     close_everything() ;
  1215. }
  1218. package BerkeleyDB ;
  1222. # Autoload methods go after =cut, and are processed by the autosplit program.
  1224. 1;
  1225. __END__