develooper Front page | perl.perl5.porters | Postings from April 2006

[perl #39026] Tie::Memoize::EXISTS not caching the value

From:
Len Weisberg
Date:
April 29, 2006 03:07
Subject:
[perl #39026] Tie::Memoize::EXISTS not caching the value
Message ID:
rt-3.0.11-39026-132847.17.5801704932685@perl.org
# New Ticket Created by  Len Weisberg 
# Please include the string:  [perl #39026]
# in the subject line of all future correspondence about this issue. 
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=39026 >


To: perlbug@perl.org
Subject: Tie::Memoize::EXISTS not caching the value
Reply-To: Len@Weisberg.com
Message-Id: <5.8.3_2316_1146269610@INDIGO>

This is a bug report for perl from Len@Weisberg.com,
generated with the help of perlbug 1.34 running under perl v5.8.3.

-------------------------------------------------

The Tie::Memoize::EXISTS routine is not caching the value when it should.
The exists operation gives the right answers, but if the EXISTS callback
is expensive or has side-effects, this could be a (medium) serious problem.

Take a look at the code for ./lib/Tie::Memoize.pl, v1.0,
    http://search.cpan.org/src/NWCLARK/perl-5.8.8/lib/Tie/Memoize.pm

The logic is different depending on whether
the FETCH and EXISTS callbacks are the same or different.
In the "same" case, the results of "yes it exists" is supposed to be
cached in the value-cache, since it knows the actual value.
In the "different" case, the EXISTS results should always be cached in
the exists-cache, since the EXISTS routine doesn't know what the value is.

For the old code, the EXISTS routine never successfully caches anything.

The FETCH and EXISTS code each handle the args differently.
It looks like someone didn't quite finish converting EXISTS to
using shift instead of directly accessing $_[0] .
The last three occurrences of $_[0] in FETCH don't do anything.

I was going to quote Emerson's line about hobgoblins, but this one is
more appropriate:
>    Consistency is the last refuge of the unimaginative.
>        Oscar Wilde (1854 - 1900)

That notwithstanding, consistency would have prevented this problem.
I have made a minimal change, and it's still not consistent, but
I think it works.

--------------------------------------------------

Here's a patch:

*** Memoize.pm-r1.0-orig	Tue Feb  3 00:24:28 2004
--- Memoize2.pm	Fri Apr 28 17:23:16 2006
***************
*** 30,40 ****
    my $cache = $a->[1]{$key};
    return $cache if defined $cache; # Existence cache
    my @res = $a->[3]($key,$a->[4]);
!   $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
    # Now we know it exists
!   return ($_[0][1]{$key} = 1) if $a->[5]; # Only existence reported
    # Now know the value
!   $_[0][0]{$key} = $res[0];	# Store data
    return 1
  }

--- 30,40 ----
    my $cache = $a->[1]{$key};
    return $cache if defined $cache; # Existence cache
    my @res = $a->[3]($key,$a->[4]);
!   $a->[1]{$key} = 0, return unless @res; # Cache non-existence
    # Now we know it exists
!   return ($a->[1]{$key} = 1) if $a->[5]; # Only existence reported
    # Now know the value
!   $a->[0]{$key} = $res[0];	# Store data
    return 1
  }


--------------------------------------------------

And here's a demo program.
It doesn't test everything for the new version, but it does
demonstrate the bug, for both the "same" and "different" cases.
It could be the basis for an addition to the test suite.


#! /bin/perl    -w
use Tie::Memoize ;    ## Version 1.0
use Tie::Memoize2 ;   ## The patched version, installed as a different package

my $obj = tie %hash, 'Tie::Memoize', \&callback ;
tryit('using (standard) Tie::Memoize, r1.0; both callbacks same',
      22,33) ;

$obj = tie %hash, 'Tie::Memoize', \&fetch_cb, 0, \&exists_cb ;
tryit('using (standard) Tie::Memoize, r1.0; different callbacks',
      44,55) ;

