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
223 =begin for general sadness
225 unless ($parsers_libdir) {
227 # are we in a checkout?
228 if ($checkout_dir = _find_co_root()) {
229 $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers');
232 require File::ShareDir;
233 $parsers_libdir = File::Spec->catdir(
234 File::ShareDir::dist_dir('SQL-Translator'),
239 unshift @INC, $parsers_libdir;
242 my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type";
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);
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");
256 eval "local \$^W; require $precompiled_mod" or do {
258 die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n";
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$@"
265 my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"};
266 my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"};
269 (stat($grammar_spec_fn))[9]
271 (stat($precompiled_fn))[9]
274 "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'"
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"
282 return $precompiled_mod->new;
287 # Try to determine the root of a checkout/untar if possible
291 my @mod_parts = split /::/, (__PACKAGE__ . '.pm');
292 my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS
294 return undef unless ($INC{$rel_path});
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/../../..
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);
305 return ( -f File::Spec->catfile($root, 'Makefile.PL') )
312 package SQL::Translator::Utils::Error;
315 '""' => sub { ${$_[0]} },
319 my ($class, $msg) = @_;
325 die SQL::Translator::Utils::Error->new($_[0]);
329 my ($orig, $self, @args) = @_;
333 die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error");
341 my ($orig, $self) = (shift, shift);
342 carp "'$name' is a read-only accessor" if @_;
353 SQL::Translator::Utils - SQL::Translator Utility functions
357 use SQL::Translator::Utils qw(debug);
358 debug("PKG: Bad things happened");
362 C<SQL::Translator::Utils> contains utility functions designed to be
363 used from the other modules within the C<SQL::Translator> modules.
365 Nothing is exported by default.
367 =head1 EXPORTED FUNCTIONS AND CONSTANTS
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)>.
376 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
378 debug("PKG: Error reading file at SUB/LINE");
382 [SQL::Translator: Error reading file at foo/666]
384 The entire message is enclosed within C<[> and C<]> for visual clarity
385 when STDERR is intermixed with STDOUT.
387 =head2 normalize_name
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.
397 normalize_name("Hello, world");
403 A more useful example, from the C<SQL::Translator::Parser::Excel> test
406 normalize_name("silly field (with random characters)");
410 silly_field_with_random_characters
412 =head2 header_comment
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:
421 package My::Producer;
423 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
425 print header_comment(__PACKAGE__,
432 -- Created by My::Prodcuer
433 -- Created on Fri Apr 25 06:56:02 2003
438 Note the gratuitous spacing.
440 =head2 parse_list_arg
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:
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 ] );
452 =head2 truncate_id_uniquely
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,
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 )
463 Will give three different results; specifically:
465 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
466 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
467 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
469 =head2 $DEFAULT_COMMENT
471 This is the default comment string, '-- ' by default. Useful for
474 =head2 parse_mysql_version
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:
486 5.001005 (perl style)
489 =head2 parse_dbms_version
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.
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>
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
508 around foo => \&ex2err;
511 my ($orig, $self) = (shift, shift);
512 return ex2err($orig, $self, @_) if @_;
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.
524 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
525 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.