1 package SQL::Translator::Utils;
5 use Digest::SHA qw( sha1_hex );
7 use Scalar::Util qw(blessed);
11 our $VERSION = '1.59';
12 our $DEFAULT_COMMENT = '-- ';
14 use base qw(Exporter);
16 debug normalize_name header_comment parse_list_arg truncate_id_uniquely
17 $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
21 use constant COLLISION_TAG_LENGTH => 8;
24 my ($pkg, $file, $line, $sub) = caller(0);
27 return unless ${"$pkg\::DEBUG"};
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";
44 my $name = shift or return '';
46 # The name can only begin with a-zA-Z_; if there's anything
48 $name =~ s/^([^a-zA-Z_])/_$1/;
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;
54 # All duplicated _ need to be squashed into one.
64 my $producer = shift || caller;
65 my $comment_char = shift;
66 my $now = scalar localtime;
68 $comment_char = $DEFAULT_COMMENT
69 unless defined $comment_char;
71 my $header_comment =<<"HEADER_COMMENT";
73 ${comment_char}Created by $producer
74 ${comment_char}Created on $now
78 # Any additional stuff passed in
79 for my $additional_comment (@_) {
80 $header_comment .= "${comment_char}${additional_comment}\n";
83 return $header_comment;
87 my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
90 # This protects stringification of references.
92 if ( @$list && ref $list->[0] ) {
96 # This processes string-like arguments.
100 map { s/^\s+|\s+$//g; $_ }
102 grep { defined && length } @$list
107 sub truncate_id_uniquely {
108 my ( $desired_name, $max_symbol_length ) = @_;
111 unless defined $desired_name && length $desired_name > $max_symbol_length;
113 my $truncated_name = substr $desired_name, 0,
114 $max_symbol_length - COLLISION_TAG_LENGTH - 1;
116 # Hex isn't the most space-efficient, but it skirts around allowed
118 my $digest = sha1_hex($desired_name);
119 my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
121 return $truncated_name
127 sub parse_mysql_version {
128 my ($v, $target) = @_;
130 return undef unless $v;
137 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
138 push @vers, $1, $2, $3;
141 # XYYZZ (mysql) style
142 elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
143 push @vers, $1, $2, $3;
146 # XX.YYYZZZ (perl) style or simply X
147 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
148 push @vers, $1, $2, $3;
151 #how do I croak sanely here?
152 die "Unparseable MySQL version '$v'";
155 if ($target eq 'perl') {
156 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
158 elsif ($target eq 'mysql') {
159 return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
162 #how do I croak sanely here?
163 die "Unknown version target '$target'";
167 sub parse_dbms_version {
168 my ($v, $target) = @_;
170 return undef unless $v;
175 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
176 push @vers, $1, $2, $3;
179 # XX.YYYZZZ (perl) style or simply X
180 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
181 push @vers, $1, $2, $3;
184 #how do I croak sanely here?
185 die "Unparseable database server version '$v'";
188 if ($target eq 'perl') {
189 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
191 elsif ($target eq 'native') {
192 return join '.' => grep defined, @vers;
195 #how do I croak sanely here?
196 die "Unknown version target '$target'";
200 #my ($parsers_libdir, $checkout_dir);
201 sub ddl_parser_instance {
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$@";
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;
215 require Parse::RecDescent;
216 return Parse::RecDescent->new(do {
218 ${"SQL::Translator::Parser::${type}::GRAMMAR"}
219 || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
222 # this is disabled until RT#74593 is resolved
226 unless ($parsers_libdir) {
228 # are we in a checkout?
229 if ($checkout_dir = _find_co_root()) {
230 $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
233 require File::ShareDir;
234 $parsers_libdir = File::Spec->catdir(
235 File::ShareDir::dist_dir('SQL-Translator'),
240 unshift @INC, $parsers_libdir;
243 my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
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);
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");
257 eval "local \$^W; require $precompiled_mod" or do {
259 die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
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$@"
266 my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
267 my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
270 (stat($grammar_spec_fn))[9]
272 (stat($precompiled_fn))[9]
275 "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
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"
283 return $precompiled_mod->new;
291 # Try to determine the root of a checkout/untar if possible
295 my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
296 my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS
298 return undef unless ($INC{$rel_path});
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/../../..
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);
309 return ( -f File::Spec->catfile($root, 'Makefile.PL') )
316 package SQL::Translator::Utils::Error;
319 '""' => sub { ${$_[0]} },
323 my ($class, $msg) = @_;
329 die SQL::Translator::Utils::Error->new($_[0]);
333 my ($orig, $self, @args) = @_;
337 die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
345 my ($orig, $self) = (shift, shift);
346 carp "'$name' is a read-only accessor" if @_;
357 SQL::Translator::Utils - SQL::Translator Utility functions
361 use SQL::Translator::Utils qw(debug);
362 debug("PKG: Bad things happened");
366 C<SQL::Translator::Utils> contains utility functions designed to be
367 used from the other modules within the C<SQL::Translator> modules.
369 Nothing is exported by default.
371 =head1 EXPORTED FUNCTIONS AND CONSTANTS
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)>.
380 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
382 debug("PKG: Error reading file at SUB/LINE");
386 [SQL::Translator: Error reading file at foo/666]
388 The entire message is enclosed within C<[> and C<]> for visual clarity
389 when STDERR is intermixed with STDOUT.
391 =head2 normalize_name
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.
401 normalize_name("Hello, world");
407 A more useful example, from the C<SQL::Translator::Parser::Excel> test
410 normalize_name("silly field (with random characters)");
414 silly_field_with_random_characters
416 =head2 header_comment
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:
425 package My::Producer;
427 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
429 print header_comment(__PACKAGE__,
436 -- Created by My::Prodcuer
437 -- Created on Fri Apr 25 06:56:02 2003
442 Note the gratuitous spacing.
444 =head2 parse_list_arg
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:
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 ] );
456 =head2 truncate_id_uniquely
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,
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 )
467 Will give three different results; specifically:
469 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
470 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
471 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
473 =head2 $DEFAULT_COMMENT
475 This is the default comment string, '-- ' by default. Useful for
478 =head2 parse_mysql_version
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:
490 5.001005 (perl style)
493 =head2 parse_dbms_version
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.
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>
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
512 around foo => \&ex2err;
515 my ($orig, $self) = (shift, shift);
516 return ex2err($orig, $self, @_) if @_;
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.
528 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
529 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.