Apache::FakeTable - Pure Perl implementation of the Apache::Table interface

  use Apache::FakeTable;

  my $table = Apache::FakeTable->new($r);

  $table->set(From => 'david@example.com');

  $table->add(Cookie => 'One Cookie');
  $table->add(Cookie => 'Another Cookie');

  while(my($key, $val) = each %$table) {
      print "$key: $val\n";
  }

  my $table = Apache::FakeTable->new($r);
  $table = Apache::FakeTable->new($r, $initial_size);

  my $value = $table->get($key);
  my @values = $table->get($key);
  my $value = $table->{$key};

  $table->set($key, $value);
  $table->{$key} = $value;

  $table->unset($key);
  delete $table->{$key};

  $table->clear;
  %$table = ();

  $table->add($key, $value);

  $table->merge($key, $value);

  $table->do($coderef);

package Apache::FakeTable;
use strict;
use vars qw($VERSION);
$VERSION = '0.05';

sub new {
    # We actually ignore the optional initial size argument.
    my ($class, $r) = @_;
    unless (UNIVERSAL::isa($r, 'Apache')) {
        require Carp;
        Carp::croak("Usage: " . __PACKAGE__ . "::new(pclass, r, nalloc=10)");
    }
    my $self = {};
    tie %{$self}, 'Apache::FakeTableHash';
    return bless $self, ref $class || $class;
}

sub get {
    tied(%{shift()})->_get(@_);
}

sub set {
    my ($self, $header, $value) = @_;
    # Issue a warning if the value is undefined.
    if (! defined $value and $^W) {
        require Carp;
        Carp::carp('Use of uninitialized value in null operation');
        $value = '';
    }
    $self->{$header} = $value;
}

sub unset {
    my $self = shift;
    delete $self->{shift()};
}

sub clear {
    %{shift()} = ();
}

sub add {
    # Issue a warning if the value is undefined.
    if (! defined $_[2] and $^W) {
        require Carp;
        Carp::carp('Use of uninitialized value in null operation');
        $_[2] = '';
    }
    tied(%{shift()})->_add(@_);
}

sub merge {
    my ($self, $key, $value) = @_;
    if (exists $self->{$key}) {
        $self->{$key} .= ', ' . $value;
    } else {
        $self->{$key} = $value;
    }
}

sub do {
    my ($self, $code) = @_;
    while (my ($k, $val) = each %$self) {
        for my $v (ref $val ? @$val : $val) {
            return unless $code->($k => $v);
        }
    }
}

1;

##############################################################################
# This is the implementation of the case-insensitive hash that each table
# object is based on.
package Apache::FakeTableHash;
use strict;
my %curr_keys;

sub TIEHASH {
    my $class = shift;
    return bless {}, ref $class || $class;
}

# Values are always stored as strings in an array.
sub STORE {
    my ($self, $key, $value) = @_;
    # Issue a warning if the value is undefined.
    if (! defined $value and $^W) {
        require Carp;
        Carp::carp('Use of uninitialized value in null operation');
        $value = '';
    }
    $self->{lc $key} = [ $key => ["$value"] ];
}

sub _add {
    my ($self, $key, $value) = @_;
    my $ckey = lc $key;
    if (exists $self->{$ckey}) {
        # Add it to the array,
        push @{$self->{$ckey}[1]}, "$value";
    } else {
        # It's a simple assignment.
        $self->{$ckey} = [ $key => ["$value"] ];
    }
}

sub DELETE {
    my ($self, $key) = @_;
    my $ret = delete $self->{lc $key};
    return $ret->[1][0];
}

sub FETCH {
    my $self = shift;
    my $key = lc shift;
    # Grab the values first so that we don't autovivicate the key.
    my $val = $self->{$key} or return;
    # If the key is the current key, return the value that's next. Otherwise,
    # return the first value.
    return $curr_keys{$self} && $curr_keys{$self}->[0] eq $key
      ? $val->[1][$curr_keys{$self}->[1]]
      : $val->[1][0];
}

sub _get {
    my ($self, $key) = @_;
    my $ckey = lc $key;
    # Prevent autovivication.
    return unless exists $self->{$ckey};
    # Return the array in an array context and just the first value in a
    # scalar context.
    return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0];
}

sub CLEAR {
    %{shift()} = ();
}

sub EXISTS {
    my ($self, $key)= @_;
    return exists $self->{lc $key};
}

my $keyer = sub {
    my $self = shift;
    # Get the next key via perl's iterator.
    my $key = each %$self;
    # If there's no key, clear out our tracking of the current key and return.
    delete $curr_keys{$self}, return unless defined $key;
    # Cache the key and array index 0 for NEXTKEY and FETCH to use.
    $curr_keys{$self} = [ $key => 0 ];
    return $self->{$key}[0];
};

sub FIRSTKEY {
    my $self = shift;
    # Reset perl's iterator and then get the key.
    keys %$self;
    $self->$keyer();
}

sub NEXTKEY {
    my ($self, $last_key) = @_;
    # Return the last key if there are more values to be fetched for it.
    my $ckey = lc $last_key;
    return $last_key
      if $curr_keys{$self}->[0] eq $ckey
      && ++$curr_keys{$self}->[1] <= $#{$self->{$ckey}[1]};

    # Otherwise, just get the next key.
    $self->$keyer();
}

# Just be sure to clear out the current key.
sub DESTROY { delete $curr_keys{shift()}; }

1;
__END__