[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Utils.pm

package SQL::Translator::Utils;

use strict;
use warnings;
use Digest::SHA qw( sha1_hex );
use File::Spec;

our $VERSION = '1.59';
our $DEFAULT_COMMENT = '-- ';

use base qw(Exporter);
our @EXPORT_OK = qw(
    debug normalize_name header_comment parse_list_arg truncate_id_uniquely
    $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
    ddl_parser_instance
);
use constant COLLISION_TAG_LENGTH => 8;

sub debug {
    my ($pkg, $file, $line, $sub) = caller(0);
    {
        no strict qw(refs);
        return unless ${"$pkg\::DEBUG"};
    }

    $sub =~ s/^$pkg\:://;

    while (@_) {
        my $x = shift;
        chomp $x;
        $x =~ s/\bPKG\b/$pkg/g;
        $x =~ s/\bLINE\b/$line/g;
        $x =~ s/\bSUB\b/$sub/g;
        #warn '[' . $x . "]\n";
        print STDERR '[' . $x . "]\n";
    }
}

sub normalize_name {
    my $name = shift or return '';

    # The name can only begin with a-zA-Z_; if there's anything
    # else, prefix with _
    $name =~ s/^([^a-zA-Z_])/_$1/;

    # anything other than a-zA-Z0-9_ in the non-first position
    # needs to be turned into _
    $name =~ tr/[a-zA-Z0-9_]/_/c;

    # All duplicated _ need to be squashed into one.
    $name =~ tr/_/_/s;

    # Trim a trailing _
    $name =~ s/_$//;

    return $name;
}

sub header_comment {
    my $producer = shift || caller;
    my $comment_char = shift;
    my $now = scalar localtime;

    $comment_char = $DEFAULT_COMMENT
        unless defined $comment_char;

    my $header_comment =<<"HEADER_COMMENT";
${comment_char}
${comment_char}Created by $producer
${comment_char}Created on $now
${comment_char}
HEADER_COMMENT

    # Any additional stuff passed in
    for my $additional_comment (@_) {
        $header_comment .= "${comment_char}${additional_comment}\n";
    }

    return $header_comment;
}

sub parse_list_arg {
    my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];

    #
    # This protects stringification of references.
    #
    if ( @$list && ref $list->[0] ) {
        return $list;
    }
    #
    # This processes string-like arguments.
    #
    else {
        return [
            map { s/^\s+|\s+$//g; $_ }
            map { split /,/ }
            grep { defined && length } @$list
        ];
    }
}

sub truncate_id_uniquely {
    my ( $desired_name, $max_symbol_length ) = @_;

    return $desired_name
      unless defined $desired_name && length $desired_name > $max_symbol_length;

    my $truncated_name = substr $desired_name, 0,
      $max_symbol_length - COLLISION_TAG_LENGTH - 1;

    # Hex isn't the most space-efficient, but it skirts around allowed
    # charset issues
    my $digest = sha1_hex($desired_name);
    my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;

    return $truncated_name
         . '_'
         . $collision_tag;
}


sub parse_mysql_version {
    my ($v, $target) = @_;

    return undef unless $v;

    $target ||= 'perl';

    my @vers;

    # X.Y.Z style
    if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
        push @vers, $1, $2, $3;
    }

    # XYYZZ (mysql) style
    elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
        push @vers, $1, $2, $3;
    }

    # XX.YYYZZZ (perl) style or simply X
    elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
        push @vers, $1, $2, $3;
    }
    else {
        #how do I croak sanely here?
        die "Unparseable MySQL version '$v'";
    }

    if ($target eq 'perl') {
        return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
    }
    elsif ($target eq 'mysql') {
        return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
    }
    else {
        #how do I croak sanely here?
        die "Unknown version target '$target'";
    }
}

sub parse_dbms_version {
    my ($v, $target) = @_;

    return undef unless $v;

    my @vers;

    # X.Y.Z style
    if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
        push @vers, $1, $2, $3;
    }

    # XX.YYYZZZ (perl) style or simply X
    elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
        push @vers, $1, $2, $3;
    }
    else {
        #how do I croak sanely here?
        die "Unparseable database server version '$v'";
    }

    if ($target eq 'perl') {
        return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
    }
    elsif ($target eq 'native') {
        return join '.' => grep defined, @vers;
    }
    else {
        #how do I croak sanely here?
        die "Unknown version target '$target'";
    }
}

