1 package SQL::Translator::Utils;
5 use Digest::SHA qw( sha1_hex );
7 use Scalar::Util qw(blessed);
9 use Carp qw(carp croak);
11 our $VERSION = '1.59';
12 our $DEFAULT_COMMENT = '-- ';
14 use base qw(Exporter);
16 debug normalize_name header_comment parse_list_arg truncate_id_uniquely
17 $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
18 ddl_parser_instance batch_alter_table_statements
20 normalize_quote_options
22 use constant COLLISION_TAG_LENGTH => 8;
25 my ($pkg, $file, $line, $sub) = caller(0);
28 return unless ${"$pkg\::DEBUG"};
36 $x =~ s/\bPKG\b/$pkg/g;
37 $x =~ s/\bLINE\b/$line/g;
38 $x =~ s/\bSUB\b/$sub/g;
39 #warn '[' . $x . "]\n";
40 print STDERR '[' . $x . "]\n";
45 my $name = shift or return '';
47 # The name can only begin with a-zA-Z_; if there's anything
49 $name =~ s/^([^a-zA-Z_])/_$1/;
51 # anything other than a-zA-Z0-9_ in the non-first position
52 # needs to be turned into _
53 $name =~ tr/[a-zA-Z0-9_]/_/c;
55 # All duplicated _ need to be squashed into one.
64 sub normalize_quote_options {
68 if (defined $config->{quote_identifiers}) {
69 $quote = $config->{quote_identifiers};
71 for (qw/quote_table_names quote_field_names/) {
72 carp "Ignoring deprecated parameter '$_', since 'quote_identifiers' is supplied"
73 if defined $config->{$_}
76 # Legacy one set the other is not
78 defined $config->{'quote_table_names'}
80 defined $config->{'quote_field_names'}
82 if (defined $config->{'quote_table_names'}) {
83 carp "Explicitly disabling the deprecated 'quote_table_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_field_names'"
84 unless $config->{'quote_table_names'};
85 $quote = $config->{'quote_table_names'} ? 1 : 0;
88 carp "Explicitly disabling the deprecated 'quote_field_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_table_names'"
89 unless $config->{'quote_field_names'};
90 $quote = $config->{'quote_field_names'} ? 1 : 0;
94 elsif(defined $config->{'quote_table_names'}) {
95 croak 'Setting quote_table_names and quote_field_names to conflicting values is no longer supported'
96 if ($config->{'quote_table_names'} xor $config->{'quote_field_names'});
98 $quote = $config->{'quote_table_names'} ? 1 : 0;
105 my $producer = shift || caller;
106 my $comment_char = shift;
107 my $now = scalar localtime;
109 $comment_char = $DEFAULT_COMMENT
110 unless defined $comment_char;
112 my $header_comment =<<"HEADER_COMMENT";
114 ${comment_char}Created by $producer
115 ${comment_char}Created on $now
119 # Any additional stuff passed in
120 for my $additional_comment (@_) {
121 $header_comment .= "${comment_char}${additional_comment}\n";
124 return $header_comment;
128 my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
131 # This protects stringification of references.
133 if ( @$list && ref $list->[0] ) {
137 # This processes string-like arguments.
141 map { s/^\s+|\s+$//g; $_ }
143 grep { defined && length } @$list
148 sub truncate_id_uniquely {
149 my ( $desired_name, $max_symbol_length ) = @_;
152 unless defined $desired_name && length $desired_name > $max_symbol_length;
154 my $truncated_name = substr $desired_name, 0,
155 $max_symbol_length - COLLISION_TAG_LENGTH - 1;
157 # Hex isn't the most space-efficient, but it skirts around allowed
159 my $digest = sha1_hex($desired_name);
160 my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
162 return $truncated_name
168 sub parse_mysql_version {
169 my ($v, $target) = @_;
171 return undef unless $v;
178 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
179 push @vers, $1, $2, $3;
182 # XYYZZ (mysql) style
183 elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
184 push @vers, $1, $2, $3;
187 # XX.YYYZZZ (perl) style or simply X
188 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
189 push @vers, $1, $2, $3;
192 #how do I croak sanely here?
193 die "Unparseable MySQL version '$v'";
196 if ($target eq 'perl') {
197 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
199 elsif ($target eq 'mysql') {
200 return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
203 #how do I croak sanely here?
204 die "Unknown version target '$target'";
208 sub parse_dbms_version {
209 my ($v, $target) = @_;
211 return undef unless $v;
216 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
217 push @vers, $1, $2, $3;
220 # XX.YYYZZZ (perl) style or simply X
221 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
222 push @vers, $1, $2, $3;
225 #how do I croak sanely here?
226 die "Unparseable database server version '$v'";
229 if ($target eq 'perl') {
230 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
232 elsif ($target eq 'native') {
233 return join '.' => grep defined, @vers;
236 #how do I croak sanely here?
237 die "Unknown version target '$target'";
241 #my ($parsers_libdir, $checkout_dir);
242 sub ddl_parser_instance {
246 # it may differ from our caller, even though currently this is not the case
247 eval "require SQL::Translator::Parser::$type"
248 or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@";
250 # handle DB2 in a special way, since the grammar source was lost :(
251 if ($type eq 'DB2') {
252 require SQL::Translator::Parser::DB2::Grammar;
253 return SQL::Translator::Parser::DB2::Grammar->new;
256 require Parse::RecDescent;
257 return Parse::RecDescent->new(do {
259 ${"SQL::Translator::Parser::${type}::GRAMMAR"}
260 || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
263 # this is disabled until RT#74593 is resolved
267 unless ($parsers_libdir) {
269 # are we in a checkout?
270 if ($checkout_dir = _find_co_root()) {
271 $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
274 require File::ShareDir;
275 $parsers_libdir = File::Spec->catdir(
276 File::ShareDir::dist_dir('SQL-Translator'),
281 unshift @INC, $parsers_libdir;
284 my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
287 # Parse::RecDescent has horrible architecture where each precompiled parser
288 # instance shares global state with all its siblings
289 # What we do here is gross, but scarily efficient - the parser compilation
290 # is much much slower than an unload/reload cycle
291 require Class::Unload;
292 Class::Unload->unload($precompiled_mod);
294 # There is also a sub-namespace that P::RD uses, but simply unsetting
295 # $^W to stop redefine warnings seems to be enough
296 #Class::Unload->unload("Parse::RecDescent::$precompiled_mod");
298 eval "local \$^W; require $precompiled_mod" or do {
300 die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
303 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$@"
307 my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
308 my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
311 (stat($grammar_spec_fn))[9]
313 (stat($precompiled_fn))[9]
316 "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
318 ? " - run Makefile.PL to regenerate stale versions\n"
319 : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
324 return $precompiled_mod->new;
332 # Try to determine the root of a checkout/untar if possible
336 my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
337 my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS
339 return undef unless ($INC{$rel_path});
341 # a bit convoluted, but what we do here essentially is:
342 # - get the file name of this particular module
343 # - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..
345 my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
346 for (1 .. @mod_parts) {
347 $root = File::Spec->catdir($root, File::Spec->updir);
350 return ( -f File::Spec->catfile($root, 'Makefile.PL') )
357 package SQL::Translator::Utils::Error;
360 '""' => sub { ${$_[0]} },
364 my ($class, $msg) = @_;
370 die SQL::Translator::Utils::Error->new($_[0]);
374 my ($orig, $self, @args) = @_;
378 die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
386 my ($orig, $self) = (shift, shift);
387 carp "'$name' is a read-only accessor" if @_;
392 sub batch_alter_table_statements {
393 my ($diff_hash, $options, @meths) = @_;
397 alter_drop_constraint
404 alter_create_constraint
408 my $package = caller;
411 my $meth = $package->can($_) or die "$package cant $_";
412 map { $meth->(ref $_ eq 'ARRAY' ? @$_ : $_, $options) } @{ $diff_hash->{$_} }
413 } grep { @{$diff_hash->{$_} || []} }
423 SQL::Translator::Utils - SQL::Translator Utility functions
427 use SQL::Translator::Utils qw(debug);
428 debug("PKG: Bad things happened");
432 C<SQL::Translator::Utils> contains utility functions designed to be
433 used from the other modules within the C<SQL::Translator> modules.
435 Nothing is exported by default.
437 =head1 EXPORTED FUNCTIONS AND CONSTANTS
441 C<debug> takes 0 or more messages, which will be sent to STDERR using
442 C<warn>. Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
443 will be replaced by the calling package, subroutine, and line number,
444 respectively, as reported by C<caller(1)>.
446 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
448 debug("PKG: Error reading file at SUB/LINE");
452 [SQL::Translator: Error reading file at foo/666]
454 The entire message is enclosed within C<[> and C<]> for visual clarity
455 when STDERR is intermixed with STDOUT.
457 =head2 normalize_name
459 C<normalize_name> takes a string and ensures that it is suitable for
460 use as an identifier. This means: ensure that it starts with a letter
461 or underscore, and that the rest of the string consists of only
462 letters, numbers, and underscores. A string that begins with
463 something other than [a-zA-Z] will be prefixer with an underscore, and
464 all other characters in the string will be replaced with underscores.
465 Finally, a trailing underscore will be removed, because that's ugly.
467 normalize_name("Hello, world");
473 A more useful example, from the C<SQL::Translator::Parser::Excel> test
476 normalize_name("silly field (with random characters)");
480 silly_field_with_random_characters
482 =head2 header_comment
484 Create the header comment. Takes 1 mandatory argument (the producer
485 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
486 and 0 or more additional comments, which will be appended to the header,
487 prefixed with the comment character. If additional comments are provided,
488 then a comment string must be provided ($DEFAULT_COMMENT is exported for
489 this use). For example, this:
491 package My::Producer;
493 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
495 print header_comment(__PACKAGE__,
502 -- Created by My::Prodcuer
503 -- Created on Fri Apr 25 06:56:02 2003
508 Note the gratuitous spacing.
510 =head2 parse_list_arg
512 Takes a string, list or arrayref (all of which could contain
513 comma-separated values) and returns an array reference of the values.
514 All of the following will return equivalent values:
516 parse_list_arg('id');
517 parse_list_arg('id', 'name');
518 parse_list_arg( 'id, name' );
519 parse_list_arg( [ 'id', 'name' ] );
520 parse_list_arg( qw[ id name ] );
522 =head2 truncate_id_uniquely
524 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
525 $desired_name to $max_symbol_length by including part of the hash of
526 the full name at the end of the truncated name, giving a high
527 probability that the symbol will be unique. For example,
529 truncate_id_uniquely( 'a' x 100, 64 )
530 truncate_id_uniquely( 'a' x 99 . 'b', 64 );
531 truncate_id_uniquely( 'a' x 99, 64 )
533 Will give three different results; specifically:
535 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
536 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
537 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
539 =head2 $DEFAULT_COMMENT
541 This is the default comment string, '-- ' by default. Useful for
544 =head2 parse_mysql_version
546 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
547 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
548 consistent format for both C<< parser_args->{mysql_parser_version} >> and
549 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
550 version specifications:
556 5.001005 (perl style)
559 =head2 parse_dbms_version
561 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
562 or 'native') transforms the string to the given target style.
567 Throws the provided string as an object that will stringify back to the
568 original string. This stops it from being mangled by L<Moo>'s C<isa>
573 Wraps an attribute accessor to catch any exception raised using
574 L</throw> and store them in C<< $self->error() >>, finally returning
575 undef. A reference to this function can be passed directly to
578 around foo => \&ex2err;
581 my ($orig, $self) = (shift, shift);
582 return ex2err($orig, $self, @_) if @_;
588 Takes a field name and returns a reference to a function can be used
589 L<around|Moo/around> a read-only accessor to make it L<carp|Carp>
590 instead of die when passed an argument.
592 =head2 batch_alter_table_statements
594 Takes diff and argument hashes as passed to
595 L<batch_alter_table|SQL::Translator::Diff/batch_alter_table($table, $hash, $args) (optional)>
596 and an optional list of producer functions to call on the calling package.
597 Returns the list of statements returned by the producer functions.
599 If no producer functions are specified, the following functions in the
600 calling package are called:
604 =item 1. rename_table
606 =item 2. alter_drop_constraint
608 =item 3. alter_drop_index
616 =item 6. rename_field
618 =item 7. alter_create_index
620 =item 8. alter_create_constraint
626 If the corresponding array in the hash has any elements, but the
627 caller doesn't implement that function, an exception is thrown.
631 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
632 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.