File Coverage

blib/lib/SQL/Translator/Filter/Names.pm

Criterion	Covered	Total	%
statement	33	34	97.0
branch	7	12	58.3
condition			n/a
subroutine	8	9	88.8
pod	0	4	0.0
total	48	59	81.3

package SQL::Translator::Filter::Names;

=head1 NAME

SQL::Translator::Filter::Names - Tweak the names of schema objects.

=head1 SYNOPSIS

  #! /usr/bin/perl -w
  use SQL::Translator;

  # Lowercase all table names and upper case the first letter of all field
  # names. (MySql style!)
  #
  my $sqlt = SQL::Translator->new(
      filename => \@ARGV,
      from     => 'MySQL',
      to       => 'MySQL',
      filters => [
        Names => {
            'tables' => 'lc',
            'fields' => 'ucfirst',
        },
      ],
  ) || die "SQLFairy error : ".SQL::Translator->error;
  print($sqlt->translate) || die "SQLFairy error : ".$sqlt->error;

=cut

use strict;
use warnings;
our $VERSION = '1.63';

sub filter {
    my $schema = shift;
    my %args = %{$_[0]};

    # Tables
    #if ( my $func = $args{tables} ) {
    #    _filtername($_,$func) foreach ( $schema->get_tables );
    #}
    # ,
    foreach my $type ( qw/tables procedures triggers views/ ) {
        if ( my $func = $args{$type} ) {
            my $meth = "get_$type";
            _filtername($_,$func) foreach $schema->$meth;
        }
    }

    # Fields
    if ( my $func = $args{fields} ) {
        _filtername($_,$func)
        foreach map { $_->get_fields } $schema->get_tables ;
    }

}

# _filtername( OBJ, FUNC_NAME )
# Update the name attribute on the schema object given using the named filter.
# Objects with no name are skipped.
# Returns true if the name was changed. Dies if there is an error running func.
sub _filtername {
    my ($obj,$func) = @_;
    return unless my $name = $obj->name;
    $func = _getfunc($func);
    my $newname = eval { $func->($name) };
    die "$@" if $@; # TODO - Better message!
    return if $name eq $newname;
    $_->name($newname);
}

# _getfunc( NAME ) - Returns code ref to func NAME or dies.
sub _getfunc {
    my ($name) = @_;
    no strict 'refs';
    my $func = "SQL::Translator::Filter::Names::$name";
    die "Table name filter - unknown function '$name'\n" unless exists &$func;
    \&$func;
}



# The name munging functions
#=============================================================================
# Get called with name to munge as first arg and return the new name. Die on
# errors.

sub lc { lc shift; }
sub uc { uc shift; }
sub ucfirst { ucfirst shift; }

1; #==========================================================================

__END__