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';
13 use base qw(Exporter);
15 debug normalize_name header_comment parse_list_arg truncate_id_uniquely
16 $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
17 ddl_parser_instance batch_alter_table_statements
18 uniq throw ex2err carp_ro
19 normalize_quote_options
21 use constant COLLISION_TAG_LENGTH => 8;
23 our $DEFAULT_COMMENT = '--';
26 my ($pkg, $file, $line, $sub) = caller(0);
29 return unless ${"$pkg\::DEBUG"};
37 $x =~ s/\bPKG\b/$pkg/g;
38 $x =~ s/\bLINE\b/$line/g;
39 $x =~ s/\bSUB\b/$sub/g;
40 #warn '[' . $x . "]\n";
41 print STDERR '[' . $x . "]\n";
46 my $name = shift or return '';
48 # The name can only begin with a-zA-Z_; if there's anything
50 $name =~ s/^([^a-zA-Z_])/_$1/;
52 # anything other than a-zA-Z0-9_ in the non-first position
53 # needs to be turned into _
54 $name =~ tr/[a-zA-Z0-9_]/_/c;
56 # All duplicated _ need to be squashed into one.
65 sub normalize_quote_options {
69 if (defined $config->{quote_identifiers}) {
70 $quote = $config->{quote_identifiers};
72 for (qw/quote_table_names quote_field_names/) {
73 carp "Ignoring deprecated parameter '$_', since 'quote_identifiers' is supplied"
74 if defined $config->{$_}
77 # Legacy one set the other is not
79 defined $config->{'quote_table_names'}
81 defined $config->{'quote_field_names'}
83 if (defined $config->{'quote_table_names'}) {
84 carp "Explicitly disabling the deprecated 'quote_table_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_field_names'"
85 unless $config->{'quote_table_names'};
86 $quote = $config->{'quote_table_names'} ? 1 : 0;
89 carp "Explicitly disabling the deprecated 'quote_field_names' implies disabling 'quote_identifiers' which in turn implies disabling 'quote_table_names'"
90 unless $config->{'quote_field_names'};
91 $quote = $config->{'quote_field_names'} ? 1 : 0;
95 elsif(defined $config->{'quote_table_names'}) {
96 croak 'Setting quote_table_names and quote_field_names to conflicting values is no longer supported'
97 if ($config->{'quote_table_names'} xor $config->{'quote_field_names'});
99 $quote = $config->{'quote_table_names'} ? 1 : 0;
106 my $producer = shift || caller;
107 my $comment_char = shift;
108 my $now = scalar localtime;
110 $comment_char = $DEFAULT_COMMENT
111 unless defined $comment_char;
113 my $header_comment =<<"HEADER_COMMENT";
115 ${comment_char} Created by $producer
116 ${comment_char} Created on $now
120 # Any additional stuff passed in
121 for my $additional_comment (@_) {
122 $header_comment .= "${comment_char} ${additional_comment}\n";
125 return $header_comment;
129 my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
132 # This protects stringification of references.
134 if ( @$list && ref $list->[0] ) {
138 # This processes string-like arguments.
142 map { s/^\s+|\s+$//g; $_ }
144 grep { defined && length } @$list
149 sub truncate_id_uniquely {
150 my ( $desired_name, $max_symbol_length ) = @_;
153 unless defined $desired_name && length $desired_name > $max_symbol_length;
155 my $truncated_name = substr $desired_name, 0,
156 $max_symbol_length - COLLISION_TAG_LENGTH - 1;
158 # Hex isn't the most space-efficient, but it skirts around allowed
160 my $digest = sha1_hex($desired_name);
161 my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
163 return $truncated_name
169 sub parse_mysql_version {
170 my ($v, $target) = @_;
172 return undef unless $v;
179 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
180 push @vers, $1, $2, $3;
183 # XYYZZ (mysql) style
184 elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
185 push @vers, $1, $2, $3;
188 # XX.YYYZZZ (perl) style or simply X
189 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
190 push @vers, $1, $2, $3;
193 #how do I croak sanely here?
194 die "Unparseable MySQL version '$v'";
197 if ($target eq 'perl') {
198 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
200 elsif ($target eq 'mysql') {
201 return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
204 #how do I croak sanely here?
205 die "Unknown version target '$target'";
209 sub parse_dbms_version {
210 my ($v, $target) = @_;
212 return undef unless $v;
217 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
218 push @vers, $1, $2, $3;
221 # XX.YYYZZZ (perl) style or simply X
222 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
223 push @vers, $1, $2, $3;
226 #how do I croak sanely here?
227 die "Unparseable database server version '$v'";
230 if ($target eq 'perl') {
231 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
233 elsif ($target eq 'native') {
234 return join '.' => grep defined, @vers;
237 #how do I croak sanely here?
238 die "Unknown version target '$target'";
242 #my ($parsers_libdir, $checkout_dir);
243 sub ddl_parser_instance {
247 # it may differ from our caller, even though currently this is not the case
248 eval "require SQL::Translator::Parser::$type"
249 or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@";
251 # handle DB2 in a special way, since the grammar source was lost :(
252 if ($type eq 'DB2') {
253 require SQL::Translator::Parser::DB2::Grammar;
254 return SQL::Translator::Parser::DB2::Grammar->new;
257 require Parse::RecDescent;
258 return Parse::RecDescent->new(do {
260 ${"SQL::Translator::Parser::${type}::GRAMMAR"}
261 || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
264 # this is disabled until RT#74593 is resolved
268 unless ($parsers_libdir) {
270 # are we in a checkout?
271 if ($checkout_dir = _find_co_root()) {
272 $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
275 require File::ShareDir;
276 $parsers_libdir = File::Spec->catdir(
277 File::ShareDir::dist_dir('SQL-Translator'),
282 unshift @INC, $parsers_libdir;
285 my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
288 # Parse::RecDescent has horrible architecture where each precompiled parser
289 # instance shares global state with all its siblings
290 # What we do here is gross, but scarily efficient - the parser compilation
291 # is much much slower than an unload/reload cycle
292 require Class::Unload;
293 Class::Unload->unload($precompiled_mod);
295 # There is also a sub-namespace that P::RD uses, but simply unsetting
296 # $^W to stop redefine warnings seems to be enough
297 #Class::Unload->unload("Parse::RecDescent::$precompiled_mod");
299 eval "local \$^W; require $precompiled_mod" or do {
301 die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
304 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$@"
308 my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
309 my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
312 (stat($grammar_spec_fn))[9]
314 (stat($precompiled_fn))[9]
317 "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
319 ? " - run Makefile.PL to regenerate stale versions\n"
320 : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
325 return $precompiled_mod->new;
333 # Try to determine the root of a checkout/untar if possible
337 my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
338 my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS
340 return undef unless ($INC{$rel_path});
342 # a bit convoluted, but what we do here essentially is:
343 # - get the file name of this particular module
344 # - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..
346 my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
347 for (1 .. @mod_parts) {
348 $root = File::Spec->catdir($root, File::Spec->updir);
351 return ( -f File::Spec->catfile($root, 'Makefile.PL') )
358 package SQL::Translator::Utils::Error;
361 '""' => sub { ${$_[0]} },
365 my ($class, $msg) = @_;
371 my( %seen, $seen_undef, $numeric_preserving_copy );
374 ? $seen{ $numeric_preserving_copy = $_ }++
380 die SQL::Translator::Utils::Error->new($_[0]);
384 my ($orig, $self, @args) = @_;
388 die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
396 my ($orig, $self) = (shift, shift);
397 carp "'$name' is a read-only accessor" if @_;
402 sub batch_alter_table_statements {
403 my ($diff_hash, $options, @meths) = @_;
407 alter_drop_constraint
414 alter_create_constraint
418 my $package = caller;
421 my $meth = $package->can($_) or die "$package cant $_";
422 map { $meth->(ref $_ eq 'ARRAY' ? @$_ : $_, $options) } @{ $diff_hash->{$_} }
423 } grep { @{$diff_hash->{$_} || []} }
433 SQL::Translator::Utils - SQL::Translator Utility functions
437 use SQL::Translator::Utils qw(debug);
438 debug("PKG: Bad things happened");
442 C<SQL::Translator::Utils> contains utility functions designed to be
443 used from the other modules within the C<SQL::Translator> modules.
445 Nothing is exported by default.
447 =head1 EXPORTED FUNCTIONS AND CONSTANTS
451 C<debug> takes 0 or more messages, which will be sent to STDERR using
452 C<warn>. Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
453 will be replaced by the calling package, subroutine, and line number,
454 respectively, as reported by C<caller(1)>.
456 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
458 debug("PKG: Error reading file at SUB/LINE");
462 [SQL::Translator: Error reading file at foo/666]
464 The entire message is enclosed within C<[> and C<]> for visual clarity
465 when STDERR is intermixed with STDOUT.
467 =head2 normalize_name
469 C<normalize_name> takes a string and ensures that it is suitable for
470 use as an identifier. This means: ensure that it starts with a letter
471 or underscore, and that the rest of the string consists of only
472 letters, numbers, and underscores. A string that begins with
473 something other than [a-zA-Z] will be prefixer with an underscore, and
474 all other characters in the string will be replaced with underscores.
475 Finally, a trailing underscore will be removed, because that's ugly.
477 normalize_name("Hello, world");
483 A more useful example, from the C<SQL::Translator::Parser::Excel> test
486 normalize_name("silly field (with random characters)");
490 silly_field_with_random_characters
492 =head2 header_comment
494 Create the header comment. Takes 1 mandatory argument (the producer
495 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
496 and 0 or more additional comments, which will be appended to the header,
497 prefixed with the comment character. If additional comments are provided,
498 then a comment string must be provided ($DEFAULT_COMMENT is exported for
499 this use). For example, this:
501 package My::Producer;
503 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
505 print header_comment(__PACKAGE__,
512 -- Created by My::Prodcuer
513 -- Created on Fri Apr 25 06:56:02 2003
518 Note the gratuitous spacing.
520 =head2 parse_list_arg
522 Takes a string, list or arrayref (all of which could contain
523 comma-separated values) and returns an array reference of the values.
524 All of the following will return equivalent values:
526 parse_list_arg('id');
527 parse_list_arg('id', 'name');
528 parse_list_arg( 'id, name' );
529 parse_list_arg( [ 'id', 'name' ] );
530 parse_list_arg( qw[ id name ] );
532 =head2 truncate_id_uniquely
534 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
535 $desired_name to $max_symbol_length by including part of the hash of
536 the full name at the end of the truncated name, giving a high
537 probability that the symbol will be unique. For example,
539 truncate_id_uniquely( 'a' x 100, 64 )
540 truncate_id_uniquely( 'a' x 99 . 'b', 64 );
541 truncate_id_uniquely( 'a' x 99, 64 )
543 Will give three different results; specifically:
545 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
546 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
547 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
549 =head2 $DEFAULT_COMMENT
551 This is the default comment string, '--' by default. Useful for
554 =head2 parse_mysql_version
556 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
557 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
558 consistent format for both C<< parser_args->{mysql_parser_version} >> and
559 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
560 version specifications:
566 5.001005 (perl style)
569 =head2 parse_dbms_version
571 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
572 or 'native') transforms the string to the given target style.
577 Throws the provided string as an object that will stringify back to the
578 original string. This stops it from being mangled by L<Moo>'s C<isa>
583 Wraps an attribute accessor to catch any exception raised using
584 L</throw> and store them in C<< $self->error() >>, finally returning
585 undef. A reference to this function can be passed directly to
588 around foo => \&ex2err;
591 my ($orig, $self) = (shift, shift);
592 return ex2err($orig, $self, @_) if @_;
598 Takes a field name and returns a reference to a function can be used
599 L<around|Moo/around> a read-only accessor to make it L<carp|Carp>
600 instead of die when passed an argument.
602 =head2 batch_alter_table_statements
604 Takes diff and argument hashes as passed to
605 L<batch_alter_table|SQL::Translator::Diff/batch_alter_table($table, $hash, $args) (optional)>
606 and an optional list of producer functions to call on the calling package.
607 Returns the list of statements returned by the producer functions.
609 If no producer functions are specified, the following functions in the
610 calling package are called:
614 =item 1. rename_table
616 =item 2. alter_drop_constraint
618 =item 3. alter_drop_index
626 =item 6. rename_field
628 =item 7. alter_create_index
630 =item 8. alter_create_constraint
636 If the corresponding array in the hash has any elements, but the
637 caller doesn't implement that function, an exception is thrown.
641 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
642 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.