lib/SQL/Translator/Utils.pm

   1 package SQL::Translator::Utils;
   2
   3 use strict;
   4 use warnings;
   5 use Digest::SHA qw( sha1_hex );
   6 use File::Spec;
   7 use Scalar::Util qw(blessed);
   8 use Try::Tiny;
   9 use Carp qw(carp croak);
  10
  11 our $VERSION = '1.62';
  12
  13 use base qw(Exporter);
  14 our @EXPORT_OK = qw(
  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
  20 );
  21 use constant COLLISION_TAG_LENGTH => 8;
  22
  23 our $DEFAULT_COMMENT = '--';
  24
  25 sub debug {
  26     my ($pkg, $file, $line, $sub) = caller(0);
  27     {
  28         no strict qw(refs);
  29         return unless ${"$pkg\::DEBUG"};
  30     }
  31
  32     $sub =~ s/^$pkg\:://;
  33
  34     while (@_) {
  35         my $x = shift;
  36         chomp $x;
  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";
  42     }
  43 }
  44
  45 sub normalize_name {
  46     my $name = shift or return '';
  47
  48     # The name can only begin with a-zA-Z_; if there's anything
  49     # else, prefix with _
  50     $name =~ s/^([^a-zA-Z_])/_$1/;
  51
  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;
  55
  56     # All duplicated _ need to be squashed into one.
  57     $name =~ tr/_/_/s;
  58
  59     # Trim a trailing _
  60     $name =~ s/_$//;
  61
  62     return $name;
  63 }
  64
  65 sub normalize_quote_options {
  66     my $config = shift;
  67
  68     my $quote;
  69     if (defined $config->{quote_identifiers}) {
  70       $quote = $config->{quote_identifiers};
  71
  72       for (qw/quote_table_names quote_field_names/) {
  73         carp "Ignoring deprecated parameter '$_', since 'quote_identifiers' is supplied"
  74           if defined $config->{$_}
  75       }
  76     }
  77     # Legacy one set the other is not
  78     elsif (
  79       defined $config->{'quote_table_names'}
  80         xor
  81       defined $config->{'quote_field_names'}
  82     ) {
  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;
  87       }
  88       else {
  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;
  92       }
  93     }
  94     # Legacy both are set
  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'});
  98
  99       $quote = $config->{'quote_table_names'} ? 1 : 0;
 100     }
 101
 102     return $quote;
 103 }
 104
 105 sub header_comment {
 106     my $producer = shift || caller;
 107     my $comment_char = shift;
 108     my $now = scalar localtime;
 109
 110     $comment_char = $DEFAULT_COMMENT
 111         unless defined $comment_char;
 112
 113     my $header_comment =<<"HEADER_COMMENT";
 114 ${comment_char}
 115 ${comment_char} Created by $producer
 116 ${comment_char} Created on $now
 117 ${comment_char}
 118 HEADER_COMMENT
 119
 120     # Any additional stuff passed in
 121     for my $additional_comment (@_) {
 122         $header_comment .= "${comment_char} ${additional_comment}\n";
 123     }
 124
 125     return $header_comment;
 126 }
 127
 128 sub parse_list_arg {
 129     my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
 130
 131     #
 132     # This protects stringification of references.
 133     #
 134     if ( @$list && ref $list->[0] ) {
 135         return $list;
 136     }
 137     #
 138     # This processes string-like arguments.
 139     #
 140     else {
 141         return [
 142             map { s/^\s+|\s+$//g; $_ }
 143             map { split /,/ }
 144             grep { defined && length } @$list
 145         ];
 146     }
 147 }
 148
 149 sub truncate_id_uniquely {
 150     my ( $desired_name, $max_symbol_length ) = @_;
 151
 152     return $desired_name
 153       unless defined $desired_name && length $desired_name > $max_symbol_length;
 154
 155     my $truncated_name = substr $desired_name, 0,
 156       $max_symbol_length - COLLISION_TAG_LENGTH - 1;
 157
 158     # Hex isn't the most space-efficient, but it skirts around allowed
 159     # charset issues
 160     my $digest = sha1_hex($desired_name);
 161     my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
 162
 163     return $truncated_name
 164          . '_'
 165          . $collision_tag;
 166 }
 167
 168
 169 sub parse_mysql_version {
 170     my ($v, $target) = @_;
 171
 172     return undef unless $v;
 173
 174     $target ||= 'perl';
 175
 176     my @vers;
 177
 178     # X.Y.Z style
 179     if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 180         push @vers, $1, $2, $3;
 181     }
 182
 183     # XYYZZ (mysql) style
 184     elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
 185         push @vers, $1, $2, $3;
 186     }
 187
 188     # XX.YYYZZZ (perl) style or simply X
 189     elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 190         push @vers, $1, $2, $3;
 191     }
 192     else {
 193         #how do I croak sanely here?
 194         die "Unparseable MySQL version '$v'";
 195     }
 196
 197     if ($target eq 'perl') {
 198         return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 199     }
 200     elsif ($target eq 'mysql') {
 201         return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
 202     }
 203     else {
 204         #how do I croak sanely here?
 205         die "Unknown version target '$target'";
 206     }
 207 }
 208
 209 sub parse_dbms_version {
 210     my ($v, $target) = @_;
 211
 212     return undef unless $v;
 213
 214     my @vers;
 215
 216     # X.Y.Z style
 217     if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 218         push @vers, $1, $2, $3;
 219     }
 220
 221     # XX.YYYZZZ (perl) style or simply X
 222     elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 223         push @vers, $1, $2, $3;
 224     }
 225     else {
 226         #how do I croak sanely here?
 227         die "Unparseable database server version '$v'";
 228     }
 229
 230     if ($target eq 'perl') {
 231         return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 232     }
 233     elsif ($target eq 'native') {
 234         return join '.' => grep defined, @vers;
 235     }
 236     else {
 237         #how do I croak sanely here?
 238         die "Unknown version target '$target'";
 239     }
 240 }
 241
 242 #my ($parsers_libdir, $checkout_dir);
 243 sub ddl_parser_instance {
 244
 245     my $type = shift;
 246
 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$@";
 250
 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;
 255     }
 256
 257     require Parse::RecDescent;
 258     return Parse::RecDescent->new(do {
 259       no strict 'refs';
 260       ${"SQL::Translator::Parser::${type}::GRAMMAR"}
 261         || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
 262     });
 263
 264 # this is disabled until RT#74593 is resolved
 265
 266 =begin sadness
 267
 268     unless ($parsers_libdir) {
 269
 270         # are we in a checkout?
 271         if ($checkout_dir = _find_co_root()) {
 272             $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
 273         }
 274         else {
 275             require File::ShareDir;
 276             $parsers_libdir = File::Spec->catdir(
 277               File::ShareDir::dist_dir('SQL-Translator'),
 278               'PrecompiledParsers'
 279             );
 280         }
 281
 282         unshift @INC, $parsers_libdir;
 283     }
 284
 285     my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
 286
 287     # FIXME FIXME FIXME
 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);
 294
 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");
 298
 299     eval "local \$^W; require $precompiled_mod" or do {
 300         if ($checkout_dir) {
 301             die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
 302         }
 303         else {
 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$@"
 305         }
 306     };
 307
 308     my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
 309     my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
 310
 311     if (
 312         (stat($grammar_spec_fn))[9]
 313             >
 314         (stat($precompiled_fn))[9]
 315     ) {
 316         die (
 317             "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
 318           . ($checkout_dir
 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"
 321             )
 322         );
 323     }
 324
 325     return $precompiled_mod->new;
 326
 327 =end sadness
 328
 329 =cut
 330
 331 }
 332
 333 # Try to determine the root of a checkout/untar if possible
 334 # or return undef
 335 sub _find_co_root {
 336
 337     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 338     my $rel_path = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 339
 340     return undef unless ($INC{$rel_path});
 341
 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/../../..
 345
 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);
 349     }
 350
 351     return ( -f File::Spec->catfile($root, 'Makefile.PL') )
 352         ? $root
 353         : undef
 354     ;
 355 }
 356
 357 {
 358     package SQL::Translator::Utils::Error;
 359
 360     use overload
 361         '""' => sub { ${$_[0]} },
 362         fallback => 1;
 363
 364     sub new {
 365         my ($class, $msg) = @_;
 366         bless \$msg, $class;
 367     }
 368 }
 369
 370 sub uniq {
 371   my( %seen, $seen_undef, $numeric_preserving_copy );
 372   grep { not (
 373     defined $_
 374       ? $seen{ $numeric_preserving_copy = $_ }++
 375       : $seen_undef++
 376   ) } @_;
 377 }
 378
 379 sub throw {
 380     die SQL::Translator::Utils::Error->new($_[0]);
 381 }
 382
 383 sub ex2err {
 384     my ($orig, $self, @args) = @_;
 385     return try {
 386         $self->$orig(@args);
 387     } catch {
 388         die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
 389         $self->error("$_");
 390     };
 391 }
 392
 393 sub carp_ro {
 394     my ($name) = @_;
 395     return sub {
 396         my ($orig, $self) = (shift, shift);
 397         carp "'$name' is a read-only accessor" if @_;
 398         return $self->$orig;
 399     };
 400 }
 401
 402 sub batch_alter_table_statements {
 403     my ($diff_hash, $options, @meths) = @_;
 404
 405     @meths = qw(
 406         rename_table
 407         alter_drop_constraint
 408         alter_drop_index
 409         drop_field
 410         add_field
 411         alter_field
 412         rename_field
 413         alter_create_index
 414         alter_create_constraint
 415         alter_table
 416     ) unless @meths;
 417
 418     my $package = caller;
 419
 420     return map {
 421         my $meth = $package->can($_) or die "$package cant $_";
 422         map { $meth->(ref $_ eq 'ARRAY' ? @$_ : $_, $options) } @{ $diff_hash->{$_} }
 423     } grep { @{$diff_hash->{$_} || []} }
 424         @meths;
 425 }
 426
 427 1;
 428
 429 =pod
 430
 431 =head1 NAME
 432
 433 SQL::Translator::Utils - SQL::Translator Utility functions
 434
 435 =head1 SYNOPSIS
 436
 437   use SQL::Translator::Utils qw(debug);
 438   debug("PKG: Bad things happened");
 439
 440 =head1 DESCSIPTION
 441
 442 C<SQL::Translator::Utils> contains utility functions designed to be
 443 used from the other modules within the C<SQL::Translator> modules.
 444
 445 Nothing is exported by default.
 446
 447 =head1 EXPORTED FUNCTIONS AND CONSTANTS
 448
 449 =head2 debug
 450
 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)>.
 455
 456 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
 457
 458   debug("PKG: Error reading file at SUB/LINE");
 459
 460 Will warn
 461
 462   [SQL::Translator: Error reading file at foo/666]
 463
 464 The entire message is enclosed within C<[> and C<]> for visual clarity
 465 when STDERR is intermixed with STDOUT.
 466
 467 =head2 normalize_name
 468
 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.
 476
 477   normalize_name("Hello, world");
 478
 479 Produces:
 480
 481   Hello_world
 482
 483 A more useful example, from the C<SQL::Translator::Parser::Excel> test
 484 suite:
 485
 486   normalize_name("silly field (with random characters)");
 487
 488 returns:
 489
 490   silly_field_with_random_characters
 491
 492 =head2 header_comment
 493
 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:
 500
 501   package My::Producer;
 502
 503   use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
 504
 505   print header_comment(__PACKAGE__,
 506                        $DEFAULT_COMMENT,
 507                        "Hi mom!");
 508
 509 produces:
 510
 511   --
 512   -- Created by My::Prodcuer
 513   -- Created on Fri Apr 25 06:56:02 2003
 514   --
 515   -- Hi mom!
 516   --
 517
 518 Note the gratuitous spacing.
 519
 520 =head2 parse_list_arg
 521
 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:
 525
 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 ] );
 531
 532 =head2 truncate_id_uniquely
 533
 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,
 538
 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 )
 542
 543 Will give three different results; specifically:
 544
 545   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
 546   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
 547   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
 548
 549 =head2 $DEFAULT_COMMENT
 550
 551 This is the default comment string, '--' by default.  Useful for
 552 C<header_comment>.
 553
 554 =head2 parse_mysql_version
 555
 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:
 561
 562   5.0.3
 563   4.1
 564   3.23.2
 565   5
 566   5.001005  (perl style)
 567   30201     (mysql style)
 568
 569 =head2 parse_dbms_version
 570
 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.
 573 to
 574
 575 =head2 throw
 576
 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>
 579 code.
 580
 581 =head2 ex2err
 582
 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
 586 L<Moo/around>.
 587
 588     around foo => \&ex2err;
 589
 590     around bar => sub {
 591         my ($orig, $self) = (shift, shift);
 592         return ex2err($orig, $self, @_) if @_;
 593         ...
 594     };
 595
 596 =head2 carp_ro
 597
 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.
 601
 602 =head2 batch_alter_table_statements
 603
 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.
 608
 609 If no producer functions are specified, the following functions in the
 610 calling package are called:
 611
 612 =over
 613
 614 =item 1. rename_table
 615
 616 =item 2. alter_drop_constraint
 617
 618 =item 3. alter_drop_index
 619
 620 =item 4. drop_field
 621
 622 =item 5. add_field
 623
 624 =item 5. alter_field
 625
 626 =item 6. rename_field
 627
 628 =item 7. alter_create_index
 629
 630 =item 8. alter_create_constraint
 631
 632 =item 9. alter_table
 633
 634 =back
 635
 636 If the corresponding array in the hash has any elements, but the
 637 caller doesn't implement that function, an exception is thrown.
 638
 639 =head1 AUTHORS
 640
 641 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 642 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 643
 644 =cut