#my ($parsers_libdir, $checkout_dir);
sub ddl_parser_instance {

    my $type = shift;

    # it may differ from our caller, even though currently this is not the case
    eval "require SQL::Translator::Parser::$type"
        or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@";

    require Parse::RecDescent;
    return Parse::RecDescent->new(do {
      no strict 'refs';
      ${"SQL::Translator::Parser::${type}::GRAMMAR"}
        || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
    });

# this is disabled until RT#74593 is resolved
=begin for general sadness

    unless ($parsers_libdir) {

        # are we in a checkout?
        if ($checkout_dir = _find_co_root()) {
            $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
        }
        else {
            require File::ShareDir;
            $parsers_libdir = File::Spec->catdir(
              File::ShareDir::dist_dir('SQL-Translator'),
              'PrecompiledParsers'
            );
        }

        unshift @INC, $parsers_libdir;
    }

    my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";

    # FIXME FIXME FIXME
    # Parse::RecDescent has horrible architecture where each precompiled parser
    # instance shares global state with all its siblings
    # What we do here is gross, but scarily efficient - the parser compilation
    # is much much slower than an unload/reload cycle
    require Class::Unload;
    Class::Unload->unload($precompiled_mod);

    # There is also a sub-namespace that P::RD uses, but simply unsetting
    # $^W to stop redefine warnings seems to be enough
    #Class::Unload->unload("Parse::RecDescent::$precompiled_mod");

    eval "local \$^W; require $precompiled_mod" or do {
        if ($checkout_dir) {
            die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
        }
        else {
            die "Unable to load precompiled grammar for $type... this is not supposed to happen if you are not in a checkout, please file a bugreport:\n$@"
        }
    };

    my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
    my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};

    if (
        (stat($grammar_spec_fn))[9]
            >
        (stat($precompiled_fn))[9]
    ) {
        die (
            "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
          . ($checkout_dir
                ? " - run Makefile.PL to regenerate stale versions\n"
                : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
            )
        );
    }

    return $precompiled_mod->new;
=cut

}

# Try to determine the root of a checkout/untar if possible
# or return undef
sub _find_co_root {

    my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
    my $rel_path = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS

    return undef unless ($INC{$rel_path});

    # a bit convoluted, but what we do here essentially is:
    #  - get the file name of this particular module
    #  - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..

    my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
    for (1 .. @mod_parts) {
        $root = File::Spec->catdir($root, File::Spec->updir);
    }

    return ( -f File::Spec->catfile($root, 'Makefile.PL') )
        ? $root
        : undef
    ;
}

1;

=pod

=head1 NAME

SQL::Translator::Utils - SQL::Translator Utility functions

=head1 SYNOPSIS

  use SQL::Translator::Utils qw(debug);
  debug("PKG: Bad things happened");

=head1 DESCSIPTION

C<SQL::Translator::Utils> contains utility functions designed to be
used from the other modules within the C<SQL::Translator> modules.

Nothing is exported by default.

=head1 EXPORTED FUNCTIONS AND CONSTANTS

=head2 debug

C<debug> takes 0 or more messages, which will be sent to STDERR using
C<warn>.  Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
will be replaced by the calling package, subroutine, and line number,
respectively, as reported by C<caller(1)>.

For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:

  debug("PKG: Error reading file at SUB/LINE");

Will warn

  [SQL::Translator: Error reading file at foo/666]

The entire message is enclosed within C<[> and C<]> for visual clarity
when STDERR is intermixed with STDOUT.

=head2 normalize_name

C<normalize_name> takes a string and ensures that it is suitable for
use as an identifier.  This means: ensure that it starts with a letter
or underscore, and that the rest of the string consists of only
letters, numbers, and underscores.  A string that begins with
something other than [a-zA-Z] will be prefixer with an underscore, and
all other characters in the string will be replaced with underscores.
Finally, a trailing underscore will be removed, because that's ugly.

  normalize_name("Hello, world");

Produces:

  Hello_world

A more useful example, from the C<SQL::Translator::Parser::Excel> test
suite:

  normalize_name("silly field (with random characters)");

returns:

  silly_field_with_random_characters

=head2 header_comment

