1 package SQL::Translator::Utils;
5 use Digest::SHA qw( sha1_hex );
7 use Scalar::Util qw(blessed);
10 our $VERSION = '1.59';
11 our $DEFAULT_COMMENT = '-- ';
13 use base qw(Exporter);
15 debug normalize_name header_comment parse_list_arg truncate_id_uniquely
16 $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
20 use constant COLLISION_TAG_LENGTH => 8;
23 my ($pkg, $file, $line, $sub) = caller(0);
26 return unless ${"$pkg\::DEBUG"};
34 $x =~ s/\bPKG\b/$pkg/g;
35 $x =~ s/\bLINE\b/$line/g;
36 $x =~ s/\bSUB\b/$sub/g;
37 #warn '[' . $x . "]\n";
38 print STDERR '[' . $x . "]\n";
43 my $name = shift or return '';
45 # The name can only begin with a-zA-Z_; if there's anything
47 $name =~ s/^([^a-zA-Z_])/_$1/;
49 # anything other than a-zA-Z0-9_ in the non-first position
50 # needs to be turned into _
51 $name =~ tr/[a-zA-Z0-9_]/_/c;
53 # All duplicated _ need to be squashed into one.
63 my $producer = shift || caller;
64 my $comment_char = shift;
65 my $now = scalar localtime;
67 $comment_char = $DEFAULT_COMMENT
68 unless defined $comment_char;
70 my $header_comment =<<"HEADER_COMMENT";
72 ${comment_char}Created by $producer
73 ${comment_char}Created on $now
77 # Any additional stuff passed in
78 for my $additional_comment (@_) {
79 $header_comment .= "${comment_char}${additional_comment}\n";
82 return $header_comment;
86 my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
89 # This protects stringification of references.
91 if ( @$list && ref $list->[0] ) {
95 # This processes string-like arguments.
99 map { s/^\s+|\s+$//g; $_ }
101 grep { defined && length } @$list
106 sub truncate_id_uniquely {
107 my ( $desired_name, $max_symbol_length ) = @_;
110 unless defined $desired_name && length $desired_name > $max_symbol_length;
112 my $truncated_name = substr $desired_name, 0,
113 $max_symbol_length - COLLISION_TAG_LENGTH - 1;
115 # Hex isn't the most space-efficient, but it skirts around allowed
117 my $digest = sha1_hex($desired_name);
118 my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
120 return $truncated_name
126 sub parse_mysql_version {
127 my ($v, $target) = @_;
129 return undef unless $v;
136 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
137 push @vers, $1, $2, $3;
140 # XYYZZ (mysql) style
141 elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
142 push @vers, $1, $2, $3;
145 # XX.YYYZZZ (perl) style or simply X
146 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
147 push @vers, $1, $2, $3;
150 #how do I croak sanely here?
151 die "Unparseable MySQL version '$v'";
154 if ($target eq 'perl') {
155 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
157 elsif ($target eq 'mysql') {
158 return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
161 #how do I croak sanely here?
162 die "Unknown version target '$target'";
166 sub parse_dbms_version {
167 my ($v, $target) = @_;
169 return undef unless $v;
174 if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
175 push @vers, $1, $2, $3;
178 # XX.YYYZZZ (perl) style or simply X
179 elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
180 push @vers, $1, $2, $3;
183 #how do I croak sanely here?
184 die "Unparseable database server version '$v'";
187 if ($target eq 'perl') {
188 return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
190 elsif ($target eq 'native') {
191 return join '.' => grep defined, @vers;
194 #how do I croak sanely here?
195 die "Unknown version target '$target'";
199 #my ($parsers_libdir, $checkout_dir);
200 sub ddl_parser_instance {
204 # it may differ from our caller, even though currently this is not the case
205 eval "require SQL::Translator::Parser::$type"
206 or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@";
208 # handle DB2 in a special way, since the grammar source was lost :(
209 if ($type eq 'DB2') {
210 require SQL::Translator::Parser::DB2::Grammar;
211 return SQL::Translator::Parser::DB2::Grammar->new;
214 require Parse::RecDescent;
215 return Parse::RecDescent->new(do {
217 ${"SQL::Translator::Parser::${type}::GRAMMAR"}
218 || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n"
221 # this is disabled until RT#74593 is resolved
222 =begin for general sadness
224 unless ($parsers_libdir) {
226 # are we in a checkout?
227 if ($checkout_dir = _find_co_root()) {
228 $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
231 require File::ShareDir;
232 $parsers_libdir = File::Spec->catdir(
233 File::ShareDir::dist_dir('SQL-Translator'),
238 unshift @INC, $parsers_libdir;
241 my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
244 # Parse::RecDescent has horrible architecture where each precompiled parser
245 # instance shares global state with all its siblings
246 # What we do here is gross, but scarily efficient - the parser compilation
247 # is much much slower than an unload/reload cycle
248 require Class::Unload;
249 Class::Unload->unload($precompiled_mod);
251 # There is also a sub-namespace that P::RD uses, but simply unsetting
252 # $^W to stop redefine warnings seems to be enough
253 #Class::Unload->unload("Parse::RecDescent::$precompiled_mod");
255 eval "local \$^W; require $precompiled_mod" or do {
257 die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
260 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$@"
264 my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
265 my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
268 (stat($grammar_spec_fn))[9]
270 (stat($precompiled_fn))[9]
273 "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
275 ? " - run Makefile.PL to regenerate stale versions\n"
276 : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n"
281 return $precompiled_mod->new;
286 # Try to determine the root of a checkout/untar if possible
290 my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
291 my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS
293 return undef unless ($INC{$rel_path});
295 # a bit convoluted, but what we do here essentially is:
296 # - get the file name of this particular module
297 # - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../..
299 my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1];
300 for (1 .. @mod_parts) {
301 $root = File::Spec->catdir($root, File::Spec->updir);
304 return ( -f File::Spec->catfile($root, 'Makefile.PL') )
311 package SQL::Translator::Utils::Error;
314 '""' => sub { ${$_[0]} },
318 my ($class, $msg) = @_;
324 die SQL::Translator::Utils::Error->new($_[0]);
328 my ($orig, $self, @args) = @_;
332 die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
343 SQL::Translator::Utils - SQL::Translator Utility functions
347 use SQL::Translator::Utils qw(debug);
348 debug("PKG: Bad things happened");
352 C<SQL::Translator::Utils> contains utility functions designed to be
353 used from the other modules within the C<SQL::Translator> modules.
355 Nothing is exported by default.
357 =head1 EXPORTED FUNCTIONS AND CONSTANTS
361 C<debug> takes 0 or more messages, which will be sent to STDERR using
362 C<warn>. Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
363 will be replaced by the calling package, subroutine, and line number,
364 respectively, as reported by C<caller(1)>.
366 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
368 debug("PKG: Error reading file at SUB/LINE");
372 [SQL::Translator: Error reading file at foo/666]
374 The entire message is enclosed within C<[> and C<]> for visual clarity
375 when STDERR is intermixed with STDOUT.
377 =head2 normalize_name
379 C<normalize_name> takes a string and ensures that it is suitable for
380 use as an identifier. This means: ensure that it starts with a letter
381 or underscore, and that the rest of the string consists of only
382 letters, numbers, and underscores. A string that begins with
383 something other than [a-zA-Z] will be prefixer with an underscore, and
384 all other characters in the string will be replaced with underscores.
385 Finally, a trailing underscore will be removed, because that's ugly.
387 normalize_name("Hello, world");
393 A more useful example, from the C<SQL::Translator::Parser::Excel> test
396 normalize_name("silly field (with random characters)");
400 silly_field_with_random_characters
402 =head2 header_comment
404 Create the header comment. Takes 1 mandatory argument (the producer
405 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
406 and 0 or more additional comments, which will be appended to the header,
407 prefixed with the comment character. If additional comments are provided,
408 then a comment string must be provided ($DEFAULT_COMMENT is exported for
409 this use). For example, this:
411 package My::Producer;
413 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
415 print header_comment(__PACKAGE__,
422 -- Created by My::Prodcuer
423 -- Created on Fri Apr 25 06:56:02 2003
428 Note the gratuitous spacing.
430 =head2 parse_list_arg
432 Takes a string, list or arrayref (all of which could contain
433 comma-separated values) and returns an array reference of the values.
434 All of the following will return equivalent values:
436 parse_list_arg('id');
437 parse_list_arg('id', 'name');
438 parse_list_arg( 'id, name' );
439 parse_list_arg( [ 'id', 'name' ] );
440 parse_list_arg( qw[ id name ] );
442 =head2 truncate_id_uniquely
444 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
445 $desired_name to $max_symbol_length by including part of the hash of
446 the full name at the end of the truncated name, giving a high
447 probability that the symbol will be unique. For example,
449 truncate_id_uniquely( 'a' x 100, 64 )
450 truncate_id_uniquely( 'a' x 99 . 'b', 64 );
451 truncate_id_uniquely( 'a' x 99, 64 )
453 Will give three different results; specifically:
455 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
456 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
457 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
459 =head2 $DEFAULT_COMMENT
461 This is the default comment string, '-- ' by default. Useful for
464 =head2 parse_mysql_version
466 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
467 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
468 consistent format for both C<< parser_args->{mysql_parser_version} >> and
469 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
470 version specifications:
476 5.001005 (perl style)
479 =head2 parse_dbms_version
481 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
482 or 'native') transforms the string to the given target style.
487 Throws the provided string as an object that will stringify back to the
488 original string. This stops it from being mangled by L<Moo>'s C<isa>
493 Wraps an attribute accessor to catch any exception raised using
494 L</throw> and store them in C<< $self->error() >>, finally returning
495 undef. A reference to this function can be passed directly to
498 around foo => \&ex2err;
501 my ($orig, $self) = (shift, shift);
502 return ex2err($orig, $self, @_) if @_;
508 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
509 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.