File Coverage

blib/lib/Params/Style.pm

Criterion	Covered	Total	%
statement	97	99	97.9
branch	21	22	95.4
condition	4	8	50.0
subroutine	24	24	100.0
pod	9	9	100.0
total	155	162	95.6

package Params::Style;

# $Id: Style.pm,v 1.3 2005/11/29 14:36:10 mrodrigu Exp $

use strict;
use warnings;
use Carp;

require Exporter;

use vars qw( @ISA %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION);

@ISA = qw(Exporter);

# This allows declaration use Params::Style ':all';
%EXPORT_TAGS = ( all => [ qw( &perl_style_params &javaStyleParams &JavaStyleParams &nostyleparams &replace_keys) ] );

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} },  &replace_keys,
               &perl_style_params, &javaStyleParams, &JavaStyleParams, &nostyleparams
             );

$VERSION = '0.06';


my( $uc, $UC);

BEGIN
  { if( $] >= 5.007) { $uc  = qr/\p{UppercaseLetter}/;
                       $UC  = qr/\P{UppercaseLetter}/;
                     }
    else             { $uc= qr/[A-Z]/;
                       $UC= qr/[^A-Z]/;
                     }
  }

################################################################
#                                                              #
#                   functional interface                       #
#                                                              #
################################################################

sub replace_keys
  { my $replace_keys = shift; # sub call to use on each key

    if( @_ == 1)
      { # should be a reference
        my $options= shift;
        if( UNIVERSAL::isa( $options, 'ARRAY'))
          { if( scalar @$options % 2) { _croak_odd_arg_nb(); }
            my @options; my $flip= 0;
            foreach (@$options)
              { if( $flip=1-$flip) { push @options, $replace_keys->( $_); }
                else               { push @options, $_;              }
              }
            return \@options;
          }
        elsif( UNIVERSAL::isa( $options, 'HASH'))
          { my %options= map { $replace_keys->($_) => $options->{$_} } keys %$options;
            return \%options;
          }
        else
          { _croak_wrong_arg_type( ref $options); }

          }
    else
      {  if( scalar @_ % 2) { _croak_odd_arg_nb(); }
        my @options;
        while( my $key= shift @_) { push @options, $replace_keys->( $key), shift( @_); }
        return @options;
      }
  }

sub perl_style_params { return replace_keys( \&perl_style, @_); }
sub javaStyleParams   { return replace_keys( \&javaStyle,  @_); }
sub JavaStyleParams   { return replace_keys( \&JavaStyle,  @_); }
sub nostyleparams     { return replace_keys( \&nostyle,    @_); }


################################################################
#                                                              #
#                   basic replace style                        #
#                                                              #
################################################################

sub javaStyle { my $name= shift;    $name=~ s{_(\w)}{\U$1}g;       return $name; }
sub JavaStyle { my $name= shift;    $name=~ s{(?:_|^)(\w)}{\U$1}g; return $name; }
sub nostyle   { my $name= lc shift; $name=~ s{_}{}g;               return $name; }

sub perl_style
  { my $name= shift;
    return $name if( $name=~ m{_});
    $name=~ s{(?
    $name=~ s{(?
    $name=~ s{_($uc)$}{_\L$1};
    $name=~ s{^_}{};
    return $name;
  }

sub _croak_odd_arg_nb
  { my $pn_sub= (caller(2))[3];
    my ($package, $filename, $line)= (caller(3))[0..2];
    $filename||= ''; $line ||= '';
    die "odd number of arguments passed to $pn_sub at $filename line $line\n";
  }

sub _croak_wrong_arg_type
  { my $type= shift;
    my $pn_sub= (caller(2))[3];
    my ($package, $filename, $line)= (caller(3))[0..2];
    $filename||= ''; $line ||= '';
    die "wrong arguments type $type passed to $pn_sub at $filename line $line ",
         "should be hash, hashref, array or array ref\n";
  }

################################################################
#                                                              #
#                   tied hash interface                        #
#                                                              #
################################################################

use Attribute::Handlers autotie => { '__CALLER__::ParamsStyle' => __PACKAGE__ };

use vars qw(@ISA);
use Tie::Hash;
unshift @ISA, 'Tie::ExtraHash';

my %replace_func= ( perl_style => \&Params::Style::perl_style,
                    javaStyle  => \&Params::Style::javaStyle,
                    JavaStyle  => \&Params::Style::JavaStyle,
                    nostyle    => \&Params::Style::nostyle,
                  );
my $DEFAULT_STYLE= 'perl_style';


sub TIEHASH
  { my( $class, $style)= @_;
    my $replace_keys;
    if( UNIVERSAL::isa( $style, 'CODE'))
      { $replace_keys= $style; }
    elsif( $style)
      { $replace_keys= $replace_func{$style} or croak "wrong Params::Style style '$style'\n"; }
    else
      { $replace_keys= $replace_func{$DEFAULT_STYLE}; }

    return bless [ {}, $replace_keys ], $class;
  }


sub STORE
  { my( $hash, $key, $value)= @_;
    my( $storage, $replace_keys)= @$hash;
    $storage->{$replace_keys->($key)}= $value;
  }

sub EXISTS
  { my( $hash, $key)= @_;
    my( $storage, $replace_keys)= @$hash;
    return exists $storage->{$replace_keys->($key)};
  }

sub FETCH
  { my( $hash, $key)= @_;
    my( $storage, $replace_keys)= @$hash;
    return $storage->{$replace_keys->($key)};
  }



1;
__END__