Create the header comment.  Takes 1 mandatory argument (the producer
classname), an optional comment character (defaults to $DEFAULT_COMMENT),
and 0 or more additional comments, which will be appended to the header,
prefixed with the comment character.  If additional comments are provided,
then a comment string must be provided ($DEFAULT_COMMENT is exported for
this use).  For example, this:

  package My::Producer;

  use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);

  print header_comment(__PACKAGE__,
                       $DEFAULT_COMMENT,
                       "Hi mom!");

produces:

  --
  -- Created by My::Prodcuer
  -- Created on Fri Apr 25 06:56:02 2003
  --
  -- Hi mom!
  --

Note the gratuitous spacing.

=head2 parse_list_arg

Takes a string, list or arrayref (all of which could contain
comma-separated values) and returns an array reference of the values.
All of the following will return equivalent values:

  parse_list_arg('id');
  parse_list_arg('id', 'name');
  parse_list_arg( 'id, name' );
  parse_list_arg( [ 'id', 'name' ] );
  parse_list_arg( qw[ id name ] );

=head2 truncate_id_uniquely

Takes a string ($desired_name) and int ($max_symbol_length). Truncates
$desired_name to $max_symbol_length by including part of the hash of
the full name at the end of the truncated name, giving a high
probability that the symbol will be unique. For example,

  truncate_id_uniquely( 'a' x 100, 64 )
  truncate_id_uniquely( 'a' x 99 . 'b', 64 );
  truncate_id_uniquely( 'a' x 99,  64 )

Will give three different results; specifically:

  aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
  aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
  aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2

=head2 $DEFAULT_COMMENT

This is the default comment string, '-- ' by default.  Useful for
C<header_comment>.

=head2 parse_mysql_version

Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
consistent format for both C<< parser_args->{mysql_parser_version} >> and
C<< producer_args->{mysql_version} >> respectively. Takes any of the following
version specifications:

  5.0.3
  4.1
  3.23.2
  5
  5.001005  (perl style)
  30201     (mysql style)

=head2 parse_dbms_version

Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
or 'native') transforms the string to the given target style.
to

=head1 AUTHORS

Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.

=cut
Commit	Line	Data
1a24938d	1	package SQL::Translator::Utils;
1a24938d	2
1a24938d	3	use strict;
f27f9229	4	use warnings;
c092c5b3	5	use Digest::SHA qw( sha1_hex );
bdf60588	6	use File::Spec;
1a24938d	7
0c04c5a2	8	our $VERSION = '1.59';
0c04c5a2	9	our $DEFAULT_COMMENT = '-- ';
bdf60588	10
bdf60588	11	use base qw(Exporter);
0c04c5a2	12	our @EXPORT_OK = qw(
7b4b17aa	13	debug normalize_name header_comment parse_list_arg truncate_id_uniquely
7b4b17aa	14	$DEFAULT_COMMENT parse_mysql_version parse_dbms_version
bdf60588	15	ddl_parser_instance
118bb73f	16	);
11ad2df9	17	use constant COLLISION_TAG_LENGTH => 8;
1a24938d	18
1a24938d	19	sub debug {
a2ba36ba	20	my ($pkg, $file, $line, $sub) = caller(0);
1a24938d	21	{
	22	no strict qw(refs);
	23	return unless ${"$pkg\::DEBUG"};
	24	}
	25
	26	$sub =~ s/^$pkg\:://;
	27
	28	while (@_) {
	29	my $x = shift;
	30	chomp $x;
	31	$x =~ s/\bPKG\b/$pkg/g;
	32	$x =~ s/\bLINE\b/$line/g;
	33	$x =~ s/\bSUB\b/$sub/g;
	34	#warn '[' . $x . "]\n";
	35	print STDERR '[' . $x . "]\n";
	36	}
	37	}
	38
93d12e9c	39	sub normalize_name {
ae48473b	40	my $name = shift or return '';
93d12e9c	41
	42	# The name can only begin with a-zA-Z_; if there's anything
	43	# else, prefix with _
	44	$name =~ s/^([^a-zA-Z_])/_$1/;
	45
	46	# anything other than a-zA-Z0-9_ in the non-first position
	47	# needs to be turned into _
	48	$name =~ tr/[a-zA-Z0-9_]/_/c;
	49
	50	# All duplicated _ need to be squashed into one.
	51	$name =~ tr/_/_/s;
	52
	53	# Trim a trailing _
	54	$name =~ s/_$//;
	55
	56	return $name;
	57	}
	58
