Pure perl trick that Apache::Table might be doing in C (fwd)

  This message is in MIME format.  The first part should be readable text,
  while the remaining parts are likely unreadable without MIME-aware tools.

--------------000801010106000704020802
Content-Type: TEXT/PLAIN; CHARSET=US-ASCII; FORMAT=flowed
Content-ID: <[email protected]>

---------- Forwarded message ----------
Date: Sat, 11 Jul 2009 15:03:03 +0930
From: Andrew Kirkpatrick <[email protected]>
To: [email protected]
Subject: Pure perl trick that Apache::Table might be doing in C

Hi David,

Perhaps this belongs on the Mason mailing lists, but I'm not sure which one, 
anyway if so let me know and I'll post there.

Around here: 
http://search.cpan.org/~drolsky/HTML-Mason-1.42/lib/HTML/Mason/CGIHandler.pm#HTML::Mason::FakeTable_Methods

There is the statement:

"HTML::Mason::FakeTable is designed to behave exactly like Apache::Table, and 
differs in only one respect. When a given key has multiple values in an 
Apache::Table object, one can fetch each of the values for that key using 
Perl's each operator"

I took that as an interesting exercise, and not having written a tie since the 
late 90s thought to give it a go. The result is a class that achieves the 
interface of Apache::Table, at least in that respect (see attached). I made it 
a modulino so you can give it a spin easily.

Hopefully it proves useful to someone. I've been striving to modernize the perl 
environment at the University of Adelaide, and while I think Catalyst is a 
clear winner for some apps I'm considering doing some CMS work in Mason.

Cheers,
Andrew Kirkpatrick
--------------000801010106000704020802
Content-Type: APPLICATION/X-PERL; NAME=MultiHash.pm
Content-ID: <[email protected]>
Content-Description: 
Content-Disposition: INLINE; FILENAME=MultiHash.pm

# Author: Andrew Kirkpatrick
# License: Artistic License 2.0
# see http://www.opensource.org/licenses/artistic-license-2.0.php

package MultiHash;

use strict;
use warnings;

sub TIEHASH {
  my ($class, $attr) = @_;
  return bless { attr => $attr }, $class;
}

sub FETCH {
  my ($self, $key) = @_;
  my $result;
  if (my $val = $self->{data}{$key}) {
    my $index = $self->{indx}{$key};
    $index = 0 if $index > $#$val;
    $result = $val->[$index];
    $index++;
    $self->{indx}{$key} = $index;
  }
  return $result;
}

sub STORE {
  my ($self, $key, $value) = @_;
  push @{$self->{data}{$key}}, $value;
  $self->{indx}{$key} ||= 0;
}

sub DELETE {
  my ($self, $key) = @_;
  if (my $data = $self->{data}{$key}) {
    my $result = $self->{attr}{fifo} ? shift @$data : pop @$data;
    unless (@$data) {
      delete $self->{data}{$key};
      delete $self->{indx}{$key};
    }
    return $result;
  } else {
    return;
  }
}

sub CLEAR {
  my ($self) = @_;
  $self->{data} = {};
  $self->{indx} = {};
}

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

sub FIRSTKEY {
  my ($self) = @_;
  my $dummy = keys %{$self->{data}};
  return each %{$self->{data}};
}

sub NEXTKEY {
  my ($self, $lastkey) = @_;
  if ($self->{indx}{$lastkey} < @{$self->{data}{$lastkey}}) {
    #my $count = @{$self->{data}{$lastkey}};
    #warn "key $lastkey: $self->{indx}{$lastkey} < $count\n";
    return wantarray ? ($lastkey, $self->FETCH($lastkey)) : $lastkey;
  } else {
    return each %{$self->{data}};
  }
}

sub SCALAR {
  my ($self) = @_;
  # this won't count multi values but should suffice
  return scalar %{$self->{data}};
}

sub UNTIE {
  my ($self) = @_;
  if ($self->{attr}{debug}) {
    require Data::Dumper;
    warn Data::Dumper::Dumper($self);
  }
}

1;

package main;

sub main {
  $| = 1;
  print "Testing $0\n";
  tie(my %mh, 'MultiHash', {debug => 1, fifo => 1});

  %mh = (
         one    => 1,
         two    => 2,
         two    => 3,
         two    => 4,
         three  => 5,
         three  => 6,
         seven  => 7,
        );

  my @two_values = map { $mh{two} } 1..12;
  print "\nConsecutive values of the key 'two': @two_values\n";

  print "\nEach loop:\n";
  while (my ($k, $v) = each %mh) {
    no warnings;
    print "$k => $v\n";
  }

  my @two_was = delete @mh{qw(two two two)};
  print "\nFrom deleting 'two' thrice: @two_was\n";

  print "\nDebug dump:\n";
  untie %mh;
}

# I knew I'd write a modulino one day :)
main() unless caller;

1;

--------------000801010106000704020802
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

------------------------------------------------------------------------------
Enter the BlackBerry Developer Challenge  
This is your chance to win up to $100,000 in prizes! For a limited time, 
vendors submitting new applications to BlackBerry App World(TM) will have
the opportunity to enter the BlackBerry Developer Challenge. See full prize  
details at: http://p.sf.net/sfu/Challenge
--------------000801010106000704020802
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

_______________________________________________
Mason-devel mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/mason-devel

--------------000801010106000704020802--