lib/SQL/Translator/Utils.pm

   1 package SQL::Translator::Utils;
   2
   3 use strict;
   4 use warnings;
   5 use base qw(Exporter);
   6 use vars qw($VERSION $DEFAULT_COMMENT @EXPORT_OK);
   7 use Digest::SHA1 qw( sha1_hex );
   8 use Exporter;
   9
  10 $VERSION = '1.59';
  11 $DEFAULT_COMMENT = '-- ';
  12 @EXPORT_OK = qw(
  13     debug normalize_name header_comment parse_list_arg truncate_id_uniquely
  14     $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
  15 );
  16 use constant COLLISION_TAG_LENGTH => 8;
  17
  18 sub debug {
  19     my ($pkg, $file, $line, $sub) = caller(0);
  20     {
  21         no strict qw(refs);
  22         return unless ${"$pkg\::DEBUG"};
  23     }
  24
  25     $sub =~ s/^$pkg\:://;
  26
  27     while (@_) {
  28         my $x = shift;
  29         chomp $x;
  30         $x =~ s/\bPKG\b/$pkg/g;
  31         $x =~ s/\bLINE\b/$line/g;
  32         $x =~ s/\bSUB\b/$sub/g;
  33         #warn '[' . $x . "]\n";
  34         print STDERR '[' . $x . "]\n";
  35     }
  36 }
  37
  38 sub normalize_name {
  39     my $name = shift or return '';
  40
  41     # The name can only begin with a-zA-Z_; if there's anything
  42     # else, prefix with _
  43     $name =~ s/^([^a-zA-Z_])/_$1/;
  44
  45     # anything other than a-zA-Z0-9_ in the non-first position
  46     # needs to be turned into _
  47     $name =~ tr/[a-zA-Z0-9_]/_/c;
  48
  49     # All duplicated _ need to be squashed into one.
  50     $name =~ tr/_/_/s;
  51
  52     # Trim a trailing _
  53     $name =~ s/_$//;
  54
  55     return $name;
  56 }
  57
  58 sub header_comment {
  59     my $producer = shift || caller;
  60     my $comment_char = shift;
  61     my $now = scalar localtime;
  62
  63     $comment_char = $DEFAULT_COMMENT
  64         unless defined $comment_char;
  65
  66     my $header_comment =<<"HEADER_COMMENT";
  67 ${comment_char}
  68 ${comment_char}Created by $producer
  69 ${comment_char}Created on $now
  70 ${comment_char}
  71 HEADER_COMMENT
  72
  73     # Any additional stuff passed in
  74     for my $additional_comment (@_) {
  75         $header_comment .= "${comment_char}${additional_comment}\n";
  76     }
  77
  78     return $header_comment;
  79 }
  80
  81 sub parse_list_arg {
  82     my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
  83
  84     #
  85     # This protects stringification of references.
  86     #
  87     if ( @$list && ref $list->[0] ) {
  88         return $list;
  89     }
  90     #
  91     # This processes string-like arguments.
  92     #
  93     else {
  94         return [
  95             map { s/^\s+|\s+$//g; $_ }
  96             map { split /,/ }
  97             grep { defined && length } @$list
  98         ];
  99     }
 100 }
 101
 102 sub truncate_id_uniquely {
 103     my ( $desired_name, $max_symbol_length ) = @_;
 104
 105     return $desired_name
 106       unless defined $desired_name && length $desired_name > $max_symbol_length;
 107
 108     my $truncated_name = substr $desired_name, 0,
 109       $max_symbol_length - COLLISION_TAG_LENGTH - 1;
 110
 111     # Hex isn't the most space-efficient, but it skirts around allowed
 112     # charset issues
 113     my $digest = sha1_hex($desired_name);
 114     my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH;
 115
 116     return $truncated_name
 117          . '_'
 118          . $collision_tag;
 119 }
 120
 121
 122 sub parse_mysql_version {
 123     my ($v, $target) = @_;
 124
 125     return undef unless $v;
 126
 127     $target ||= 'perl';
 128
 129     my @vers;
 130
 131     # X.Y.Z style
 132     if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 133         push @vers, $1, $2, $3;
 134     }
 135
 136     # XYYZZ (mysql) style
 137     elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
 138         push @vers, $1, $2, $3;
 139     }
 140
 141     # XX.YYYZZZ (perl) style or simply X
 142     elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 143         push @vers, $1, $2, $3;
 144     }
 145     else {
 146         #how do I croak sanely here?
 147         die "Unparseable MySQL version '$v'";
 148     }
 149
 150     if ($target eq 'perl') {
 151         return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 152     }
 153     elsif ($target eq 'mysql') {
 154         return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
 155     }
 156     else {
 157         #how do I croak sanely here?
 158         die "Unknown version target '$target'";
 159     }
 160 }
 161
 162 sub parse_dbms_version {
 163     my ($v, $target) = @_;
 164
 165     return undef unless $v;
 166
 167     my @vers;
 168
 169     # X.Y.Z style
 170     if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 171         push @vers, $1, $2, $3;
 172     }
 173
 174     # XX.YYYZZZ (perl) style or simply X
 175     elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 176         push @vers, $1, $2, $3;
 177     }
 178     else {
 179         #how do I croak sanely here?
 180         die "Unparseable database server version '$v'";
 181     }
 182
 183     if ($target eq 'perl') {
 184         return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 185     }
 186     elsif ($target eq 'native') {
 187         return join '.' => grep defined, @vers;
 188     }
 189     else {
 190         #how do I croak sanely here?
 191         die "Unknown version target '$target'";
 192     }
 193 }
 194
 195 1;
 196
 197 =pod
 198
 199 =head1 NAME
 200
 201 SQL::Translator::Utils - SQL::Translator Utility functions
 202
 203 =head1 SYNOPSIS
 204
 205   use SQL::Translator::Utils qw(debug);
 206   debug("PKG: Bad things happened");
 207
 208 =head1 DESCSIPTION
 209
 210 C<SQL::Translator::Utils> contains utility functions designed to be
 211 used from the other modules within the C<SQL::Translator> modules.
 212
 213 Nothing is exported by default.
 214
 215 =head1 EXPORTED FUNCTIONS AND CONSTANTS
 216
 217 =head2 debug
 218
 219 C<debug> takes 0 or more messages, which will be sent to STDERR using
 220 C<warn>.  Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
 221 will be replaced by the calling package, subroutine, and line number,
 222 respectively, as reported by C<caller(1)>.
 223
 224 For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
 225
 226   debug("PKG: Error reading file at SUB/LINE");
 227
 228 Will warn
 229
 230   [SQL::Translator: Error reading file at foo/666]
 231
 232 The entire message is enclosed within C<[> and C<]> for visual clarity
 233 when STDERR is intermixed with STDOUT.
 234
 235 =head2 normalize_name
 236
 237 C<normalize_name> takes a string and ensures that it is suitable for
 238 use as an identifier.  This means: ensure that it starts with a letter
 239 or underscore, and that the rest of the string consists of only
 240 letters, numbers, and underscores.  A string that begins with
 241 something other than [a-zA-Z] will be prefixer with an underscore, and
 242 all other characters in the string will be replaced with underscores.
 243 Finally, a trailing underscore will be removed, because that's ugly.
 244
 245   normalize_name("Hello, world");
 246
 247 Produces:
 248
 249   Hello_world
 250
 251 A more useful example, from the C<SQL::Translator::Parser::Excel> test
 252 suite:
 253
 254   normalize_name("silly field (with random characters)");
 255
 256 returns:
 257
 258   silly_field_with_random_characters
 259
 260 =head2 header_comment
 261
 262 Create the header comment.  Takes 1 mandatory argument (the producer
 263 classname), an optional comment character (defaults to $DEFAULT_COMMENT),
 264 and 0 or more additional comments, which will be appended to the header,
 265 prefixed with the comment character.  If additional comments are provided,
 266 then a comment string must be provided ($DEFAULT_COMMENT is exported for
 267 this use).  For example, this:
 268
 269   package My::Producer;
 270
 271   use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
 272
 273   print header_comment(__PACKAGE__,
 274                        $DEFAULT_COMMENT,
 275                        "Hi mom!");
 276
 277 produces:
 278
 279   --
 280   -- Created by My::Prodcuer
 281   -- Created on Fri Apr 25 06:56:02 2003
 282   --
 283   -- Hi mom!
 284   --
 285
 286 Note the gratuitous spacing.
 287
 288 =head2 parse_list_arg
 289
 290 Takes a string, list or arrayref (all of which could contain
 291 comma-separated values) and returns an array reference of the values.
 292 All of the following will return equivalent values:
 293
 294   parse_list_arg('id');
 295   parse_list_arg('id', 'name');
 296   parse_list_arg( 'id, name' );
 297   parse_list_arg( [ 'id', 'name' ] );
 298   parse_list_arg( qw[ id name ] );
 299
 300 =head2 truncate_id_uniquely
 301
 302 Takes a string ($desired_name) and int ($max_symbol_length). Truncates
 303 $desired_name to $max_symbol_length by including part of the hash of
 304 the full name at the end of the truncated name, giving a high
 305 probability that the symbol will be unique. For example,
 306
 307   truncate_id_uniquely( 'a' x 100, 64 )
 308   truncate_id_uniquely( 'a' x 99 . 'b', 64 );
 309   truncate_id_uniquely( 'a' x 99,  64 )
 310
 311 Will give three different results; specifically:
 312
 313   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025
 314   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a
 315   aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2
 316
 317 =head2 $DEFAULT_COMMENT
 318
 319 This is the default comment string, '-- ' by default.  Useful for
 320 C<header_comment>.
 321
 322 =head2 parse_mysql_version
 323
 324 Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
 325 L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
 326 consistent format for both C<< parser_args->{mysql_parser_version} >> and
 327 C<< producer_args->{mysql_version} >> respectively. Takes any of the following
 328 version specifications:
 329
 330   5.0.3
 331   4.1
 332   3.23.2
 333   5
 334   5.001005  (perl style)
 335   30201     (mysql style)
 336
 337 =head2 parse_dbms_version
 338
 339 Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl'
 340 or 'native') transforms the string to the given target style.
 341 to
 342
 343 =head1 AUTHORS
 344
 345 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 346 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 347
 348 =cut