a2ba36ba	59	sub header_comment {
	60	my $producer = shift \|\| caller;
	61	my $comment_char = shift;
	62	my $now = scalar localtime;
	63
	64	$comment_char = $DEFAULT_COMMENT
	65	unless defined $comment_char;
	66
	67	my $header_comment =<<"HEADER_COMMENT";
	68	${comment_char}
	69	${comment_char}Created by $producer
	70	${comment_char}Created on $now
	71	${comment_char}
	72	HEADER_COMMENT
	73
	74	# Any additional stuff passed in
	75	for my $additional_comment (@_) {
	76	$header_comment .= "${comment_char}${additional_comment}\n";
	77	}
	78
	79	return $header_comment;
	80	}
	81
e545d971	82	sub parse_list_arg {
	83	my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
	84
51bb6fe0	85	#
	86	# This protects stringification of references.
	87	#
	88	if ( @$list && ref $list->[0] ) {
	89	return $list;
	90	}
	91	#
	92	# This processes string-like arguments.
	93	#
	94	else {
ea93df61	95	return [
51bb6fe0	96	map { s/^\s+\|\s+$//g; $_ }
	97	map { split /,/ }
	98	grep { defined && length } @$list
	99	];
	100	}
118bb73f	101	}
118bb73f	102
f5405d47	103	sub truncate_id_uniquely {
	104	my ( $desired_name, $max_symbol_length ) = @_;
	105
16fa91c0	106	return $desired_name
16fa91c0	107	unless defined $desired_name && length $desired_name > $max_symbol_length;
f5405d47	108
16fa91c0	109	my $truncated_name = substr $desired_name, 0,
11ad2df9	110	$max_symbol_length - COLLISION_TAG_LENGTH - 1;
f5405d47	111
	112	# Hex isn't the most space-efficient, but it skirts around allowed
	113	# charset issues
	114	my $digest = sha1_hex($desired_name);
11ad2df9	115	my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
f5405d47	116
	117	return $truncated_name
	118	. '_'
	119	. $collision_tag;
	120	}
	121
5d666b31	122
5d666b31	123	sub parse_mysql_version {
	124	my ($v, $target) = @_;
	125
	126	return undef unless $v;
	127
	128	$target \|\|= 'perl';
	129
	130	my @vers;
	131
ea93df61	132	# X.Y.Z style
5d666b31	133	if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
	134	push @vers, $1, $2, $3;
	135	}
	136
ea93df61	137	# XYYZZ (mysql) style
5d666b31	138	elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
	139	push @vers, $1, $2, $3;
	140	}
	141
ea93df61	142	# XX.YYYZZZ (perl) style or simply X
5d666b31	143	elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
	144	push @vers, $1, $2, $3;
	145	}
	146	else {
	147	#how do I croak sanely here?
	148	die "Unparseable MySQL version '$v'";
	149	}
	150
	151	if ($target eq 'perl') {
	152	return sprintf ('%d.%03d%03d', map { $_ \|\| 0 } (@vers) );
	153	}
	154	elsif ($target eq 'mysql') {
	155	return sprintf ('%d%02d%02d', map { $_ \|\| 0 } (@vers) );
	156	}
	157	else {
	158	#how do I croak sanely here?
	159	die "Unknown version target '$target'";
	160	}
	161	}
	162
7b4b17aa	163	sub parse_dbms_version {
	164	my ($v, $target) = @_;
	165
	166	return undef unless $v;
	167
	168	my @vers;
	169
ea93df61	170	# X.Y.Z style
7b4b17aa	171	if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
	172	push @vers, $1, $2, $3;
	173	}
	174
ea93df61	175	# XX.YYYZZZ (perl) style or simply X
7b4b17aa	176	elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
	177	push @vers, $1, $2, $3;
	178	}
	179	else {
	180	#how do I croak sanely here?
	181	die "Unparseable database server version '$v'";
	182	}
	183
	184	if ($target eq 'perl') {
	185	return sprintf ('%d.%03d%03d', map { $_ \|\| 0 } (@vers) );
	186	}
	187	elsif ($target eq 'native') {
e0d18105	188	return join '.' => grep defined, @vers;
7b4b17aa	189	}
	190	else {
	191	#how do I croak sanely here?
	192	die "Unknown version target '$target'";
	193	}
	194	}
