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)
