lib/SQL/Translator/Utils.pm

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