5d666b31	195
0eb3b94a	196	#my ($parsers_libdir, $checkout_dir);
bdf60588	197	sub ddl_parser_instance {
0eb3b94a	198
bdf60588	199	my $type = shift;
	200
	201	# it may differ from our caller, even though currently this is not the case
	202	eval "require SQL::Translator::Parser::$type"
	203	or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@";
	204
0eb3b94a	205	require Parse::RecDescent;
	206	return Parse::RecDescent->new(do {
	207	no strict 'refs';
	208	${"SQL::Translator::Parser::${type}::GRAMMAR"}
	209	\|\| die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
	210	});
	211
	212	# this is disabled until RT#74593 is resolved
	213	=begin for general sadness
	214
bdf60588	215	unless ($parsers_libdir) {
	216
	217	# are we in a checkout?
	218	if ($checkout_dir = _find_co_root()) {
	219	$parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
	220	}
	221	else {
	222	require File::ShareDir;
	223	$parsers_libdir = File::Spec->catdir(
	224	File::ShareDir::dist_dir('SQL-Translator'),
	225	'PrecompiledParsers'
	226	);
	227	}
	228
	229	unshift @INC, $parsers_libdir;
	230	}
	231
	232	my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
	233
	234	# FIXME FIXME FIXME
	235	# Parse::RecDescent has horrible architecture where each precompiled parser
	236	# instance shares global state with all its siblings
	237	# What we do here is gross, but scarily efficient - the parser compilation
	238	# is much much slower than an unload/reload cycle
f2ab5843	239	require Class::Unload;
bdf60588	240	Class::Unload->unload($precompiled_mod);
	241
	242	# There is also a sub-namespace that P::RD uses, but simply unsetting
	243	# $^W to stop redefine warnings seems to be enough
	244	#Class::Unload->unload("Parse::RecDescent::$precompiled_mod");
	245
	246	eval "local \$^W; require $precompiled_mod" or do {
	247	if ($checkout_dir) {
	248	die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
	249	}
	250	else {
	251	die "Unable to load precompiled grammar for $type... this is not supposed to happen if you are not in a checkout, please file a bugreport:\n$@"
	252	}
	253	};
	254
	255	my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
	256	my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
	257
	258	if (
	259	(stat($grammar_spec_fn))[9]
	260	>
	261	(stat($precompiled_fn))[9]
	262	) {
	263	die (
	264	"Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
	265	. ($checkout_dir
	266	? " - run Makefile.PL to regenerate stale versions\n"
	267	: "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
	268	)
	269	);
	270	}
	271
	272	return $precompiled_mod->new;
0eb3b94a	273	=cut
0eb3b94a	274
bdf60588	275	}
	276
	277	# Try to determine the root of a checkout/untar if possible
	278	# or return undef
	279	sub _find_co_root {
	280
	281	my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
	282	my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS
	283
	284	return undef unless ($INC{$rel_path});
	285
	286	# a bit convoluted, but what we do here essentially is:
	287	# - get the file name of this particular module
	288	# - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..
	289
	290	my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
	291	for (1 .. @mod_parts) {
	292	$root = File::Spec->catdir($root, File::Spec->updir);
	293	}
	294
	295	return ( -f File::Spec->catfile($root, 'Makefile.PL') )
	296	? $root
	297	: undef
	298	;
	299	}
	300
1a24938d	301	1;
1a24938d	302
118bb73f	303	=pod
1a24938d	304
	305	=head1 NAME
	306
	307	SQL::Translator::Utils - SQL::Translator Utility functions
	308
	309	=head1 SYNOPSIS
	310
	311	use SQL::Translator::Utils qw(debug);
	312	debug("PKG: Bad things happened");
	313
	314	=head1 DESCSIPTION
	315
	316	C<SQL::Translator::Utils> contains utility functions designed to be
	317	used from the other modules within the C<SQL::Translator> modules.
	318
a2ba36ba	319	Nothing is exported by default.
1a24938d	320
a2ba36ba	321	=head1 EXPORTED FUNCTIONS AND CONSTANTS
1a24938d	322
	323	=head2 debug
	324
	325	C<debug> takes 0 or more messages, which will be sent to STDERR using
	326	C<warn>. Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
	327	will be replaced by the calling package, subroutine, and line number,
