File Coverage

blib/lib/Apache/FakeTable.pm

Criterion	Covered	Total	%
statement	81	82	98.7
branch	21	26	80.7
condition	13	21	61.9
subroutine	22	22	100.0
pod	8	8	100.0
total	145	159	91.1

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

=head1 Name

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

=head1 Synopsis

  use Apache::FakeTable;

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

  $table->set(From => '[e-mail]');

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

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

=head1 Description

This class emulates the behavior of the L class, and is
designed to behave exactly like Apache::Table. This means that all keys are
case-insensitive and may have multiple values. As a drop-in substitute for
Apache::Table, you should be able to use it exactly like Apache::Table.

You can treat an Apache::FakeTable object much like any other hash. However,
like Apache Table, those keys that contain multiple values will trigger
slightly different behavior than a traditional hash. The variations in
behavior are as follows:

=over

=item keys

Will return the same key multiple times, once for each value stored for that
key.

=item values

Will return the first value multiple times, once for each value stored for a
given key. It'd be nice if it returned all the values for a given key, instead
of the first value C<*> the number of values, but that's not the way
Apache::Table works, and I'm not sure I'd know how to implement it even if it
did!

=item each

Will return the same key multiple times, pairing it with each of its values
in turn.

=back

Otherwise, things should be quite hash-like, particularly when a key has only
a single value.

=head1 Interface

=head3 new()

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

Returns a new C object. An L object is required as
the first argument. An optional second argument sets the initial size of the
table for storing values.

=cut

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;
}

=head3 get()

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

Gets the value stored for a given key in the table. If a key has multiple
values, all will be returned when C is called in an array context, and
only the first value when it is called in a scalar context.

=cut

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

=head3 set()

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

Takes key and value arguments and sets the value for that key. Previous values
for that key will be discarded. The value must be a string, or C will
turn it into one. A value of C will be converted to the null string
('') a warning will be issued if warnings are enabled.

=cut

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;
}

=head3 unset()

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

Takes a single key argument and deletes that key from the table, so that none
of its values will be in the table any longer.

=cut

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

=head3 clear()

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

Clears the table of all values.

=cut

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

=head3 add()

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

Adds a new value to the table. This method is the sole interface for adding
mutiple values for a single key.

=cut

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');
        splice @_, 2, 1, '';
    }
    tied(%{shift()})->_add(@_);
}

=head3 merge()

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

Merges a new value with an existing value by appending the new value to the
existing. The result is a string with the old value separated from the new by
a comma and a space. If C<$key> contains multiple values, then only the first
value will be used before appending the new value, and the remaining values
will be discarded.

=cut

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

=head3 do()

  $table->do($coderef);

Pass a code reference to this method to have it iterate over all of the
key/value pairs in the table. Keys with multiple values will trigger the
execution of the code reference multiple times, once for each value. The code
reference should expect two arguments: a key and a value. Iteration terminates
when the code reference returns false, so be sure to have it return a true
value if you want it to iterate over every value in the table.

=cut

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__