diff --git a/lib/Perlbal.pm b/lib/Perlbal.pm index c5fb9ca..38270c2 100644 --- a/lib/Perlbal.pm +++ b/lib/Perlbal.pm @@ -126,6 +126,13 @@ if ($ENV{PERLBAL_XS_HEADERS} && $XSModules{headers}) { Perlbal::XS::HTTPHeaders::enable(); } +# unactivate field::new +if ($ENV{PERLBAL_REMOVE_FIELDS}) { + use Perlbal::Fields; + Perlbal::Fields->remove(); +} + + # setup a USR1 signal handler that tells us to dump some basic statistics # of how we're doing to the syslog $SIG{'USR1'} = sub { diff --git a/lib/Perlbal/Fields.pm b/lib/Perlbal/Fields.pm new file mode 100644 index 0000000..6b1a440 --- /dev/null +++ b/lib/Perlbal/Fields.pm @@ -0,0 +1,47 @@ +package Perlbal::Fields; +use strict; +use warnings; +use fields; + +# allow package to be called in command line +__PACKAGE__->run(@ARGV) unless caller(); + +# should be the main method called, extra sub could be triggered from this point +sub run { + my ( $package, @options ) = @_; + + # unactivate fields if launch in command line + $package->remove(); + + 1; +} + +# hash with keys and undef val for each class +my $cache_for_class = {}; + +# replace fields::new method which uses Hash::Util::lock_ref_keys +# - it's a good idea to keep using the original fields::new during development stage +# - but during production we can avoid locking hash and wasting time doing this ( ~ 30 % ) +sub remove { + my ($class) = @_; + + no warnings "redefine"; + no strict 'refs'; + *fields::new = sub { + my $class = shift; + $class = ref $class if ref $class; + + if ( !defined( $cache_for_class->{$class} ) ) { + my $h = {}; + my @keys = keys %{ $class . "::FIELDS" }; + map { $h->{$_} = undef; } @keys; + $cache_for_class->{$class} = $h; + } + my %h = %{ $cache_for_class->{$class} }; + + return bless \%h, $class; + }; +} + +1; +