e545d971	328	respectively, as reported by C<caller(1)>.
1a24938d	329
	330	For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
	331
	332	debug("PKG: Error reading file at SUB/LINE");
	333
	334	Will warn
	335
	336	[SQL::Translator: Error reading file at foo/666]
	337
	338	The entire message is enclosed within C<[> and C<]> for visual clarity
	339	when STDERR is intermixed with STDOUT.
93d12e9c	340
	341	=head2 normalize_name
	342
	343	C<normalize_name> takes a string and ensures that it is suitable for
	344	use as an identifier. This means: ensure that it starts with a letter
	345	or underscore, and that the rest of the string consists of only
	346	letters, numbers, and underscores. A string that begins with
	347	something other than [a-zA-Z] will be prefixer with an underscore, and
	348	all other characters in the string will be replaced with underscores.
	349	Finally, a trailing underscore will be removed, because that's ugly.
	350
	351	normalize_name("Hello, world");
	352
	353	Produces:
	354
	355	Hello_world
	356
	357	A more useful example, from the C<SQL::Translator::Parser::Excel> test
	358	suite:
	359
	360	normalize_name("silly field (with random characters)");
	361
	362	returns:
	363
	364	silly_field_with_random_characters
	365
a2ba36ba	366	=head2 header_comment
	367
	368	Create the header comment. Takes 1 mandatory argument (the producer
	369	classname), an optional comment character (defaults to $DEFAULT_COMMENT),
	370	and 0 or more additional comments, which will be appended to the header,
	371	prefixed with the comment character. If additional comments are provided,
	372	then a comment string must be provided ($DEFAULT_COMMENT is exported for
	373	this use). For example, this:
	374
	375	package My::Producer;
	376
	377	use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
	378
	379	print header_comment(__PACKAGE__,
e545d971	380	$DEFAULT_COMMENT,
a2ba36ba	381	"Hi mom!");
	382
	383	produces:
	384
e545d971	385	--
a2ba36ba	386	-- Created by My::Prodcuer
a2ba36ba	387	-- Created on Fri Apr 25 06:56:02 2003
e545d971	388	--
a2ba36ba	389	-- Hi mom!
e545d971	390	--
a2ba36ba	391
	392	Note the gratuitous spacing.
	393
118bb73f	394	=head2 parse_list_arg
	395
	396	Takes a string, list or arrayref (all of which could contain
	397	comma-separated values) and returns an array reference of the values.
	398	All of the following will return equivalent values:
	399
	400	parse_list_arg('id');
	401	parse_list_arg('id', 'name');
	402	parse_list_arg( 'id, name' );
	403	parse_list_arg( [ 'id', 'name' ] );
	404	parse_list_arg( qw[ id name ] );
	405
f5405d47	406	=head2 truncate_id_uniquely
	407
	408	Takes a string ($desired_name) and int ($max_symbol_length). Truncates
	409	$desired_name to $max_symbol_length by including part of the hash of
	410	the full name at the end of the truncated name, giving a high
	411	probability that the symbol will be unique. For example,
	412
	413	truncate_id_uniquely( 'a' x 100, 64 )
	414	truncate_id_uniquely( 'a' x 99 . 'b', 64 );
	415	truncate_id_uniquely( 'a' x 99, 64 )
	416
	417	Will give three different results; specifically:
	418
	419	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
	420	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
	421	aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
	422
a2ba36ba	423	=head2 $DEFAULT_COMMENT
	424
	425	This is the default comment string, '-- ' by default. Useful for
	426	C<header_comment>.
	427
5d666b31	428	=head2 parse_mysql_version
5d666b31	429
ea93df61	430	Used by both L<Parser::MySQL\|SQL::Translator::Parser::MySQL> and
5d666b31	431	L<Producer::MySQL\|SQL::Translator::Producer::MySQL> in order to provide a
	432	consistent format for both C<< parser_args->{mysql_parser_version} >> and
	433	C<< producer_args->{mysql_version} >> respectively. Takes any of the following
	434	version specifications:
	435
	436	5.0.3
	437	4.1
	438	3.23.2
	439	5
	440	5.001005 (perl style)
	441	30201 (mysql style)
	442
282bf498	443	=head2 parse_dbms_version
	444
	445	Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
	446	or 'native') transforms the string to the given target style.
	447	to
	448
118bb73f	449	=head1 AUTHORS
	450
	451	Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
11ad2df9	452	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
118bb73f	453
118bb73f	454	=cut