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 =begin for general sadness
 224
 225     unless ($parsers_libdir) {
 226
 227         # are we in a checkout?
 228         if ($checkout_dir = _find_co_root()) {
 229             $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
 230         }
 231         else {
 232             require File::ShareDir;
 233             $parsers_libdir = File::Spec->catdir(
 234               File::ShareDir::dist_dir('SQL-Translator'),
 235               'PrecompiledParsers'
 236             );
 237         }
 238
 239         unshift @INC, $parsers_libdir;
 240     }
 241
 242     my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
 243
 244     # FIXME FIXME FIXME
 245     # Parse::RecDescent has horrible architecture where each precompiled parser
 246     # instance shares global state with all its siblings
 247     # What we do here is gross, but scarily efficient - the parser compilation
 248     # is much much slower than an unload/reload cycle
 249     require Class::Unload;
 250     Class::Unload->unload($precompiled_mod);
 251
 252     # There is also a sub-namespace that P::RD uses, but simply unsetting
 253     # $^W to stop redefine warnings seems to be enough
 254     #Class::Unload->unload("Parse::RecDescent::$precompiled_mod");
 255
 256     eval "local \$^W; require $precompiled_mod" or do {
 257         if ($checkout_dir) {
 258             die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
 259         }
 260         else {
 261             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$@"
 262         }
 263     };
 264
 265     my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
 266     my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
 267
 268     if (
 269         (stat($grammar_spec_fn))[9]
 270             >
 271         (stat($precompiled_fn))[9]
 272     ) {
 273         die (
 274             "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
 275           . ($checkout_dir
 276                 ? " - run Makefile.PL to regenerate stale versions\n"
 277                 : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
 278             )
 279         );
 280     }
 281
 282     return $precompiled_mod->new;
 283 =cut
 284
 285 }
 286
 287 # Try to determine the root of a checkout/untar if possible
 288 # or return undef
 289 sub _find_co_root {
 290
 291     my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
 292     my $rel_path = join ('/', @mod_parts);  # %INC stores paths with / regardless of OS
 293
 294     return undef unless ($INC{$rel_path});
 295
 296     # a bit convoluted, but what we do here essentially is:
 297     #  - get the file name of this particular module
 298     #  - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..
 299
 300     my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
 301     for (1 .. @mod_parts) {
 302         $root = File::Spec->catdir($root, File::Spec->updir);
 303     }
 304
 305     return ( -f File::Spec->catfile($root, 'Makefile.PL') )
 306         ? $root
 307         : undef
 308     ;
 309 }
 310
 311 {
 312     package SQL::Translator::Utils::Error;
 313
 314     use overload
 315         '""' => sub { ${$_[0]} },
 316         fallback => 1;
 317
 318     sub new {
 319         my ($class, $msg) = @_;
 320         bless \$msg, $class;
 321     }
 322 }
 323
 324 sub throw {
 325     die SQL::Translator::Utils::Error->new($_[0]);
 326 }
 327
 328 sub ex2err {
 329     my ($orig, $self, @args) = @_;
 330     return try {
 331         $self->$orig(@args);
 332     } catch {
 333         die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
 334         $self->error("$_");
 335     };
 336 }
 337
 338 sub carp_ro {
 339     my ($name) = @_;
 340     return sub {
 341         my ($orig, $self) = (shift, shift);
 342         carp "'$name' is a read-only accessor" if @_;
 343         return $self->$orig;
 344     };
 345 }
 346
 347 1;
 348
 349 =pod
 350
 351 =head1 NAME
 352
 353 SQL::Translator::Utils - SQL::Translator Utility functions
 354
 355 =head1 SYNOPSIS
 356
 357   use SQL::Translator::Utils qw(debug);
 358   debug("PKG: Bad things happened");
 359
 360 =head1 DESCSIPTION
 361
 362 C<SQL::Translator::Utils> contains utility functions designed to be
 363 used from the other modules within the C<SQL::Translator> modules.
 364
 365 Nothing is exported by default.
 366
 367 =head1 EXPORTED FUNCTIONS AND CONSTANTS
 368
 369 =head2 debug
 370
 371 C<debug> takes 0 or more messages, which will be sent to STDERR using
 372 C<warn>.  Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
 373 will be replaced by the calling package, subroutine, and line number,
 374 respectively, as reported by C<caller(1)>.
 375
 376 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
 377
 378   debug("PKG: Error reading file at SUB/LINE");
 379
 380 Will warn
 381
 382   [SQL::Translator: Error reading file at foo/666]
 383
 384 The entire message is enclosed within C<[> and C<]> for visual clarity
 385 when STDERR is intermixed with STDOUT.
 386
 387 =head2 normalize_name
 388
 389 C<normalize_name> takes a string and ensures that it is suitable for
 390 use as an identifier.  This means: ensure that it starts with a letter
 391 or underscore, and that the rest of the string consists of only
 392 letters, numbers, and underscores.  A string that begins with
 393 something other than [a-zA-Z] will be prefixer with an underscore, and
 394 all other characters in the string will be replaced with underscores.
 395 Finally, a trailing underscore will be removed, because that's ugly.
 396
 397   normalize_name("Hello, world");
 398
 399 Produces:
 400
 401   Hello_world
 402
 403 A more useful example, from the C<SQL::Translator::Parser::Excel> test
 404 suite:
 405
 406   normalize_name("silly field (with random characters)");
 407
 408 returns:
 409
 410   silly_field_with_random_characters
 411
 412 =head2 header_comment
 413
 414 Create the header comment.  Takes 1 mandatory argument (the producer
 415 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
 416 and 0 or more additional comments, which will be appended to the header,
 417 prefixed with the comment character.  If additional comments are provided,
 418 then a comment string must be provided ($DEFAULT_COMMENT is exported for
 419 this use).  For example, this:
 420
 421   package My::Producer;
 422
 423   use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
 424
 425   print header_comment(__PACKAGE__,
 426                        $DEFAULT_COMMENT,
 427                        "Hi mom!");
 428
 429 produces:
 430
 431   --
 432   -- Created by My::Prodcuer
 433   -- Created on Fri Apr 25 06:56:02 2003
 434   --
 435   -- Hi mom!
 436   --
 437
 438 Note the gratuitous spacing.
 439
 440 =head2 parse_list_arg
 441
 442 Takes a string, list or arrayref (all of which could contain
 443 comma-separated values) and returns an array reference of the values.
 444 All of the following will return equivalent values:
 445
 446   parse_list_arg('id');
 447   parse_list_arg('id', 'name');
 448   parse_list_arg( 'id, name' );
 449   parse_list_arg( [ 'id', 'name' ] );
 450   parse_list_arg( qw[ id name ] );
 451
 452 =head2 truncate_id_uniquely
 453
 454 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
 455 $desired_name to $max_symbol_length by including part of the hash of
 456 the full name at the end of the truncated name, giving a high
 457 probability that the symbol will be unique. For example,
 458
 459   truncate_id_uniquely( 'a' x 100, 64 )
 460   truncate_id_uniquely( 'a' x 99 . 'b', 64 );
 461   truncate_id_uniquely( 'a' x 99,  64 )
 462
 463 Will give three different results; specifically:
 464
 465   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
 466   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
 467   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
 468
 469 =head2 $DEFAULT_COMMENT
 470
 471 This is the default comment string, '-- ' by default.  Useful for
 472 C<header_comment>.
 473
 474 =head2 parse_mysql_version
 475
 476 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
 477 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
 478 consistent format for both C<< parser_args->{mysql_parser_version} >> and
 479 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
 480 version specifications:
 481
 482   5.0.3
 483   4.1
 484   3.23.2
 485   5
 486   5.001005  (perl style)
 487   30201     (mysql style)
 488
 489 =head2 parse_dbms_version
 490
 491 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
 492 or 'native') transforms the string to the given target style.
 493 to
 494
 495 =head2 throw
 496
 497 Throws the provided string as an object that will stringify back to the
 498 original string.  This stops it from being mangled by L<Moo>'s C<isa>
 499 code.
 500
 501 =head2 ex2err
 502
 503 Wraps an attribute accessor to catch any exception raised using
 504 L</throw> and store them in C<< $self->error() >>, finally returning
 505 undef.  A reference to this function can be passed directly to
 506 L<Moo/around>.
 507
 508     around foo => \&ex2err;
 509
 510     around bar => sub {
 511         my ($orig, $self) = (shift, shift);
 512         return ex2err($orig, $self, @_) if @_;
 513         ...
 514     };
 515
 516 =head2 carp_ro
 517
 518 Takes a field name and returns a reference to a function can be used
 519 L<around|Moo/around> a read-only accessor to make it L<carp|Carp/carp>
 520 instead of die when passed an argument.
 521
 522 =head1 AUTHORS
 523
 524 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 525 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 526
 527 =cut