home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / odbm.t < prev    next >
Text File  |  1999-08-20  |  10KB  |  407 lines

  1. #!./perl
  2.  
  3. # $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
  4.  
  5. BEGIN {
  6.     chdir 't' if -d 't';
  7.     unshift @INC, '../lib';
  8.     require Config; import Config;
  9.     if ($Config{'extensions'} !~ /\bODBM_File\b/) {
  10.     print "1..0 # Skip: ODBM_File was not built\n";
  11.     exit 0;
  12.     }
  13. }
  14.  
  15. require ODBM_File;
  16. #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
  17. use Fcntl;
  18.  
  19. print "1..64\n";
  20.  
  21. unlink <Op.dbmx*>;
  22.  
  23. umask(0);
  24. print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n");
  25.  
  26. $Dfile = "Op.dbmx.pag";
  27. if (! -e $Dfile) {
  28.     ($Dfile) = <Op.dbmx*>;
  29. }
  30. if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
  31.     print "ok 2 # Skipped: different file permission semantics\n";
  32. }
  33. else {
  34.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  35.      $blksize,$blocks) = stat($Dfile);
  36.     print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
  37. }
  38. while (($key,$value) = each(%h)) {
  39.     $i++;
  40. }
  41. print (!$i ? "ok 3\n" : "not ok 3\n");
  42.  
  43. $h{'goner1'} = 'snork';
  44.  
  45. $h{'abc'} = 'ABC';
  46. $h{'def'} = 'DEF';
  47. $h{'jkl','mno'} = "JKL\034MNO";
  48. $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  49. $h{'a'} = 'A';
  50. $h{'b'} = 'B';
  51. $h{'c'} = 'C';
  52. $h{'d'} = 'D';
  53. $h{'e'} = 'E';
  54. $h{'f'} = 'F';
  55. $h{'g'} = 'G';
  56. $h{'h'} = 'H';
  57. $h{'i'} = 'I';
  58.  
  59. $h{'goner2'} = 'snork';
  60. delete $h{'goner2'};
  61.  
  62. untie(%h);
  63. print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
  64.  
  65. $h{'j'} = 'J';
  66. $h{'k'} = 'K';
  67. $h{'l'} = 'L';
  68. $h{'m'} = 'M';
  69. $h{'n'} = 'N';
  70. $h{'o'} = 'O';
  71. $h{'p'} = 'P';
  72. $h{'q'} = 'Q';
  73. $h{'r'} = 'R';
  74. $h{'s'} = 'S';
  75. $h{'t'} = 'T';
  76. $h{'u'} = 'U';
  77. $h{'v'} = 'V';
  78. $h{'w'} = 'W';
  79. $h{'x'} = 'X';
  80. $h{'y'} = 'Y';
  81. $h{'z'} = 'Z';
  82.  
  83. $h{'goner3'} = 'snork';
  84.  
  85. delete $h{'goner1'};
  86. delete $h{'goner3'};
  87.  
  88. @keys = keys(%h);
  89. @values = values(%h);
  90.  
  91. if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
  92.  
  93. while (($key,$value) = each(%h)) {
  94.     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
  95.     $key =~ y/a-z/A-Z/;
  96.     $i++ if $key eq $value;
  97.     }
  98. }
  99.  
  100. if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
  101.  
  102. @keys = ('blurfl', keys(%h), 'dyick');
  103. if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
  104.  
  105. $h{'foo'} = '';
  106. $h{''} = 'bar';
  107.  
  108. # check cache overflow and numeric keys and contents
  109. $ok = 1;
  110. for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
  111. for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
  112. print ($ok ? "ok 8\n" : "not ok 8\n");
  113.  
  114. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  115.    $blksize,$blocks) = stat($Dfile);
  116. print ($size > 0 ? "ok 9\n" : "not ok 9\n");
  117.  
  118. @h{0..200} = 200..400;
  119. @foo = @h{0..200};
  120. print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
  121.  
  122. print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
  123. print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
  124.  
  125. untie %h;
  126. unlink 'Op.dbmx.dir', $Dfile;
  127.  
  128. sub ok
  129. {
  130.     my $no = shift ;
  131.     my $result = shift ;
  132.  
  133.     print "not " unless $result ;
  134.     print "ok $no\n" ;
  135. }
  136.  
  137. {
  138.    # sub-class test
  139.  
  140.    package Another ;
  141.  
  142.    use strict ;
  143.  
  144.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
  145.    print FILE <<'EOM' ;
  146.  
  147.    package SubDB ;
  148.  
  149.    use strict ;
  150.    use vars qw(@ISA @EXPORT) ;
  151.  
  152.    require Exporter ;
  153.    use ODBM_File;
  154.    @ISA=qw(ODBM_File);
  155.    @EXPORT = @ODBM_File::EXPORT ;
  156.  
  157.    sub STORE { 
  158.     my $self = shift ;
  159.         my $key = shift ;
  160.         my $value = shift ;
  161.         $self->SUPER::STORE($key, $value * 2) ;
  162.    }
  163.  
  164.    sub FETCH { 
  165.     my $self = shift ;
  166.         my $key = shift ;
  167.         $self->SUPER::FETCH($key) - 1 ;
  168.    }
  169.  
  170.    sub A_new_method
  171.    {
  172.     my $self = shift ;
  173.         my $key = shift ;
  174.         my $value = $self->FETCH($key) ;
  175.     return "[[$value]]" ;
  176.    }
  177.  
  178.    1 ;
  179. EOM
  180.  
  181.     close FILE ;
  182.  
  183.     BEGIN { push @INC, '.'; }
  184.  
  185.     eval 'use SubDB ; use Fcntl ;';
  186.     main::ok(13, $@ eq "") ;
  187.     my %h ;
  188.     my $X ;
  189.     eval '
  190.     $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
  191.     ' ;
  192.  
  193.     main::ok(14, $@ eq "") ;
  194.  
  195.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  196.     main::ok(15, $@ eq "") ;
  197.     main::ok(16, $ret == 5) ;
  198.  
  199.     $ret = eval '$X->A_new_method("fred") ' ;
  200.     main::ok(17, $@ eq "") ;
  201.     main::ok(18, $ret eq "[[5]]") ;
  202.  
  203.     undef $X;
  204.     untie(%h);
  205.     unlink "SubDB.pm", <dbhash.tmp*> ;
  206.  
  207. }
  208.  
  209. {
  210.    # DBM Filter tests
  211.    use strict ;
  212.    my (%h, $db) ;
  213.    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  214.  
  215.    sub checkOutput
  216.    {
  217.        my($fk, $sk, $fv, $sv) = @_ ;
  218.        print "# ", join('|', $fetch_key, $fk, $store_key, $sk,
  219.             $fetch_value, $fv, $store_value, $sv, $_), "\n";
  220.        return
  221.            $fetch_key eq $fk && $store_key eq $sk && 
  222.        $fetch_value eq $fv && $store_value eq $sv &&
  223.        $_ eq 'original' ;
  224.    }
  225.    
  226.    unlink <Op.dbmx*>;
  227.    ok(19, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
  228.  
  229.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  230.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  231.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  232.    $db->filter_store_value (sub { $store_value = $_ }) ;
  233.  
  234.    $_ = "original" ;
  235.  
  236.    $h{"fred"} = "joe" ;
  237.    #                   fk   sk     fv   sv
  238.    ok(20, checkOutput( "", "fred", "", "joe")) ;
  239.  
  240.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  241.    ok(21, $h{"fred"} eq "joe");
  242.    #                   fk    sk     fv    sv
  243.    ok(22, checkOutput( "", "fred", "joe", "")) ;
  244.  
  245.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  246.    ok(23, $db->FIRSTKEY() eq "fred") ;
  247.    #                    fk     sk  fv  sv
  248.    ok(24, checkOutput( "fred", "", "", "")) ;
  249.  
  250.    # replace the filters, but remember the previous set
  251.    my ($old_fk) = $db->filter_fetch_key   
  252.                (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  253.    my ($old_sk) = $db->filter_store_key   
  254.                (sub { $_ = lc $_ ; $store_key = $_ }) ;
  255.    my ($old_fv) = $db->filter_fetch_value 
  256.                (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  257.    my ($old_sv) = $db->filter_store_value 
  258.                (sub { s/o/x/g; $store_value = $_ }) ;
  259.    
  260.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  261.    $h{"Fred"} = "Joe" ;
  262.    #                   fk   sk     fv    sv
  263.    ok(25, checkOutput( "", "fred", "", "Jxe")) ;
  264.  
  265.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  266.    ok(26, $h{"Fred"} eq "[Jxe]");
  267.    #                   fk   sk     fv    sv
  268.    ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
  269.  
  270.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  271.    ok(28, $db->FIRSTKEY() eq "FRED") ;
  272.    #                   fk   sk     fv    sv
  273.    ok(29, checkOutput( "FRED", "", "", "")) ;
  274.  
  275.    # put the original filters back
  276.    $db->filter_fetch_key   ($old_fk);
  277.    $db->filter_store_key   ($old_sk);
  278.    $db->filter_fetch_value ($old_fv);
  279.    $db->filter_store_value ($old_sv);
  280.  
  281.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  282.    $h{"fred"} = "joe" ;
  283.    ok(30, checkOutput( "", "fred", "", "joe")) ;
  284.  
  285.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  286.    ok(31, $h{"fred"} eq "joe");
  287.    ok(32, checkOutput( "", "fred", "joe", "")) ;
  288.  
  289.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  290.    ok(33, $db->FIRSTKEY() eq "fred") ;
  291.    ok(34, checkOutput( "fred", "", "", "")) ;
  292.  
  293.    # delete the filters
  294.    $db->filter_fetch_key   (undef);
  295.    $db->filter_store_key   (undef);
  296.    $db->filter_fetch_value (undef);
  297.    $db->filter_store_value (undef);
  298.  
  299.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  300.    $h{"fred"} = "joe" ;
  301.    ok(35, checkOutput( "", "", "", "")) ;
  302.  
  303.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  304.    ok(36, $h{"fred"} eq "joe");
  305.    ok(37, checkOutput( "", "", "", "")) ;
  306.  
  307.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  308.    ok(38, $db->FIRSTKEY() eq "fred") ;
  309.    ok(39, checkOutput( "", "", "", "")) ;
  310.  
  311.    undef $db ;
  312.    untie %h;
  313.    unlink <Op.dbmx*>;
  314. }
  315.  
  316. {    
  317.     # DBM Filter with a closure
  318.  
  319.     use strict ;
  320.     my (%h, $db) ;
  321.  
  322.     unlink <Op.dbmx*>;
  323.     ok(40, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
  324.  
  325.     my %result = () ;
  326.  
  327.     sub Closure
  328.     {
  329.         my ($name) = @_ ;
  330.     my $count = 0 ;
  331.     my @kept = () ;
  332.  
  333.     return sub { ++$count ; 
  334.              push @kept, $_ ; 
  335.              $result{$name} = "$name - $count: [@kept]" ;
  336.            }
  337.     }
  338.  
  339.     $db->filter_store_key(Closure("store key")) ;
  340.     $db->filter_store_value(Closure("store value")) ;
  341.     $db->filter_fetch_key(Closure("fetch key")) ;
  342.     $db->filter_fetch_value(Closure("fetch value")) ;
  343.  
  344.     $_ = "original" ;
  345.  
  346.     $h{"fred"} = "joe" ;
  347.     ok(41, $result{"store key"} eq "store key - 1: [fred]");
  348.     ok(42, $result{"store value"} eq "store value - 1: [joe]");
  349.     ok(43, !defined $result{"fetch key"} );
  350.     ok(44, !defined $result{"fetch value"} );
  351.     ok(45, $_ eq "original") ;
  352.  
  353.     ok(46, $db->FIRSTKEY() eq "fred") ;
  354.     ok(47, $result{"store key"} eq "store key - 1: [fred]");
  355.     ok(48, $result{"store value"} eq "store value - 1: [joe]");
  356.     ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
  357.     ok(50, ! defined $result{"fetch value"} );
  358.     ok(51, $_ eq "original") ;
  359.  
  360.     $h{"jim"}  = "john" ;
  361.     ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
  362.     ok(53, $result{"store value"} eq "store value - 2: [joe john]");
  363.     ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
  364.     ok(55, $result{"fetch value"} eq "");
  365.     ok(56, $_ eq "original") ;
  366.  
  367.     ok(57, $h{"fred"} eq "joe");
  368.     ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
  369.     ok(59, $result{"store value"} eq "store value - 2: [joe john]");
  370.     ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
  371.     ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
  372.     ok(62, $_ eq "original") ;
  373.  
  374.     undef $db ;
  375.     untie %h;
  376.     unlink <Op.dbmx*>;
  377. }        
  378.  
  379. {
  380.    # DBM Filter recursion detection
  381.    use strict ;
  382.    my (%h, $db) ;
  383.    unlink <Op.dbmx*>;
  384.  
  385.    ok(63, $db = tie(%h, 'ODBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
  386.  
  387.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  388.  
  389.    eval '$h{1} = 1234' ;
  390.    ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
  391.    
  392.    undef $db ;
  393.    untie %h;
  394.    unlink <Op.dbmx*>;
  395. }
  396.  
  397. if ($^O eq 'hpux') {
  398.     print <<EOM;
  399. #
  400. # If you experience failures with the odbm test in HP-UX,
  401. # this is a well-known bug that's unfortunately very hard to fix.
  402. # The suggested course of action is to avoid using the ODBM_File,
  403. # but to use instead the NDBM_File extension.
  404. #
  405. EOM
  406. }
  407.