home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / ndbm.t < prev    next >
Text File  |  1999-07-20  |  10KB  |  394 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'} !~ /\bNDBM_File\b/) {
  10.     print "1..0 # Skip: NDBM_File was not built\n";
  11.     exit 0;
  12.     }
  13. }
  14.  
  15. require NDBM_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,NDBM_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,NDBM_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 NDBM_File;
  154.    @ISA=qw(NDBM_File);
  155.    @EXPORT = @NDBM_File::EXPORT if defined @NDBM_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.        return
  219.            $fetch_key eq $fk && $store_key eq $sk && 
  220.        $fetch_value eq $fv && $store_value eq $sv &&
  221.        $_ eq 'original' ;
  222.    }
  223.    
  224.    unlink <Op.dbmx*>;
  225.    ok(19, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
  226.  
  227.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  228.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  229.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  230.    $db->filter_store_value (sub { $store_value = $_ }) ;
  231.  
  232.    $_ = "original" ;
  233.  
  234.    $h{"fred"} = "joe" ;
  235.    #                   fk   sk     fv   sv
  236.    ok(20, checkOutput( "", "fred", "", "joe")) ;
  237.  
  238.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  239.    ok(21, $h{"fred"} eq "joe");
  240.    #                   fk    sk     fv    sv
  241.    ok(22, checkOutput( "", "fred", "joe", "")) ;
  242.  
  243.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  244.    ok(23, $db->FIRSTKEY() eq "fred") ;
  245.    #                    fk     sk  fv  sv
  246.    ok(24, checkOutput( "fred", "", "", "")) ;
  247.  
  248.    # replace the filters, but remember the previous set
  249.    my ($old_fk) = $db->filter_fetch_key   
  250.                (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  251.    my ($old_sk) = $db->filter_store_key   
  252.                (sub { $_ = lc $_ ; $store_key = $_ }) ;
  253.    my ($old_fv) = $db->filter_fetch_value 
  254.                (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  255.    my ($old_sv) = $db->filter_store_value 
  256.                (sub { s/o/x/g; $store_value = $_ }) ;
  257.    
  258.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  259.    $h{"Fred"} = "Joe" ;
  260.    #                   fk   sk     fv    sv
  261.    ok(25, checkOutput( "", "fred", "", "Jxe")) ;
  262.  
  263.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  264.    ok(26, $h{"Fred"} eq "[Jxe]");
  265.    #                   fk   sk     fv    sv
  266.    ok(27, checkOutput( "", "fred", "[Jxe]", "")) ;
  267.  
  268.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  269.    ok(28, $db->FIRSTKEY() eq "FRED") ;
  270.    #                   fk   sk     fv    sv
  271.    ok(29, checkOutput( "FRED", "", "", "")) ;
  272.  
  273.    # put the original filters back
  274.    $db->filter_fetch_key   ($old_fk);
  275.    $db->filter_store_key   ($old_sk);
  276.    $db->filter_fetch_value ($old_fv);
  277.    $db->filter_store_value ($old_sv);
  278.  
  279.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  280.    $h{"fred"} = "joe" ;
  281.    ok(30, checkOutput( "", "fred", "", "joe")) ;
  282.  
  283.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  284.    ok(31, $h{"fred"} eq "joe");
  285.    ok(32, checkOutput( "", "fred", "joe", "")) ;
  286.  
  287.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  288.    ok(33, $db->FIRSTKEY() eq "fred") ;
  289.    ok(34, checkOutput( "fred", "", "", "")) ;
  290.  
  291.    # delete the filters
  292.    $db->filter_fetch_key   (undef);
  293.    $db->filter_store_key   (undef);
  294.    $db->filter_fetch_value (undef);
  295.    $db->filter_store_value (undef);
  296.  
  297.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  298.    $h{"fred"} = "joe" ;
  299.    ok(35, checkOutput( "", "", "", "")) ;
  300.  
  301.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  302.    ok(36, $h{"fred"} eq "joe");
  303.    ok(37, checkOutput( "", "", "", "")) ;
  304.  
  305.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  306.    ok(38, $db->FIRSTKEY() eq "fred") ;
  307.    ok(39, checkOutput( "", "", "", "")) ;
  308.  
  309.    undef $db ;
  310.    untie %h;
  311.    unlink <Op.dbmx*>;
  312. }
  313.  
  314. {    
  315.     # DBM Filter with a closure
  316.  
  317.     use strict ;
  318.     my (%h, $db) ;
  319.  
  320.     unlink <Op.dbmx*>;
  321.     ok(40, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
  322.  
  323.     my %result = () ;
  324.  
  325.     sub Closure
  326.     {
  327.         my ($name) = @_ ;
  328.     my $count = 0 ;
  329.     my @kept = () ;
  330.  
  331.     return sub { ++$count ; 
  332.              push @kept, $_ ; 
  333.              $result{$name} = "$name - $count: [@kept]" ;
  334.            }
  335.     }
  336.  
  337.     $db->filter_store_key(Closure("store key")) ;
  338.     $db->filter_store_value(Closure("store value")) ;
  339.     $db->filter_fetch_key(Closure("fetch key")) ;
  340.     $db->filter_fetch_value(Closure("fetch value")) ;
  341.  
  342.     $_ = "original" ;
  343.  
  344.     $h{"fred"} = "joe" ;
  345.     ok(41, $result{"store key"} eq "store key - 1: [fred]");
  346.     ok(42, $result{"store value"} eq "store value - 1: [joe]");
  347.     ok(43, !defined $result{"fetch key"} );
  348.     ok(44, !defined $result{"fetch value"} );
  349.     ok(45, $_ eq "original") ;
  350.  
  351.     ok(46, $db->FIRSTKEY() eq "fred") ;
  352.     ok(47, $result{"store key"} eq "store key - 1: [fred]");
  353.     ok(48, $result{"store value"} eq "store value - 1: [joe]");
  354.     ok(49, $result{"fetch key"} eq "fetch key - 1: [fred]");
  355.     ok(50, ! defined $result{"fetch value"} );
  356.     ok(51, $_ eq "original") ;
  357.  
  358.     $h{"jim"}  = "john" ;
  359.     ok(52, $result{"store key"} eq "store key - 2: [fred jim]");
  360.     ok(53, $result{"store value"} eq "store value - 2: [joe john]");
  361.     ok(54, $result{"fetch key"} eq "fetch key - 1: [fred]");
  362.     ok(55, $result{"fetch value"} eq "");
  363.     ok(56, $_ eq "original") ;
  364.  
  365.     ok(57, $h{"fred"} eq "joe");
  366.     ok(58, $result{"store key"} eq "store key - 3: [fred jim fred]");
  367.     ok(59, $result{"store value"} eq "store value - 2: [joe john]");
  368.     ok(60, $result{"fetch key"} eq "fetch key - 1: [fred]");
  369.     ok(61, $result{"fetch value"} eq "fetch value - 1: [joe]");
  370.     ok(62, $_ eq "original") ;
  371.  
  372.     undef $db ;
  373.     untie %h;
  374.     unlink <Op.dbmx*>;
  375. }        
  376.  
  377. {
  378.    # DBM Filter recursion detection
  379.    use strict ;
  380.    my (%h, $db) ;
  381.    unlink <Op.dbmx*>;
  382.  
  383.    ok(63, $db = tie(%h, 'NDBM_File','Op.dbmx', O_RDWR|O_CREAT, 0640)) ;
  384.  
  385.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  386.  
  387.    eval '$h{1} = 1234' ;
  388.    ok(64, $@ =~ /^recursion detected in filter_store_key at/ );
  389.    
  390.    undef $db ;
  391.    untie %h;
  392.    unlink <Op.dbmx*>;
  393. }
  394.