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