home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / sdbm.t < prev    next >
Text File  |  1999-07-20  |  10KB  |  399 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'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
  10.     print "1..0\n";
  11.     exit 0;
  12.     }
  13. }
  14. require SDBM_File;
  15. #If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
  16. use Fcntl;
  17.  
  18. print "1..66\n";
  19.  
  20. unlink <Op_dbmx.*>;
  21.  
  22. umask(0);
  23. print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
  24.        ? "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' || $^O eq 'dos') {
  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,SDBM_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.  
  126. sub ok
  127. {
  128.     my $no = shift ;
  129.     my $result = shift ;
  130.  
  131.     print "not " unless $result ;
  132.     print "ok $no\n" ;
  133. }
  134.  
  135. {
  136.    # sub-class test
  137.  
  138.    package Another ;
  139.  
  140.    use strict ;
  141.  
  142.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
  143.    print FILE <<'EOM' ;
  144.  
  145.    package SubDB ;
  146.  
  147.    use strict ;
  148.    use vars qw( @ISA @EXPORT) ;
  149.  
  150.    require Exporter ;
  151.    use SDBM_File;
  152.    @ISA=qw(SDBM_File);
  153.    @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ;
  154.  
  155.    sub STORE { 
  156.     my $self = shift ;
  157.         my $key = shift ;
  158.         my $value = shift ;
  159.         $self->SUPER::STORE($key, $value * 2) ;
  160.    }
  161.  
  162.    sub FETCH { 
  163.     my $self = shift ;
  164.         my $key = shift ;
  165.         $self->SUPER::FETCH($key) - 1 ;
  166.    }
  167.  
  168.    sub A_new_method
  169.    {
  170.     my $self = shift ;
  171.         my $key = shift ;
  172.         my $value = $self->FETCH($key) ;
  173.     return "[[$value]]" ;
  174.    }
  175.  
  176.    1 ;
  177. EOM
  178.  
  179.     close FILE ;
  180.  
  181.     BEGIN { push @INC, '.'; }
  182.  
  183.     eval 'use SubDB ; use Fcntl ;';
  184.     main::ok(13, $@ eq "") ;
  185.     my %h ;
  186.     my $X ;
  187.     eval '
  188.     $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
  189.     ' ;
  190.  
  191.     main::ok(14, $@ eq "") ;
  192.  
  193.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  194.     main::ok(15, $@ eq "") ;
  195.     main::ok(16, $ret == 5) ;
  196.  
  197.     $ret = eval '$X->A_new_method("fred") ' ;
  198.     main::ok(17, $@ eq "") ;
  199.     main::ok(18, $ret eq "[[5]]") ;
  200.  
  201.     undef $X;
  202.     untie(%h);
  203.     unlink "SubDB.pm", <dbhash_tmp.*> ;
  204.  
  205. }
  206.  
  207. ok(19, !exists $h{'goner1'});
  208. ok(20, exists $h{'foo'});
  209.  
  210. untie %h;
  211. unlink <Op_dbmx*>, $Dfile;
  212.  
  213. {
  214.    # DBM Filter tests
  215.    use strict ;
  216.    my (%h, $db) ;
  217.    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  218.  
  219.    sub checkOutput
  220.    {
  221.        my($fk, $sk, $fv, $sv) = @_ ;
  222.        return
  223.            $fetch_key eq $fk && $store_key eq $sk && 
  224.        $fetch_value eq $fv && $store_value eq $sv &&
  225.        $_ eq 'original' ;
  226.    }
  227.    
  228.    unlink <Op_dbmx*>;
  229.    ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
  230.  
  231.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  232.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  233.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  234.    $db->filter_store_value (sub { $store_value = $_ }) ;
  235.  
  236.    $_ = "original" ;
  237.  
  238.    $h{"fred"} = "joe" ;
  239.    #                   fk   sk     fv   sv
  240.    ok(22, checkOutput( "", "fred", "", "joe")) ;
  241.  
  242.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  243.    ok(23, $h{"fred"} eq "joe");
  244.    #                   fk    sk     fv    sv
  245.    ok(24, checkOutput( "", "fred", "joe", "")) ;
  246.  
  247.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  248.    ok(25, $db->FIRSTKEY() eq "fred") ;
  249.    #                    fk     sk  fv  sv
  250.    ok(26, checkOutput( "fred", "", "", "")) ;
  251.  
  252.    # replace the filters, but remember the previous set
  253.    my ($old_fk) = $db->filter_fetch_key   
  254.                (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  255.    my ($old_sk) = $db->filter_store_key   
  256.                (sub { $_ = lc $_ ; $store_key = $_ }) ;
  257.    my ($old_fv) = $db->filter_fetch_value 
  258.                (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  259.    my ($old_sv) = $db->filter_store_value 
  260.                (sub { s/o/x/g; $store_value = $_ }) ;
  261.    
  262.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  263.    $h{"Fred"} = "Joe" ;
  264.    #                   fk   sk     fv    sv
  265.    ok(27, checkOutput( "", "fred", "", "Jxe")) ;
  266.  
  267.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  268.    ok(28, $h{"Fred"} eq "[Jxe]");
  269.    #                   fk   sk     fv    sv
  270.    ok(29, checkOutput( "", "fred", "[Jxe]", "")) ;
  271.  
  272.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  273.    ok(30, $db->FIRSTKEY() eq "FRED") ;
  274.    #                   fk   sk     fv    sv
  275.    ok(31, checkOutput( "FRED", "", "", "")) ;
  276.  
  277.    # put the original filters back
  278.    $db->filter_fetch_key   ($old_fk);
  279.    $db->filter_store_key   ($old_sk);
  280.    $db->filter_fetch_value ($old_fv);
  281.    $db->filter_store_value ($old_sv);
  282.  
  283.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  284.    $h{"fred"} = "joe" ;
  285.    ok(32, checkOutput( "", "fred", "", "joe")) ;
  286.  
  287.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  288.    ok(33, $h{"fred"} eq "joe");
  289.    ok(34, checkOutput( "", "fred", "joe", "")) ;
  290.  
  291.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  292.    ok(35, $db->FIRSTKEY() eq "fred") ;
  293.    ok(36, checkOutput( "fred", "", "", "")) ;
  294.  
  295.    # delete the filters
  296.    $db->filter_fetch_key   (undef);
  297.    $db->filter_store_key   (undef);
  298.    $db->filter_fetch_value (undef);
  299.    $db->filter_store_value (undef);
  300.  
  301.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  302.    $h{"fred"} = "joe" ;
  303.    ok(37, checkOutput( "", "", "", "")) ;
  304.  
  305.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  306.    ok(38, $h{"fred"} eq "joe");
  307.    ok(39, checkOutput( "", "", "", "")) ;
  308.  
  309.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  310.    ok(40, $db->FIRSTKEY() eq "fred") ;
  311.    ok(41, checkOutput( "", "", "", "")) ;
  312.  
  313.    undef $db ;
  314.    untie %h;
  315.    unlink <Op_dbmx*>;
  316. }
  317.  
  318. {    
  319.     # DBM Filter with a closure
  320.  
  321.     use strict ;
  322.     my (%h, $db) ;
  323.  
  324.     unlink <Op_dbmx*>;
  325.     ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
  326.  
  327.     my %result = () ;
  328.  
  329.     sub Closure
  330.     {
  331.         my ($name) = @_ ;
  332.     my $count = 0 ;
  333.     my @kept = () ;
  334.  
  335.     return sub { ++$count ; 
  336.              push @kept, $_ ; 
  337.              $result{$name} = "$name - $count: [@kept]" ;
  338.            }
  339.     }
  340.  
  341.     $db->filter_store_key(Closure("store key")) ;
  342.     $db->filter_store_value(Closure("store value")) ;
  343.     $db->filter_fetch_key(Closure("fetch key")) ;
  344.     $db->filter_fetch_value(Closure("fetch value")) ;
  345.  
  346.     $_ = "original" ;
  347.  
  348.     $h{"fred"} = "joe" ;
  349.     ok(43, $result{"store key"} eq "store key - 1: [fred]");
  350.     ok(44, $result{"store value"} eq "store value - 1: [joe]");
  351.     ok(45, !defined $result{"fetch key"} );
  352.     ok(46, !defined $result{"fetch value"} );
  353.     ok(47, $_ eq "original") ;
  354.  
  355.     ok(48, $db->FIRSTKEY() eq "fred") ;
  356.     ok(49, $result{"store key"} eq "store key - 1: [fred]");
  357.     ok(50, $result{"store value"} eq "store value - 1: [joe]");
  358.     ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]");
  359.     ok(52, ! defined $result{"fetch value"} );
  360.     ok(53, $_ eq "original") ;
  361.  
  362.     $h{"jim"}  = "john" ;
  363.     ok(54, $result{"store key"} eq "store key - 2: [fred jim]");
  364.     ok(55, $result{"store value"} eq "store value - 2: [joe john]");
  365.     ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]");
  366.     ok(57, $result{"fetch value"} eq "");
  367.     ok(58, $_ eq "original") ;
  368.  
  369.     ok(59, $h{"fred"} eq "joe");
  370.     ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]");
  371.     ok(61, $result{"store value"} eq "store value - 2: [joe john]");
  372.     ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]");
  373.     ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]");
  374.     ok(64, $_ eq "original") ;
  375.  
  376.     undef $db ;
  377.     untie %h;
  378.     unlink <Op_dbmx*>;
  379. }        
  380.  
  381. {
  382.    # DBM Filter recursion detection
  383.    use strict ;
  384.    my (%h, $db) ;
  385.    unlink <Op_dbmx*>;
  386.  
  387.    ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ;
  388.  
  389.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  390.  
  391.    eval '$h{1} = 1234' ;
  392.    ok(66, $@ =~ /^recursion detected in filter_store_key at/ );
  393.    
  394.    undef $db ;
  395.    untie %h;
  396.    unlink <Op_dbmx*>;
  397. }
  398.  
  399.