Much wider support for Catacomb in all its glory.

[catacomb-perl] / Catacomb / Cache.pm

# -*-perl-*-
#
# $Id$
#
# Caching for fields, curves, groups, ...
#
# (c) 2004 Straylight/Edgeware
#

#----- Licensing notice -----------------------------------------------------
#
# This file is part of the Perl interface to Catacomb.
#
# Catacomb/Perl is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# Catacomb/Perl is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with Catacomb/Perl; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

package Catacomb::Cache::Ref;

sub new {
  my ($me, $c) = @_;
  $c->[0]++;
  return bless [$c], $me;
}

sub DESTROY {
  my ($me) = @_;
  my $c = $me->[0];
  if ($c->[0] > 1) { $c->[0]--; return; }
  delete $c->[1]{$c->[2]};
}

package Catacomb::Cache;

$debug = 1;

sub stringify {
  my ($x) = @_;
  if (ref($x) eq ARRAY) {
    return "[" . join("/", map(stringify($_), @$x)) . "]";
  } else {
    return $x;
  }
}

sub new { my ($me) = @_; return bless { }, $me; }

sub intern {
  my ($c, $x) = @_;
  my $k = stringify($x->get());
  my $e;
  if (exists($c->{$k})) {
    $e = $c->{$k};
  } else {
    $e = $c->{$k} = [0, $c, $k, $x];
  }
  return $e->[3], Catacomb::Cache::Ref->new($e);
}

#----- That's all, folks ----------------------------------------------------

1;