$obj = tie %hash, 'Tie::Memoize2', \&callback ;
tryit('using modified Tie::Memoize  (as Tie::Memoize2); both callbacks same',
      66,77) ;

$obj = tie %hash, 'Tie::Memoize2', \&fetch_cb, 0, \&exists_cb ;
tryit('using modified Tie::Memoize  (as Tie::Memoize2); different callbacks',
      88,55) ;


## All callbacks announce that they are running.
##   They all do the same thing, except for their message:
##     for even keys, the value is  "key=$key";  for odd keys, it is false
## Note that EXISTS is supposed to cached the value only if its
##     call back is the same as for FETCH.

sub callback {
   print "in common callback for key  $_[0]:   ";
   $_[0] % 2 ? () : "key=$_[0]"
}

sub fetch_cb {
   print "in FETCH  callback for key  $_[0]:   ";
   $_[0] % 2 ? () : "key=$_[0]"
}

sub exists_cb {
   print "in EXISTS callback for key  $_[0]:   ";
   $_[0] % 2 ? () : "key=$_[0]"
}

sub tryit {
   my $msg = shift ;
   print "\n$msg\n\n" ;
   foreach my $x (@_) {
      print "doing exists \$hash{$x}:  " ;
	printf "%s\n",  exists $hash{$x}||'no' ;

      print "doing exists \$hash{$x}:  " ;
	printf "%s\n",  exists $hash{$x}||'no' ;

      print "value of \$hash{$x}:      " ;
	printf "%s\n",   $hash{$x}||'false' ;

      print "doing exists \$hash{$x}:  " ;
	printf "%s\n",  exists $hash{$x}||'no' ;
      print "-------------\n" ;
   }
}

--------------------------------------------------

The output is:


using (standard) Tie::Memoize, r1.0; both callbacks same

doing exists $hash{22}:  in common callback for key  22:   1
doing exists $hash{22}:  in common callback for key  22:   1
value of $hash{22}:      in common callback for key  22:   key=22
doing exists $hash{22}:  1
-------------
doing exists $hash{33}:  in common callback for key  33:   no
doing exists $hash{33}:  in common callback for key  33:   no
value of $hash{33}:      in common callback for key  33:   false
doing exists $hash{33}:  no
-------------

using (standard) Tie::Memoize, r1.0; different callbacks

doing exists $hash{44}:  in EXISTS callback for key  44:   1
doing exists $hash{44}:  in EXISTS callback for key  44:   1
value of $hash{44}:      in FETCH  callback for key  44:   key=44
doing exists $hash{44}:  1
-------------
doing exists $hash{55}:  in EXISTS callback for key  55:   no
doing exists $hash{55}:  in EXISTS callback for key  55:   no
value of $hash{55}:      in FETCH  callback for key  55:   false
doing exists $hash{55}:  no
-------------

using modified Tie::Memoize  (as Tie::Memoize2); both callbacks same

doing exists $hash{66}:  in common callback for key  66:   1
doing exists $hash{66}:  1
value of $hash{66}:      key=66
doing exists $hash{66}:  1
-------------
doing exists $hash{77}:  in common callback for key  77:   no
doing exists $hash{77}:  no
value of $hash{77}:      false
doing exists $hash{77}:  no
-------------

using modified Tie::Memoize  (as Tie::Memoize2); different callbacks

doing exists $hash{88}:  in EXISTS callback for key  88:   1
doing exists $hash{88}:  1
value of $hash{88}:      in FETCH  callback for key  88:   key=88
doing exists $hash{88}:  1
-------------
doing exists $hash{55}:  in EXISTS callback for key  55:   no
doing exists $hash{55}:  no
value of $hash{55}:      false
doing exists $hash{55}:  no
-------------


It's amazing to me that such a small module in the Standard Distribution
could have such a bug, even though it does not cause incorrect output,
in the usual case.  Mmaybe testing exists on a tied hash isn't done
very often.

I must admit that I don't understand why '-w' doesn't catch the problem.
Maybe that's another bug.

Thanks for a very easy bug reporting system.

Cheers,

-Len
Len@Weisberg.com


