lib/SQL/Translator/Utils.pm

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