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