---
Flags:
    category=library
    severity=medium
---
Site configuration information for perl v5.8.3:

Configured by ActiveState at Tue Feb  3 00:28:38 2004.

Summary of my perl5 (revision 5 version 8 subversion 3) configuration:
  Platform:
    osname=MSWin32, osvers=4.0, archname=MSWin32-x86-multi-thread
    uname=''
    config_args='undef'
    hint=recommended, useposix=true, d_sigaction=undef
    usethreads=undef use5005threads=undef useithreads=define usemultiplicity=define
    useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cl', ccflags ='-nologo -Gf -W3 -MD -Zi -DNDEBUG -O1 -DWIN32 -D_CONSOLE
-DNO_STRICT -DHAVE_DES_FCRYPT  -DNO_HASH_SEED -DPERL_IMPLICIT_CONTEXT
-DPERL_IMPLICIT_SYS -DUSE_PERLIO -DPERL_MSVCRT_READFIX',
    optimize='-MD -Zi -DNDEBUG -O1',
    cppflags='-DWIN32'
    ccversion='', gccversion='', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=10
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='__int64',
lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='link', ldflags ='-nologo -nodefaultlib -debug -opt:ref,icf
-libpath:"g:\sw\perl-583\lib\CORE"  -machine:x86'
    libpth=C:\PROGRA~1\MICROS~3\VC98\lib
    libs=  oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib
comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib  netapi32.lib
uuid.lib wsock32.lib mpr.lib winmm.lib  version.lib odbc32.lib odbccp32.lib
msvcrt.lib
    perllibs=  oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib
comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib  netapi32.lib
uuid.lib wsock32.lib mpr.lib winmm.lib  version.lib odbc32.lib odbccp32.lib
msvcrt.lib
    libc=msvcrt.lib, so=dll, useshrplib=yes, libperl=perl58.lib
    gnulibc_version='undef'
  Dynamic Linking:
    dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
    cccdlflags=' ', lddlflags='-dll -nologo -nodefaultlib -debug -opt:ref,icf
-libpath:"g:\sw\perl-583\lib\CORE"  -machine:x86'

Locally applied patches:
    ACTIVEPERL_LOCAL_PATCHES_ENTRY
    22218 Remove the caveat about detached threads crashing on Windows
    22201 Avoid threads+win32 crash by freeing Perl interpreter slightly later
    22169 Display 'out of memeory' errors using low-level I/O
    22159 Upgrade to Time::Hires 1.55
    22120 Make 'Configure -Dcf_by=...' work
    22051 Upgrade to Time::HiRes 1.54
    21540 Fix backward-compatibility issues in if.pm

---
@INC for perl v5.8.3:
    g:/sw/perl-583/lib
    g:/sw/perl-583/site/lib
    .

---
Environment for perl v5.8.3:
    HOME=f:/len/home
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH=g:/sw/djgpp-204b/lib;g:/sw/djgpp-204b/bin
    LOGDIR (unset)

PATH=g:/sw/perl-583/bin/;f:/home/bat;f:/home/bin;g:/sw/perl/bin;g:/sw/emacs-21.3/bin;g:/sw/djgpp-~2/bin;g:/sw/djgpp-~1/bin;g:/sw/gnu/bin;d:/winnt/system32;d:/winnt;d:/winnt/system32/wbem;g:/sw/gtk_02~1/2.0/bin;g:/sw/gtk_02~3/2.0/bin;d:/progra~1/atitec~1/ati.ace/;g:/sw/gtk+0269/bin;g:/sw/gtk_02~4/2.0/bin;g:/sw/quickt~1/qtsystem/;f:/home/bat;f:/home/bin;g:/sw/perl/bin;g:/sw/emacs-20.7/bin;g:/sw/djgpp-~2/bin;g:/sw/djgpp-~1/bin;g:/sw/gnu/bin;c:/windows;c:/windows/command;c:/progra~1/atitec~1/aticon~1;c:/progra~1/atitec~1/aticon~1
    PERL_BADLANG (unset)
    SHELL (unset)




nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About