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
  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 1;
 352
 353 =pod
 354
 355 =head1 NAME
 356
 357 SQL::Translator::Utils - SQL::Translator Utility functions
 358
 359 =head1 SYNOPSIS
 360
 361   use SQL::Translator::Utils qw(debug);
 362   debug("PKG: Bad things happened");
 363
 364 =head1 DESCSIPTION
 365
 366 C<SQL::Translator::Utils> contains utility functions designed to be
 367 used from the other modules within the C<SQL::Translator> modules.
 368
 369 Nothing is exported by default.
 370
 371 =head1 EXPORTED FUNCTIONS AND CONSTANTS
 372
 373 =head2 debug
 374
 375 C<debug> takes 0 or more messages, which will be sent to STDERR using
 376 C<warn>.  Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
 377 will be replaced by the calling package, subroutine, and line number,
 378 respectively, as reported by C<caller(1)>.
 379
 380 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
 381
 382   debug("PKG: Error reading file at SUB/LINE");
 383
 384 Will warn
 385
 386   [SQL::Translator: Error reading file at foo/666]
 387
 388 The entire message is enclosed within C<[> and C<]> for visual clarity
 389 when STDERR is intermixed with STDOUT.
 390
 391 =head2 normalize_name
 392
 393 C<normalize_name> takes a string and ensures that it is suitable for
 394 use as an identifier.  This means: ensure that it starts with a letter
 395 or underscore, and that the rest of the string consists of only
 396 letters, numbers, and underscores.  A string that begins with
 397 something other than [a-zA-Z] will be prefixer with an underscore, and
 398 all other characters in the string will be replaced with underscores.
 399 Finally, a trailing underscore will be removed, because that's ugly.
 400
 401   normalize_name("Hello, world");
 402
 403 Produces:
 404
 405   Hello_world
 406
 407 A more useful example, from the C<SQL::Translator::Parser::Excel> test
 408 suite:
 409
 410   normalize_name("silly field (with random characters)");
 411
 412 returns:
 413
 414   silly_field_with_random_characters
 415
 416 =head2 header_comment
 417
 418 Create the header comment.  Takes 1 mandatory argument (the producer
 419 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
 420 and 0 or more additional comments, which will be appended to the header,
 421 prefixed with the comment character.  If additional comments are provided,
 422 then a comment string must be provided ($DEFAULT_COMMENT is exported for
 423 this use).  For example, this:
 424
 425   package My::Producer;
 426
 427   use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
 428
 429   print header_comment(__PACKAGE__,
 430                        $DEFAULT_COMMENT,
 431                        "Hi mom!");
 432
 433 produces:
 434
 435   --
 436   -- Created by My::Prodcuer
 437   -- Created on Fri Apr 25 06:56:02 2003
 438   --
 439   -- Hi mom!
 440   --
 441
 442 Note the gratuitous spacing.
 443
 444 =head2 parse_list_arg
 445
 446 Takes a string, list or arrayref (all of which could contain
 447 comma-separated values) and returns an array reference of the values.
 448 All of the following will return equivalent values:
 449
 450   parse_list_arg('id');
 451   parse_list_arg('id', 'name');
 452   parse_list_arg( 'id, name' );
 453   parse_list_arg( [ 'id', 'name' ] );
 454   parse_list_arg( qw[ id name ] );
 455
 456 =head2 truncate_id_uniquely
 457
 458 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
 459 $desired_name to $max_symbol_length by including part of the hash of
 460 the full name at the end of the truncated name, giving a high
 461 probability that the symbol will be unique. For example,
 462
 463   truncate_id_uniquely( 'a' x 100, 64 )
 464   truncate_id_uniquely( 'a' x 99 . 'b', 64 );
 465   truncate_id_uniquely( 'a' x 99,  64 )
 466
 467 Will give three different results; specifically:
 468
 469   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
 470   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
 471   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
 472
 473 =head2 $DEFAULT_COMMENT
 474
 475 This is the default comment string, '-- ' by default.  Useful for
 476 C<header_comment>.
 477
 478 =head2 parse_mysql_version
 479
 480 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
 481 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
 482 consistent format for both C<< parser_args->{mysql_parser_version} >> and
 483 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
 484 version specifications:
 485
 486   5.0.3
 487   4.1
 488   3.23.2
 489   5
 490   5.001005  (perl style)
 491   30201     (mysql style)
 492
 493 =head2 parse_dbms_version
 494
 495 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
 496 or 'native') transforms the string to the given target style.
 497 to
 498
 499 =head2 throw
 500
 501 Throws the provided string as an object that will stringify back to the
 502 original string.  This stops it from being mangled by L<Moo>'s C<isa>
 503 code.
 504
 505 =head2 ex2err
 506
 507 Wraps an attribute accessor to catch any exception raised using
 508 L</throw> and store them in C<< $self->error() >>, finally returning
 509 undef.  A reference to this function can be passed directly to
 510 L<Moo/around>.
 511
 512     around foo => \&ex2err;
 513
 514     around bar => sub {
 515         my ($orig, $self) = (shift, shift);
 516         return ex2err($orig, $self, @_) if @_;
 517         ...
 518     };
 519
 520 =head2 carp_ro
 521
 522 Takes a field name and returns a reference to a function can be used
 523 L<around|Moo/around> a read-only accessor to make it L<carp|Carp/carp>
 524 instead of die when passed an argument.
 525
 526 =head1 AUTHORS
 527
 528 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 529 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 530
 531 =cut