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.60';
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
19 uniq throw ex2err carp_ro
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 my( %seen, $seen_undef, $numeric_preserving_copy );
373 ? $seen{ $numeric_preserving_copy = $_ }++
379 die SQL::Translator::Utils::Error->new($_[0]);
383 my ($orig, $self, @args) = @_;
387 die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
395 my ($orig, $self) = (shift, shift);
396 carp "'$name' is a read-only accessor" if @_;
401 sub batch_alter_table_statements {
402 my ($diff_hash, $options, @meths) = @_;
406 alter_drop_constraint
413 alter_create_constraint
417 my $package = caller;
420 my $meth = $package->can($_) or die "$package cant $_";
421 map { $meth->(ref $_ eq 'ARRAY' ? @$_ : $_, $options) } @{ $diff_hash->{$_} }
422 } grep { @{$diff_hash->{$_} || []} }
432 SQL::Translator::Utils - SQL::Translator Utility functions
436 use SQL::Translator::Utils qw(debug);
437 debug("PKG: Bad things happened");
441 C<SQL::Translator::Utils> contains utility functions designed to be
442 used from the other modules within the C<SQL::Translator> modules.
444 Nothing is exported by default.
446 =head1 EXPORTED FUNCTIONS AND CONSTANTS
450 C<debug> takes 0 or more messages, which will be sent to STDERR using
451 C<warn>. Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
452 will be replaced by the calling package, subroutine, and line number,
453 respectively, as reported by C<caller(1)>.
455 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
457 debug("PKG: Error reading file at SUB/LINE");
461 [SQL::Translator: Error reading file at foo/666]
463 The entire message is enclosed within C<[> and C<]> for visual clarity
464 when STDERR is intermixed with STDOUT.
466 =head2 normalize_name
468 C<normalize_name> takes a string and ensures that it is suitable for
469 use as an identifier. This means: ensure that it starts with a letter
470 or underscore, and that the rest of the string consists of only
471 letters, numbers, and underscores. A string that begins with
472 something other than [a-zA-Z] will be prefixer with an underscore, and
473 all other characters in the string will be replaced with underscores.
474 Finally, a trailing underscore will be removed, because that's ugly.
476 normalize_name("Hello, world");
482 A more useful example, from the C<SQL::Translator::Parser::Excel> test
485 normalize_name("silly field (with random characters)");
489 silly_field_with_random_characters
491 =head2 header_comment
493 Create the header comment. Takes 1 mandatory argument (the producer
494 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
495 and 0 or more additional comments, which will be appended to the header,
496 prefixed with the comment character. If additional comments are provided,
497 then a comment string must be provided ($DEFAULT_COMMENT is exported for
498 this use). For example, this:
500 package My::Producer;
502 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
504 print header_comment(__PACKAGE__,
511 -- Created by My::Prodcuer
512 -- Created on Fri Apr 25 06:56:02 2003
517 Note the gratuitous spacing.
519 =head2 parse_list_arg
521 Takes a string, list or arrayref (all of which could contain
522 comma-separated values) and returns an array reference of the values.
523 All of the following will return equivalent values:
525 parse_list_arg('id');
526 parse_list_arg('id', 'name');
527 parse_list_arg( 'id, name' );
528 parse_list_arg( [ 'id', 'name' ] );
529 parse_list_arg( qw[ id name ] );
531 =head2 truncate_id_uniquely
533 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
534 $desired_name to $max_symbol_length by including part of the hash of
535 the full name at the end of the truncated name, giving a high
536 probability that the symbol will be unique. For example,
538 truncate_id_uniquely( 'a' x 100, 64 )
539 truncate_id_uniquely( 'a' x 99 . 'b', 64 );
540 truncate_id_uniquely( 'a' x 99, 64 )
542 Will give three different results; specifically:
544 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
545 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
546 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
548 =head2 $DEFAULT_COMMENT
550 This is the default comment string, '--' by default. Useful for
553 =head2 parse_mysql_version
555 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
556 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
557 consistent format for both C<< parser_args->{mysql_parser_version} >> and
558 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
559 version specifications:
565 5.001005 (perl style)
568 =head2 parse_dbms_version
570 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
571 or 'native') transforms the string to the given target style.
576 Throws the provided string as an object that will stringify back to the
577 original string. This stops it from being mangled by L<Moo>'s C<isa>
582 Wraps an attribute accessor to catch any exception raised using
583 L</throw> and store them in C<< $self->error() >>, finally returning
584 undef. A reference to this function can be passed directly to
587 around foo => \&ex2err;
590 my ($orig, $self) = (shift, shift);
591 return ex2err($orig, $self, @_) if @_;
597 Takes a field name and returns a reference to a function can be used
598 L<around|Moo/around> a read-only accessor to make it L<carp|Carp>
599 instead of die when passed an argument.
601 =head2 batch_alter_table_statements
603 Takes diff and argument hashes as passed to
604 L<batch_alter_table|SQL::Translator::Diff/batch_alter_table($table, $hash, $args) (optional)>
605 and an optional list of producer functions to call on the calling package.
606 Returns the list of statements returned by the producer functions.
608 If no producer functions are specified, the following functions in the
609 calling package are called:
613 =item 1. rename_table
615 =item 2. alter_drop_constraint
617 =item 3. alter_drop_index
625 =item 6. rename_field
627 =item 7. alter_create_index
629 =item 8. alter_create_constraint
635 If the corresponding array in the hash has any elements, but the
636 caller doesn't implement that function, an exception is thrown.
640 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
641 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.