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);
  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 );
  21 use constant COLLISION_TAG_LENGTH => 8;
  22
  23 sub debug {
  24     my ($pkg, $file, $line, $sub) = caller(0);
  25     {
  26         no strict qw(refs);
  27         return unless ${"$pkg\::DEBUG"};
  28     }
  29
  30     $sub =~ s/^$pkg\:://;
  31
  32     while (@_) {
  33         my $x = shift;
  34         chomp $x;
  35         $x =~ s/\bPKG\b/$pkg/g;
  36         $x =~ s/\bLINE\b/$line/g;
  37         $x =~ s/\bSUB\b/$sub/g;
  38         #warn '[' . $x . "]\n";
  39         print STDERR '[' . $x . "]\n";
  40     }
  41 }
  42
  43 sub normalize_name {
  44     my $name = shift or return '';
  45
  46     # The name can only begin with a-zA-Z_; if there's anything
  47     # else, prefix with _
  48     $name =~ s/^([^a-zA-Z_])/_$1/;
  49
  50     # anything other than a-zA-Z0-9_ in the non-first position
  51     # needs to be turned into _
  52     $name =~ tr/[a-zA-Z0-9_]/_/c;
  53
  54     # All duplicated _ need to be squashed into one.
  55     $name =~ tr/_/_/s;
  56
  57     # Trim a trailing _
  58     $name =~ s/_$//;
  59
  60     return $name;
  61 }
  62
  63 sub header_comment {
  64     my $producer = shift || caller;
  65     my $comment_char = shift;
  66     my $now = scalar localtime;
  67
  68     $comment_char = $DEFAULT_COMMENT
  69         unless defined $comment_char;
  70
  71     my $header_comment =<<"HEADER_COMMENT";
  72 ${comment_char}
  73 ${comment_char}Created by $producer
  74 ${comment_char}Created on $now
  75 ${comment_char}
  76 HEADER_COMMENT
  77
  78     # Any additional stuff passed in
  79     for my $additional_comment (@_) {
  80         $header_comment .= "${comment_char}${additional_comment}\n";
  81     }
  82
  83     return $header_comment;
  84 }
  85
  86 sub parse_list_arg {
  87     my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
  88
  89     #
  90     # This protects stringification of references.
  91     #
  92     if ( @$list && ref $list->[0] ) {
  93         return $list;
  94     }
  95     #
  96     # This processes string-like arguments.
  97     #
  98     else {
  99         return [
 100             map { s/^\s+|\s+$//g; $_ }
 101             map { split /,/ }
 102             grep { defined && length } @$list
 103         ];
 104     }
 105 }
 106
 107 sub truncate_id_uniquely {
 108     my ( $desired_name, $max_symbol_length ) = @_;
 109
 110     return $desired_name
 111       unless defined $desired_name && length $desired_name > $max_symbol_length;
 112
 113     my $truncated_name = substr $desired_name, 0,
 114       $max_symbol_length - COLLISION_TAG_LENGTH - 1;
 115
 116     # Hex isn't the most space-efficient, but it skirts around allowed
 117     # charset issues
 118     my $digest = sha1_hex($desired_name);
 119     my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
 120
 121     return $truncated_name
 122          . '_'
 123          . $collision_tag;
 124 }
 125
 126
 127 sub parse_mysql_version {
 128     my ($v, $target) = @_;
 129
 130     return undef unless $v;
 131
 132     $target ||= 'perl';
 133
 134     my @vers;
 135
 136     # X.Y.Z style
 137     if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 138         push @vers, $1, $2, $3;
 139     }
 140
 141     # XYYZZ (mysql) style
 142     elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
 143         push @vers, $1, $2, $3;
 144     }
 145
 146     # XX.YYYZZZ (perl) style or simply X
 147     elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 148         push @vers, $1, $2, $3;
 149     }
 150     else {
 151         #how do I croak sanely here?
 152         die "Unparseable MySQL version '$v'";
 153     }
 154
 155     if ($target eq 'perl') {
 156         return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 157     }
 158     elsif ($target eq 'mysql') {
 159         return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
 160     }
 161     else {
 162         #how do I croak sanely here?
 163         die "Unknown version target '$target'";
 164     }
 165 }
 166
 167 sub parse_dbms_version {
 168     my ($v, $target) = @_;
 169
 170     return undef unless $v;
 171
 172     my @vers;
 173
 174     # X.Y.Z style
 175     if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 176         push @vers, $1, $2, $3;
 177     }
 178
 179     # XX.YYYZZZ (perl) style or simply X
 180     elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 181         push @vers, $1, $2, $3;
 182     }
 183     else {
 184         #how do I croak sanely here?
 185         die "Unparseable database server version '$v'";
 186     }
 187
 188     if ($target eq 'perl') {
 189         return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 190     }
 191     elsif ($target eq 'native') {
 192         return join '.' => grep defined, @vers;
 193     }
 194     else {
 195         #how do I croak sanely here?
 196         die "Unknown version target '$target'";
 197     }
 198 }
 199
 200 #my ($parsers_libdir, $checkout_dir);
 201 sub ddl_parser_instance {
 202
 203     my $type = shift;
 204
 205     # it may differ from our caller, even though currently this is not the case
 206     eval "require SQL::Translator::Parser::$type"
 207         or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@";
 208
 209     # handle DB2 in a special way, since the grammar source was lost :(
 210     if ($type eq 'DB2') {
 211       require SQL::Translator::Parser::DB2::Grammar;
 212       return SQL::Translator::Parser::DB2::Grammar->new;
 213     }
 214
 215     require Parse::RecDescent;
 216     return Parse::RecDescent->new(do {
 217       no strict 'refs';
 218       ${"SQL::Translator::Parser::${type}::GRAMMAR"}
 219         || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
 220     });
 221
 222 # this is disabled until RT#74593 is resolved
 223
 224 =begin sadness
 225
 226     unless ($parsers_libdir) {
 227
 228         # are we in a checkout?
 229         if ($checkout_dir = _find_co_root()) {
 230             $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
 231         }
 232         else {
 233             require File::ShareDir;
 234             $parsers_libdir = File::Spec->catdir(
 235               File::ShareDir::dist_dir('SQL-Translator'),
 236               'PrecompiledParsers'
 237             );
 238         }
 239
 240         unshift @INC, $parsers_libdir;
 241     }
 242
 243     my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
 244
 245     # FIXME FIXME FIXME
 246     # Parse::RecDescent has horrible architecture where each precompiled parser
 247     # instance shares global state with all its siblings
 248     # What we do here is gross, but scarily efficient - the parser compilation
 249     # is much much slower than an unload/reload cycle
 250     require Class::Unload;
 251     Class::Unload->unload($precompiled_mod);
 252
 253     # There is also a sub-namespace that P::RD uses, but simply unsetting
 254     # $^W to stop redefine warnings seems to be enough
 255     #Class::Unload->unload("Parse::RecDescent::$precompiled_mod");
 256
 257     eval "local \$^W; require $precompiled_mod" or do {
 258         if ($checkout_dir) {
 259             die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
 260         }
 261         else {
 262             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$@"
 263         }
 264     };
 265
 266     my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
 267     my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
 268
 269     if (
 270         (stat($grammar_spec_fn))[9]
 271             >
 272         (stat($precompiled_fn))[9]
 273     ) {
 274         die (
 275             "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
 276           . ($checkout_dir
 277                 ? " - run Makefile.PL to regenerate stale versions\n"
 278                 : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
 279             )
 280         );
 281     }
 282
 283     return $precompiled_mod->new;
 284
 285 =end sadness
 286
 287 =cut
 288
 289 }
 290
 291 # Try to determine the root of a checkout/untar if possible
 292 # or return undef
 293 sub _find_co_root {
 294
 295     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 296     my $rel_path = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 297
 298     return undef unless ($INC{$rel_path});
 299
 300     # a bit convoluted, but what we do here essentially is:
 301     #  - get the file name of this particular module
 302     #  - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..
 303
 304     my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
 305     for (1 .. @mod_parts) {
 306         $root = File::Spec->catdir($root, File::Spec->updir);
 307     }
 308
 309     return ( -f File::Spec->catfile($root, 'Makefile.PL') )
 310         ? $root
 311         : undef
 312     ;
 313 }
 314
 315 {
 316     package SQL::Translator::Utils::Error;
 317
 318     use overload
 319         '""' => sub { ${$_[0]} },
 320         fallback => 1;
 321
 322     sub new {
 323         my ($class, $msg) = @_;
 324         bless \$msg, $class;
 325     }
 326 }
 327
 328 sub throw {
 329     die SQL::Translator::Utils::Error->new($_[0]);
 330 }
 331
 332 sub ex2err {
 333     my ($orig, $self, @args) = @_;
 334     return try {
 335         $self->$orig(@args);
 336     } catch {
 337         die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
 338         $self->error("$_");
 339     };
 340 }
 341
 342 sub carp_ro {
 343     my ($name) = @_;
 344     return sub {
 345         my ($orig, $self) = (shift, shift);
 346         carp "'$name' is a read-only accessor" if @_;
 347         return $self->$orig;
 348     };
 349 }
 350
 351 sub batch_alter_table_statements {
 352     my ($diff_hash, $options, @meths) = @_;
 353
 354     @meths = qw(
 355         rename_table
 356         alter_drop_constraint
 357         alter_drop_index
 358         drop_field
 359         add_field
 360         alter_field
 361         rename_field
 362         alter_create_index
 363         alter_create_constraint
 364         alter_table
 365     ) unless @meths;
 366
 367     my $package = caller;
 368
 369     return map {
 370         my $meth = $package->can($_) or die "$package cant $_";
 371         map { $meth->(ref $_ eq 'ARRAY' ? @$_ : $_, $options) } @{ $diff_hash->{$_} }
 372     } grep { @{$diff_hash->{$_} || []} }
 373         @meths;
 374 }
 375
 376 1;
 377
 378 =pod
 379
 380 =head1 NAME
 381
 382 SQL::Translator::Utils - SQL::Translator Utility functions
 383
 384 =head1 SYNOPSIS
 385
 386   use SQL::Translator::Utils qw(debug);
 387   debug("PKG: Bad things happened");
 388
 389 =head1 DESCSIPTION
 390
 391 C<SQL::Translator::Utils> contains utility functions designed to be
 392 used from the other modules within the C<SQL::Translator> modules.
 393
 394 Nothing is exported by default.
 395
 396 =head1 EXPORTED FUNCTIONS AND CONSTANTS
 397
 398 =head2 debug
 399
 400 C<debug> takes 0 or more messages, which will be sent to STDERR using
 401 C<warn>.  Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
 402 will be replaced by the calling package, subroutine, and line number,
 403 respectively, as reported by C<caller(1)>.
 404
 405 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
 406
 407   debug("PKG: Error reading file at SUB/LINE");
 408
 409 Will warn
 410
 411   [SQL::Translator: Error reading file at foo/666]
 412
 413 The entire message is enclosed within C<[> and C<]> for visual clarity
 414 when STDERR is intermixed with STDOUT.
 415
 416 =head2 normalize_name
 417
 418 C<normalize_name> takes a string and ensures that it is suitable for
 419 use as an identifier.  This means: ensure that it starts with a letter
 420 or underscore, and that the rest of the string consists of only
 421 letters, numbers, and underscores.  A string that begins with
 422 something other than [a-zA-Z] will be prefixer with an underscore, and
 423 all other characters in the string will be replaced with underscores.
 424 Finally, a trailing underscore will be removed, because that's ugly.
 425
 426   normalize_name("Hello, world");
 427
 428 Produces:
 429
 430   Hello_world
 431
 432 A more useful example, from the C<SQL::Translator::Parser::Excel> test
 433 suite:
 434
 435   normalize_name("silly field (with random characters)");
 436
 437 returns:
 438
 439   silly_field_with_random_characters
 440
 441 =head2 header_comment
 442
 443 Create the header comment.  Takes 1 mandatory argument (the producer
 444 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
 445 and 0 or more additional comments, which will be appended to the header,
 446 prefixed with the comment character.  If additional comments are provided,
 447 then a comment string must be provided ($DEFAULT_COMMENT is exported for
 448 this use).  For example, this:
 449
 450   package My::Producer;
 451
 452   use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
 453
 454   print header_comment(__PACKAGE__,
 455                        $DEFAULT_COMMENT,
 456                        "Hi mom!");
 457
 458 produces:
 459
 460   --
 461   -- Created by My::Prodcuer
 462   -- Created on Fri Apr 25 06:56:02 2003
 463   --
 464   -- Hi mom!
 465   --
 466
 467 Note the gratuitous spacing.
 468
 469 =head2 parse_list_arg
 470
 471 Takes a string, list or arrayref (all of which could contain
 472 comma-separated values) and returns an array reference of the values.
 473 All of the following will return equivalent values:
 474
 475   parse_list_arg('id');
 476   parse_list_arg('id', 'name');
 477   parse_list_arg( 'id, name' );
 478   parse_list_arg( [ 'id', 'name' ] );
 479   parse_list_arg( qw[ id name ] );
 480
 481 =head2 truncate_id_uniquely
 482
 483 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
 484 $desired_name to $max_symbol_length by including part of the hash of
 485 the full name at the end of the truncated name, giving a high
 486 probability that the symbol will be unique. For example,
 487
 488   truncate_id_uniquely( 'a' x 100, 64 )
 489   truncate_id_uniquely( 'a' x 99 . 'b', 64 );
 490   truncate_id_uniquely( 'a' x 99,  64 )
 491
 492 Will give three different results; specifically:
 493
 494   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
 495   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
 496   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
 497
 498 =head2 $DEFAULT_COMMENT
 499
 500 This is the default comment string, '-- ' by default.  Useful for
 501 C<header_comment>.
 502
 503 =head2 parse_mysql_version
 504
 505 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
 506 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
 507 consistent format for both C<< parser_args->{mysql_parser_version} >> and
 508 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
 509 version specifications:
 510
 511   5.0.3
 512   4.1
 513   3.23.2
 514   5
 515   5.001005  (perl style)
 516   30201     (mysql style)
 517
 518 =head2 parse_dbms_version
 519
 520 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
 521 or 'native') transforms the string to the given target style.
 522 to
 523
 524 =head2 throw
 525
 526 Throws the provided string as an object that will stringify back to the
 527 original string.  This stops it from being mangled by L<Moo>'s C<isa>
 528 code.
 529
 530 =head2 ex2err
 531
 532 Wraps an attribute accessor to catch any exception raised using
 533 L</throw> and store them in C<< $self->error() >>, finally returning
 534 undef.  A reference to this function can be passed directly to
 535 L<Moo/around>.
 536
 537     around foo => \&ex2err;
 538
 539     around bar => sub {
 540         my ($orig, $self) = (shift, shift);
 541         return ex2err($orig, $self, @_) if @_;
 542         ...
 543     };
 544
 545 =head2 carp_ro
 546
 547 Takes a field name and returns a reference to a function can be used
 548 L<around|Moo/around> a read-only accessor to make it L<carp|Carp/carp>
 549 instead of die when passed an argument.
 550
 551 =head2 batch_alter_table_statements
 552
 553 Takes diff and argument hashes as passed to
 554 L<batch_alter_table|SQL::Translator::Diff/batch_alter_table($table, $hash) (optional)>
 555 and an optional list of producer functions to call on the calling package.
 556 Returns the list of statements returned by the producer functions.
 557
 558 If no producer functions are specified, the following functions in the
 559 calling package are called:
 560
 561 =over
 562
 563 =item 1. rename_table
 564
 565 =item 2. alter_drop_constraint
 566
 567 =item 3. alter_drop_index
 568
 569 =item 4. drop_field
 570
 571 =item 5. add_field
 572
 573 =item 5. alter_field
 574
 575 =item 6. rename_field
 576
 577 =item 7. alter_create_index
 578
 579 =item 8. alter_create_constraint
 580
 581 =item 9. alter_table
 582
 583 =back
 584
 585 If the corresponding array in the hash has any elements, but the
 586 caller doesn't implement that function, an exception is thrown.
 587
 588 =head1 AUTHORS
 589
 590 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 591 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 592
 593 =cut