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';
  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     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 throw {
 370     die SQL::Translator::Utils::Error->new($_[0]);
 371 }
 372
 373 sub ex2err {
 374     my ($orig, $self, @args) = @_;
 375     return try {
 376         $self->$orig(@args);
 377     } catch {
 378         die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
 379         $self->error("$_");
 380     };
 381 }
 382
 383 sub carp_ro {
 384     my ($name) = @_;
 385     return sub {
 386         my ($orig, $self) = (shift, shift);
 387         carp "'$name' is a read-only accessor" if @_;
 388         return $self->$orig;
 389     };
 390 }
 391
 392 sub batch_alter_table_statements {
 393     my ($diff_hash, $options, @meths) = @_;
 394
 395     @meths = qw(
 396         rename_table
 397         alter_drop_constraint
 398         alter_drop_index
 399         drop_field
 400         add_field
 401         alter_field
 402         rename_field
 403         alter_create_index
 404         alter_create_constraint
 405         alter_table
 406     ) unless @meths;
 407
 408     my $package = caller;
 409
 410     return map {
 411         my $meth = $package->can($_) or die "$package cant $_";
 412         map { $meth->(ref $_ eq 'ARRAY' ? @$_ : $_, $options) } @{ $diff_hash->{$_} }
 413     } grep { @{$diff_hash->{$_} || []} }
 414         @meths;
 415 }
 416
 417 1;
 418
 419 =pod
 420
 421 =head1 NAME
 422
 423 SQL::Translator::Utils - SQL::Translator Utility functions
 424
 425 =head1 SYNOPSIS
 426
 427   use SQL::Translator::Utils qw(debug);
 428   debug("PKG: Bad things happened");
 429
 430 =head1 DESCSIPTION
 431
 432 C<SQL::Translator::Utils> contains utility functions designed to be
 433 used from the other modules within the C<SQL::Translator> modules.
 434
 435 Nothing is exported by default.
 436
 437 =head1 EXPORTED FUNCTIONS AND CONSTANTS
 438
 439 =head2 debug
 440
 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)>.
 445
 446 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
 447
 448   debug("PKG: Error reading file at SUB/LINE");
 449
 450 Will warn
 451
 452   [SQL::Translator: Error reading file at foo/666]
 453
 454 The entire message is enclosed within C<[> and C<]> for visual clarity
 455 when STDERR is intermixed with STDOUT.
 456
 457 =head2 normalize_name
 458
 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.
 466
 467   normalize_name("Hello, world");
 468
 469 Produces:
 470
 471   Hello_world
 472
 473 A more useful example, from the C<SQL::Translator::Parser::Excel> test
 474 suite:
 475
 476   normalize_name("silly field (with random characters)");
 477
 478 returns:
 479
 480   silly_field_with_random_characters
 481
 482 =head2 header_comment
 483
 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:
 490
 491   package My::Producer;
 492
 493   use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
 494
 495   print header_comment(__PACKAGE__,
 496                        $DEFAULT_COMMENT,
 497                        "Hi mom!");
 498
 499 produces:
 500
 501   --
 502   -- Created by My::Prodcuer
 503   -- Created on Fri Apr 25 06:56:02 2003
 504   --
 505   -- Hi mom!
 506   --
 507
 508 Note the gratuitous spacing.
 509
 510 =head2 parse_list_arg
 511
 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:
 515
 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 ] );
 521
 522 =head2 truncate_id_uniquely
 523
 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,
 528
 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 )
 532
 533 Will give three different results; specifically:
 534
 535   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
 536   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
 537   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
 538
 539 =head2 $DEFAULT_COMMENT
 540
 541 This is the default comment string, '-- ' by default.  Useful for
 542 C<header_comment>.
 543
 544 =head2 parse_mysql_version
 545
 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:
 551
 552   5.0.3
 553   4.1
 554   3.23.2
 555   5
 556   5.001005  (perl style)
 557   30201     (mysql style)
 558
 559 =head2 parse_dbms_version
 560
 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.
 563 to
 564
 565 =head2 throw
 566
 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>
 569 code.
 570
 571 =head2 ex2err
 572
 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
 576 L<Moo/around>.
 577
 578     around foo => \&ex2err;
 579
 580     around bar => sub {
 581         my ($orig, $self) = (shift, shift);
 582         return ex2err($orig, $self, @_) if @_;
 583         ...
 584     };
 585
 586 =head2 carp_ro
 587
 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.
 591
 592 =head2 batch_alter_table_statements
 593
 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.
 598
 599 If no producer functions are specified, the following functions in the
 600 calling package are called:
 601
 602 =over
 603
 604 =item 1. rename_table
 605
 606 =item 2. alter_drop_constraint
 607
 608 =item 3. alter_drop_index
 609
 610 =item 4. drop_field
 611
 612 =item 5. add_field
 613
 614 =item 5. alter_field
 615
 616 =item 6. rename_field
 617
 618 =item 7. alter_create_index
 619
 620 =item 8. alter_create_constraint
 621
 622 =item 9. alter_table
 623
 624 =back
 625
 626 If the corresponding array in the hash has any elements, but the
 627 caller doesn't implement that function, an exception is thrown.
 628
 629 =head1 AUTHORS
 630
 631 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 632 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 633
 634 =cut