diff options
author | 2013-03-25 20:40:40 +0000 | |
---|---|---|
committer | 2013-03-25 20:40:40 +0000 | |
commit | 48950c12d106c85f315112191a0228d7b83b9510 (patch) | |
tree | 54e43d54484c1bfe9bb06a10ede0ba3e2fa52c08 /gnu/usr.bin/perl/ext/SDBM_File | |
parent | avoid null dereference affecting mod_perl, Perl RT bug 116441 (diff) | |
download | wireguard-openbsd-48950c12d106c85f315112191a0228d7b83b9510.tar.xz wireguard-openbsd-48950c12d106c85f315112191a0228d7b83b9510.zip |
merge/resolve conflicts
(some more to do after this one)
Diffstat (limited to 'gnu/usr.bin/perl/ext/SDBM_File')
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm | 6 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms | 18 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c | 18 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h | 6 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/t/sdbm.t | 513 | ||||
-rw-r--r-- | gnu/usr.bin/perl/ext/SDBM_File/typemap | 8 |
8 files changed, 30 insertions, 543 deletions
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm index d1209e0158b..c989ceb6f4e 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm +++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm @@ -4,12 +4,12 @@ use strict; use warnings; require Tie::Hash; -use XSLoader (); +require XSLoader; our @ISA = qw(Tie::Hash); -our $VERSION = "1.06"; +our $VERSION = "1.09"; -XSLoader::load 'SDBM_File', $VERSION; +XSLoader::load(); 1; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c index 42b130db195..993a361186f 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c @@ -281,7 +281,7 @@ chkpage(char *pag) register int off; register short *ino = (short *) pag; - if ((n = ino[0]) < 0 || n > PBLKSIZ / sizeof(short)) + if ((n = ino[0]) < 0 || n > (int)(PBLKSIZ / sizeof(short))) return 0; if (n > 0) { diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms index 01ca17ccdfd..2965cde28da 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms @@ -70,7 +70,7 @@ The \fIsdbm\fP library is not derived from any licensed, proprietary or copyrighted software. .PP The \fIsdbm\fP implementation is based on a 1978 algorithm -[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''. +[Lar78] by P.-A. (Paul) Larson known as "Dynamic Hashing". In the course of searching for a substitute for \fIndbm\fP, I prototyped three different external-hashing algorithms [Lar78, Fag79, Lit80] and ultimately chose Larson's algorithm as a basis of the \fIsdbm\fP @@ -94,7 +94,7 @@ smaller. The \fIsdbm\fP implementation is also faster than \fIndbm\fP in database creation. Unlike the \fIndbm\fP, the \fIsdbm\fP .CW store -operation will not ``wander away'' trying to split its +operation will not "wander away" trying to split its data pages to insert a datum that \fIcannot\fP (due to elaborate worst-case situations) be inserted. (It will fail after a pre-defined number of attempts.) .SH @@ -323,31 +323,31 @@ References .LP .IP [Lar78] 4m P.-A. Larson, -``Dynamic Hashing'', \fIBIT\fP, vol. 18, pp. 184-201, 1978. +"Dynamic Hashing", \fIBIT\fP, vol. 18, pp. 184-201, 1978. .IP [Tho90] 4m Ken Thompson, \fIprivate communication\fP, Nov. 1990 .IP [Lit80] 4m W. Litwin, -`` Linear Hashing: A new tool for file and table addressing'', +"Linear Hashing: A new tool for file and table addressing", \fIProceedings of the 6th Conference on Very Large Dabatases (Montreal)\fP, pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980. .IP [Fag79] 4m R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong, -``Extendible Hashing - A Fast Access Method for Dynamic Files'', +"Extendible Hashing - A Fast Access Method for Dynamic Files", \fIACM Trans. Database Syst.\fP, vol. 4, no.3, pp. 315-344, Sept. 1979. .IP [Wal84] 4m Rich Wales, -``Discussion of "dbm" data base system'', \fIUSENET newsgroup unix.wizards\fP, +"Discussion of 'dbm' data base system", \fIUSENET newsgroup unix.wizards\fP, Jan. 1984. .IP [Tor87] 4m Chris Torek, -``Re: dbm.a and ndbm.a archives'', \fIUSENET newsgroup comp.unix\fP, +"Re: dbm.a and ndbm.a archives", \fIUSENET newsgroup comp.unix\fP, 1987. .IP [Mar79] 4m G. N. Martin, -``Spiral Storage: Incrementally Augmentable Hash Addressed Storage'', +"Spiral Storage: Incrementally Augmentable Hash Addressed Storage", \fITechnical Report #27\fP, University of Varwick, Coventry, U.K., 1979. .IP [Enb88] 4m R. J. Enbody and H. C. Du, -``Dynamic Hashing Schemes'',\fIACM Computing Surveys\fP, +"Dynamic Hashing Schemes",\fIACM Computing Surveys\fP, vol. 20, no. 2, pp. 85-113, June 1988. diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 index fe6fe76e255..25afcbe4fee 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 @@ -186,7 +186,7 @@ you notice clustering or other effects that may be due to the hashing algorithm used by this package, you can override it by supplying your own .BR sdbm_hash (\|) -routine. Doing so will make the database unintelligable to any other +routine. Doing so will make the database unintelligible to any other applications that do not use your specialized hash function. .sp .LP diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c index c5f7aa80599..46be83e560f 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c @@ -78,27 +78,27 @@ sdbm_open(register char *file, register int flags, register int mode) register char *dirname; register char *pagname; size_t filelen; - const size_t dirfext_len = sizeof(DIRFEXT ""); - const size_t pagfext_len = sizeof(PAGFEXT ""); + const size_t dirfext_size = sizeof(DIRFEXT ""); + const size_t pagfext_size = sizeof(PAGFEXT ""); if (file == NULL || !*file) return errno = EINVAL, (DBM *) NULL; /* - * need space for two seperate filenames + * need space for two separate filenames */ filelen = strlen(file); - if ((dirname = (char *) malloc(filelen + dirfext_len + 1 - + filelen + pagfext_len + 1)) == NULL) + if ((dirname = (char *) malloc(filelen + dirfext_size + + filelen + pagfext_size)) == NULL) return errno = ENOMEM, (DBM *) NULL; /* * build the file names */ memcpy(dirname, file, filelen); - memcpy(dirname + filelen, DIRFEXT, dirfext_len + 1); - pagname = dirname + filelen + dirfext_len + 1; + memcpy(dirname + filelen, DIRFEXT, dirfext_size); + pagname = dirname + filelen + dirfext_size; memcpy(pagname, file, filelen); - memcpy(pagname + filelen, PAGFEXT, pagfext_len + 1); + memcpy(pagname + filelen, PAGFEXT, pagfext_size); db = sdbm_prep(dirname, pagname, flags, mode); free((char *) dirname); @@ -306,7 +306,7 @@ makroom(register DBM *db, long int hash, int need) newp = (hash & db->hmask) | (db->hmask + 1); /* - * write delay, read avoidence/cache shuffle: + * write delay, read avoidance/cache shuffle: * select the page for incoming pair: if key is to go to the new page, * write out the previous one, and copy the new one over, thus making * it the current page. If not, simply write the new page, and we are diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h index 53fc3668010..2b8d0e9463f 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h @@ -250,11 +250,7 @@ Free_t Perl_mfree proto((Malloc_t where)); #else # ifndef memcmp /* maybe we should have included the full embedding header... */ -# ifdef NO_EMBED -# define memcmp my_memcmp -# else -# define memcmp Perl_my_memcmp -# endif +# define memcmp Perl_my_memcmp #ifndef __cplusplus extern int memcmp proto((char*, char*, int)); #endif diff --git a/gnu/usr.bin/perl/ext/SDBM_File/t/sdbm.t b/gnu/usr.bin/perl/ext/SDBM_File/t/sdbm.t index 60423d916c9..560d0bcee53 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/t/sdbm.t +++ b/gnu/usr.bin/perl/ext/SDBM_File/t/sdbm.t @@ -1,514 +1,5 @@ #!./perl -# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $ +our $DBM_Class = 'SDBM_File'; -BEGIN { - require Config; import Config; - if ($Config{'extensions'} !~ /\bSDBM_File\b/) { - print "1..0 # Skip: no SDBM_File\n"; - exit 0; - } -} - -use strict; -use warnings; - -sub ok -{ - my $no = shift ; - my $result = shift ; - - print "not " unless $result ; - print "ok $no\n" ; -} - -require SDBM_File; -#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT -use Fcntl; - -print "1..80\n"; - -unlink <Op_dbmx.*>; - -umask(0); -my %h ; -ok(1, tie %h,'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640); - -my $Dfile = "Op_dbmx.pag"; -if (! -e $Dfile) { - ($Dfile) = <Op_dbmx.*>; -} -if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' || $^O eq 'cygwin') { - print "ok 2 # Skipped: different file permission semantics\n"; -} -else { - my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); - print (($mode & 0777) == ($^O eq 'vos' ? 0750 : 0640) ? "ok 2\n" : "not ok 2\n"); -} -my $i = 0; -while (my ($key,$value) = each(%h)) { - $i++; -} -print (!$i ? "ok 3\n" : "not ok 3\n"); - -$h{'goner1'} = 'snork'; - -$h{'abc'} = 'ABC'; -$h{'def'} = 'DEF'; -$h{'jkl','mno'} = "JKL\034MNO"; -$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5); -$h{'a'} = 'A'; -$h{'b'} = 'B'; -$h{'c'} = 'C'; -$h{'d'} = 'D'; -$h{'e'} = 'E'; -$h{'f'} = 'F'; -$h{'g'} = 'G'; -$h{'h'} = 'H'; -$h{'i'} = 'I'; - -$h{'goner2'} = 'snork'; -delete $h{'goner2'}; - -untie(%h); -print (tie(%h,'SDBM_File','Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n"); - -$h{'j'} = 'J'; -$h{'k'} = 'K'; -$h{'l'} = 'L'; -$h{'m'} = 'M'; -$h{'n'} = 'N'; -$h{'o'} = 'O'; -$h{'p'} = 'P'; -$h{'q'} = 'Q'; -$h{'r'} = 'R'; -$h{'s'} = 'S'; -$h{'t'} = 'T'; -$h{'u'} = 'U'; -$h{'v'} = 'V'; -$h{'w'} = 'W'; -$h{'x'} = 'X'; -$h{'y'} = 'Y'; -$h{'z'} = 'Z'; - -$h{'goner3'} = 'snork'; - -delete $h{'goner1'}; -delete $h{'goner3'}; - -my @keys = keys(%h); -my @values = values(%h); - -if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} - -while (my ($key,$value) = each(%h)) { - if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; - } -} - -if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} - -$h{'foo'} = ''; -$h{''} = 'bar'; - -# check cache overflow and numeric keys and contents -my $ok = 1; -for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } -for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } -print ($ok ? "ok 8\n" : "not ok 8\n"); - -my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat($Dfile); -print ($size > 0 ? "ok 9\n" : "not ok 9\n"); - -@h{0..200} = 200..400; -my @foo = @h{0..200}; -print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; - -print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); -print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); - - -{ - # sub-class test - - package Another ; - - use strict ; - use warnings ; - - open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; - print FILE <<'EOM' ; - - package SubDB ; - - use strict ; - use warnings ; - use vars qw( @ISA @EXPORT) ; - - require Exporter ; - use SDBM_File; - @ISA=qw(SDBM_File); - @EXPORT = @SDBM_File::EXPORT if @SDBM_File::EXPORT ; - - sub STORE { - my $self = shift ; - my $key = shift ; - my $value = shift ; - $self->SUPER::STORE($key, $value * 2) ; - } - - sub FETCH { - my $self = shift ; - my $key = shift ; - $self->SUPER::FETCH($key) - 1 ; - } - - sub A_new_method - { - my $self = shift ; - my $key = shift ; - my $value = $self->FETCH($key) ; - return "[[$value]]" ; - } - - 1 ; -EOM - - close FILE or die "Could not close: $!"; - - BEGIN { push @INC, '.'; } - - eval 'use SubDB ; use Fcntl ;'; - main::ok(13, $@ eq "") ; - my %h ; - my $X ; - eval ' - $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 ); - ' ; - - main::ok(14, $@ eq "") ; - - my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ; - main::ok(15, $@ eq "") ; - main::ok(16, $ret == 5) ; - - $ret = eval '$X->A_new_method("fred") ' ; - main::ok(17, $@ eq "") ; - main::ok(18, $ret eq "[[5]]") ; - - undef $X; - untie(%h); - unlink "SubDB.pm", <dbhash_tmp.*> ; - -} - -ok(19, !exists $h{'goner1'}); -ok(20, exists $h{'foo'}); - -untie %h; -unlink <Op_dbmx*>, $Dfile; - -{ - # DBM Filter tests - use strict ; - use warnings ; - my (%h, $db) ; - my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - - sub checkOutput - { - my($fk, $sk, $fv, $sv) = @_ ; - return - $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; - } - - unlink <Op_dbmx*>; - ok(21, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_fetch_key (sub { $fetch_key = $_ }) ; - $db->filter_store_key (sub { $store_key = $_ }) ; - $db->filter_fetch_value (sub { $fetch_value = $_}) ; - $db->filter_store_value (sub { $store_value = $_ }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - # fk sk fv sv - ok(22, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(23, $h{"fred"} eq "joe"); - # fk sk fv sv - ok(24, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(25, $db->FIRSTKEY() eq "fred") ; - # fk sk fv sv - ok(26, checkOutput( "fred", "", "", "")) ; - - # replace the filters, but remember the previous set - my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; - my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; - my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; - my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"Fred"} = "Joe" ; - # fk sk fv sv - ok(27, checkOutput( "", "fred", "", "Jxe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(28, $h{"Fred"} eq "[Jxe]"); - # fk sk fv sv - ok(29, checkOutput( "", "fred", "[Jxe]", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(30, $db->FIRSTKEY() eq "FRED") ; - # fk sk fv sv - ok(31, checkOutput( "FRED", "", "", "")) ; - - # put the original filters back - $db->filter_fetch_key ($old_fk); - $db->filter_store_key ($old_sk); - $db->filter_fetch_value ($old_fv); - $db->filter_store_value ($old_sv); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(32, checkOutput( "", "fred", "", "joe")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(33, $h{"fred"} eq "joe"); - ok(34, checkOutput( "", "fred", "joe", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(35, $db->FIRSTKEY() eq "fred") ; - ok(36, checkOutput( "fred", "", "", "")) ; - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - $h{"fred"} = "joe" ; - ok(37, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(38, $h{"fred"} eq "joe"); - ok(39, checkOutput( "", "", "", "")) ; - - ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; - ok(40, $db->FIRSTKEY() eq "fred") ; - ok(41, checkOutput( "", "", "", "")) ; - - undef $db ; - untie %h; - unlink <Op_dbmx*>; -} - -{ - # DBM Filter with a closure - - use strict ; - use warnings ; - my (%h, $db) ; - - unlink <Op_dbmx*>; - ok(42, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - - my %result = () ; - - sub Closure - { - my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; - - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } - } - - $db->filter_store_key(Closure("store key")) ; - $db->filter_store_value(Closure("store value")) ; - $db->filter_fetch_key(Closure("fetch key")) ; - $db->filter_fetch_value(Closure("fetch value")) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(43, $result{"store key"} eq "store key - 1: [fred]"); - ok(44, $result{"store value"} eq "store value - 1: [joe]"); - ok(45, !defined $result{"fetch key"} ); - ok(46, !defined $result{"fetch value"} ); - ok(47, $_ eq "original") ; - - ok(48, $db->FIRSTKEY() eq "fred") ; - ok(49, $result{"store key"} eq "store key - 1: [fred]"); - ok(50, $result{"store value"} eq "store value - 1: [joe]"); - ok(51, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(52, ! defined $result{"fetch value"} ); - ok(53, $_ eq "original") ; - - $h{"jim"} = "john" ; - ok(54, $result{"store key"} eq "store key - 2: [fred jim]"); - ok(55, $result{"store value"} eq "store value - 2: [joe john]"); - ok(56, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(57, ! defined $result{"fetch value"} ); - ok(58, $_ eq "original") ; - - ok(59, $h{"fred"} eq "joe"); - ok(60, $result{"store key"} eq "store key - 3: [fred jim fred]"); - ok(61, $result{"store value"} eq "store value - 2: [joe john]"); - ok(62, $result{"fetch key"} eq "fetch key - 1: [fred]"); - ok(63, $result{"fetch value"} eq "fetch value - 1: [joe]"); - ok(64, $_ eq "original") ; - - undef $db ; - untie %h; - unlink <Op_dbmx*>; -} - -{ - # DBM Filter recursion detection - use strict ; - use warnings ; - my (%h, $db) ; - unlink <Op_dbmx*>; - - ok(65, $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_store_key (sub { $_ = $h{$_} }) ; - - eval '$h{1} = 1234' ; - ok(66, $@ =~ /^recursion detected in filter_store_key at/ ); - - undef $db ; - untie %h; - unlink <Op_dbmx*>; -} - -{ - # Bug ID 20001013.009 - # - # test that $hash{KEY} = undef doesn't produce the warning - # Use of uninitialized value in null operation - use warnings ; - use strict ; - use SDBM_File ; - - unlink <Op_dbmx*>; - my %h ; - my $a = ""; - local $SIG{__WARN__} = sub {$a = $_[0]} ; - - ok(67, tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - $h{ABC} = undef; - ok(68, $a eq "") ; - - untie %h; - unlink <Op_dbmx*>; -} - -{ - # When iterating over a tied hash using "each", the key passed to FETCH - # will be recycled and passed to NEXTKEY. If a Source Filter modifies the - # key in FETCH via a filter_fetch_key method we need to check that the - # modified key doesn't get passed to NEXTKEY. - # Also Test "keys" & "values" while we are at it. - - use warnings ; - use strict ; - use SDBM_File ; - - unlink <Op_dbmx*>; - my $bad_key = 0 ; - my %h = () ; - ok(69, my $db = tie(%h, 'SDBM_File','Op_dbmx', O_RDWR|O_CREAT, 0640)) ; - $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ; - $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ; - - $h{'Alpha_ABC'} = 2 ; - $h{'Alpha_DEF'} = 5 ; - - ok(70, $h{'Alpha_ABC'} == 2); - ok(71, $h{'Alpha_DEF'} == 5); - - my ($k, $v) = ("",""); - while (($k, $v) = each %h) {} - ok(72, $bad_key == 0); - - $bad_key = 0 ; - foreach $k (keys %h) {} - ok(73, $bad_key == 0); - - $bad_key = 0 ; - foreach $v (values %h) {} - ok(74, $bad_key == 0); - - undef $db ; - untie %h ; - unlink <Op_dbmx*>; -} - - -{ - # Check that DBM Filter can cope with read-only $_ - - use warnings ; - use strict ; - my %h ; - unlink <Op1_dbmx*>; - - ok(75, my $db = tie(%h, 'SDBM_File','Op1_dbmx', O_RDWR|O_CREAT, 0640)) ; - - $db->filter_fetch_key (sub { }) ; - $db->filter_store_key (sub { }) ; - $db->filter_fetch_value (sub { }) ; - $db->filter_store_value (sub { }) ; - - $_ = "original" ; - - $h{"fred"} = "joe" ; - ok(76, $h{"fred"} eq "joe"); - - eval { map { $h{$_} } (1, 2, 3) }; - ok (77, ! $@); - - - # delete the filters - $db->filter_fetch_key (undef); - $db->filter_store_key (undef); - $db->filter_fetch_value (undef); - $db->filter_store_value (undef); - - $h{"fred"} = "joe" ; - - ok(78, $h{"fred"} eq "joe"); - - ok(79, $db->FIRSTKEY() eq "fred") ; - - eval { map { $h{$_} } (1, 2, 3) }; - ok (80, ! $@); - - undef $db ; - untie %h; - unlink <Op1_dbmx*>; -} -exit ; +require '../../t/lib/dbmt_common.pl'; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/typemap b/gnu/usr.bin/perl/ext/SDBM_File/typemap index a06ce81aadf..d1fc497f452 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/SDBM_File/typemap @@ -17,12 +17,12 @@ INPUT T_DATUM_K { STRLEN len; - DBM_ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBM_ckFilter($arg, filter[store_key], \"filter_store_key\"); $var.dptr = SvPVbyte($arg, len); $var.dsize = (int)len; } T_DATUM_V - DBM_ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBM_ckFilter($arg, filter[store_value], \"filter_store_value\"); if (SvOK($arg)) { STRLEN len; $var.dptr = SvPVbyte($arg, len); @@ -37,10 +37,10 @@ T_GDATUM OUTPUT T_DATUM_K sv_setpvn($arg, $var.dptr, $var.dsize); - DBM_ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); + DBM_ckFilter($arg, filter[fetch_key],\"filter_fetch_key\"); T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); - DBM_ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); + DBM_ckFilter($arg, filter[fetch_value],\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ |