On creating hash whose keys aren't case-sensitive

[anazawa]

Hi Monks, I'm working on the following situation:

package main;
use CGI qw(header);
our $header_ref = { -type => 'text/html' };

# loads plugins

print header( $header_ref );

Above script passes a hash reference CGI::header to generate HTTP headers. CGI::header doesn't care whether keys are lowercased or camelized, nor whether to put a dash before a key. And also underscores are translated into dashes. And so the following parameters are semantically equivalent:

$header_ref = {
    'content-length'  => 1234,
    'content_length'  => 1234,
    '-content-length' => 1234,
    '-content_length' => 1234,
    'Content-Length'  => 1234,
    'Content_Length'  => 1234,
    '-Content-Length' => 1234,
    '-Content_Length' => 1234,
};

Plugin developers can modify $main::header_ref. When they modify HTTP headers, they must write as follows:

# plugins/foo
package foo;
$main::header_ref->{'-status'} = '304 Not Modified';

Another plugin may be as follows:

# plugins/bar
package bar;
$main::header_ref->{'Status'} = '404 Not Found';

To solve above problem, I wrote the following module;

# plugins/foo
package foo;
use Header qw(set_header);
set_header( $main::header, 'Status' => '304 Not Modified');

# Header.pm
package Header;
use Exporter 'import';
use List::Util qw(first);

our @EXPORT_OK = qw(get_header set_header exists_header delete_header)
+;

sub get_header {
    my $header_ref = shift;
    my $key        = _lc( shift );

    if ( wantarray ) {
        my @keys = grep { _lc( $_ ) eq $key } keys %{ $header_ref };
        return @{ $header_ref }{ @keys };
    }
    else {
        my $first_key = first { _lc( $_ ) eq $key } keys %{ $header_re
+f };
        return $header_ref->{ $first_key };
    }
}

sub set_header {
    my $header_ref = shift;
    my $key        = shift;
    my $value      = shift;
    my @keys       = grep { _lc( $_ ) eq _lc( $key ) } keys %{ $header
+_ref };

    if ( @keys ) {
        $key = shift @keys;
        delete @{ $header_ref }{ @keys };
    }

    $header_ref->{ $key } = $value;

    return;
}

sub exists_header {
    my $header_ref = shift;
    my $key        = _lc( shift );
    my @keys       = grep { _lc( $_ ) eq $key } keys %{ $header_ref };

    return scalar @keys;
}

sub delete_header {
    my $header_ref = shift;
    my $key        = _lc( shift );

    # deletes elements whose key matches $key
    my @keys = grep { _lc( $_ ) eq $key } keys %{ $header_ref };
    delete @{ $header_ref }{ @keys };

    return;
}

# returns a lowercased version of a given string
sub _lc {
    my $key = lc shift;

    # get rid of an initial dash if exists
    $key =~ s{^\-}{};

    # use dashes instead of underscores
    $key =~ tr{_}{-};

    return $key;
}

I don't think that the above way is the best to solve the problem. Although I intended to use Tie::Hash to implement above features, I don't understand how to use this module. I'm waiting for your suggestions or comments.

Update: NOTE: I assumed that I might not modify the main script. (Thanks to tobyinc)