X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FUtils.pm;h=3d5e57278f771fa26f97b46dd4fd0e84cc5450df;hb=e83ad71c8681208b81dacee01240c2b78752b83e;hp=1832a5d358ae073d85ad657cf176e5f3b62ee773;hpb=1a24938d1a2b06fe79ad196d8d60e248fc04570f;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Utils.pm b/lib/SQL/Translator/Utils.pm index 1832a5d..3d5e572 100644 --- a/lib/SQL/Translator/Utils.pm +++ b/lib/SQL/Translator/Utils.pm @@ -1,9 +1,7 @@ package SQL::Translator::Utils; # ---------------------------------------------------------------------- -# $Id: Utils.pm,v 1.1 2003-03-12 14:17:11 dlc Exp $ -# ---------------------------------------------------------------------- -# Copyright (C) 2003 darren chamberlain +# Copyright (C) 2002-2009 SQLFairy Authors # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License as @@ -22,12 +20,17 @@ package SQL::Translator::Utils; use strict; use base qw(Exporter); -use vars qw($VERSION @EXPORT_OK); - +use vars qw($VERSION $DEFAULT_COMMENT @EXPORT_OK); +use Digest::SHA1 qw( sha1_hex ); use Exporter; -$VERSION = 1.00; -@EXPORT_OK = ('debug'); +$VERSION = '1.59'; +$DEFAULT_COMMENT = '-- '; +@EXPORT_OK = qw( + debug normalize_name header_comment parse_list_arg truncate_id_uniquely + $DEFAULT_COMMENT parse_mysql_version parse_dbms_version +); +use constant COLLISION_TAG_LENGTH => 8; # ---------------------------------------------------------------------- # debug(@msg) @@ -48,7 +51,7 @@ $VERSION = 1.00; # If called from Translator.pm, on line 643. # ---------------------------------------------------------------------- sub debug { - my ($pkg, $file, $line, $sub) = caller(1); + my ($pkg, $file, $line, $sub) = caller(0); { no strict qw(refs); return unless ${"$pkg\::DEBUG"}; @@ -67,9 +70,200 @@ sub debug { } } +# ---------------------------------------------------------------------- +sub normalize_name { + my $name = shift or return ''; + + # The name can only begin with a-zA-Z_; if there's anything + # else, prefix with _ + $name =~ s/^([^a-zA-Z_])/_$1/; + + # anything other than a-zA-Z0-9_ in the non-first position + # needs to be turned into _ + $name =~ tr/[a-zA-Z0-9_]/_/c; + + # All duplicated _ need to be squashed into one. + $name =~ tr/_/_/s; + + # Trim a trailing _ + $name =~ s/_$//; + + return $name; +} + +# ---------------------------------------------------------------------- +sub header_comment { + my $producer = shift || caller; + my $comment_char = shift; + my $now = scalar localtime; + + $comment_char = $DEFAULT_COMMENT + unless defined $comment_char; + + my $header_comment =<<"HEADER_COMMENT"; +${comment_char} +${comment_char}Created by $producer +${comment_char}Created on $now +${comment_char} +HEADER_COMMENT + + # Any additional stuff passed in + for my $additional_comment (@_) { + $header_comment .= "${comment_char}${additional_comment}\n"; + } + + return $header_comment; +} + +# ---------------------------------------------------------------------- +# parse_list_arg +# +# Meant to accept a list, an array reference, or a string of +# comma-separated values. Retuns an array reference of the +# arguments. Modified to also handle a list of references. +# ---------------------------------------------------------------------- +sub parse_list_arg { + my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ]; + + # + # This protects stringification of references. + # + if ( @$list && ref $list->[0] ) { + return $list; + } + # + # This processes string-like arguments. + # + else { + return [ + map { s/^\s+|\s+$//g; $_ } + map { split /,/ } + grep { defined && length } @$list + ]; + } +} + +# ---------------------------------------------------------------------- +# truncate_id_uniquely( $desired_name, $max_symbol_length ) +# +# Truncates the name $desired_name to the $max_symbol_length by +# including part of the hash of the full name at the end of the +# truncated name, giving a high probability that the symbol will be +# unique. +# ---------------------------------------------------------------------- +sub truncate_id_uniquely { + my ( $desired_name, $max_symbol_length ) = @_; + + return $desired_name + unless defined $desired_name && length $desired_name > $max_symbol_length; + + my $truncated_name = substr $desired_name, 0, + $max_symbol_length - COLLISION_TAG_LENGTH - 1; + + # Hex isn't the most space-efficient, but it skirts around allowed + # charset issues + my $digest = sha1_hex($desired_name); + my $collision_tag = substr $digest, 0, COLLISION_TAG_LENGTH; + + return $truncated_name + . '_' + . $collision_tag; +} + + +#--------------------------------------------------------------------- +# parse_mysql_version ( $version_string, $result_target) +# +# Attempts to parse an arbitrary string as a mysql version number. +# Returns either a floating point perl style string, or a mysql style +# 5 digit string, depending on the supplied $result_target +#--------------------------------------------------------------------- +sub parse_mysql_version { + my ($v, $target) = @_; + + return undef unless $v; + + $target ||= 'perl'; + + my @vers; + + # X.Y.Z style + if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) { + push @vers, $1, $2, $3; + } + + # XYYZZ (mysql) style + elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) { + push @vers, $1, $2, $3; + } + + # XX.YYYZZZ (perl) style or simply X + elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) { + push @vers, $1, $2, $3; + } + else { + #how do I croak sanely here? + die "Unparseable MySQL version '$v'"; + } + + if ($target eq 'perl') { + return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) ); + } + elsif ($target eq 'mysql') { + return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) ); + } + else { + #how do I croak sanely here? + die "Unknown version target '$target'"; + } +} + +#--------------------------------------------------------------------- +# parse_dbms_version ( $version_string, $target ) +# +# Attempts to parse either a native or perl-style version string into +# a version number format as specified by $target, which can be either +# 'perl' for a perl-style version number, or 'native' for an X.X.X +# style version number. +#--------------------------------------------------------------------- +sub parse_dbms_version { + my ($v, $target) = @_; + + return undef unless $v; + + my @vers; + + # X.Y.Z style + if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) { + push @vers, $1, $2, $3; + } + + # XX.YYYZZZ (perl) style or simply X + elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) { + push @vers, $1, $2, $3; + } + else { + #how do I croak sanely here? + die "Unparseable database server version '$v'"; + } + + if ($target eq 'perl') { + return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) ); + } + elsif ($target eq 'native') { + return join '.' => grep defined, @vers; + } + else { + #how do I croak sanely here? + die "Unknown version target '$target'"; + } +} + 1; -__END__ +# ---------------------------------------------------------------------- + +=pod =head1 NAME @@ -85,16 +279,16 @@ SQL::Translator::Utils - SQL::Translator Utility functions C contains utility functions designed to be used from the other modules within the C modules. -No functions are exported by default. +Nothing is exported by default. -=head1 EXPORTED FUNCTIONS +=head1 EXPORTED FUNCTIONS AND CONSTANTS =head2 debug C takes 0 or more messages, which will be sent to STDERR using C. Occurances of the strings I, I, and I will be replaced by the calling package, subroutine, and line number, -respectively, as reported by C. +respectively, as reported by C. For example, from within C in F, at line 666: @@ -106,3 +300,112 @@ Will warn The entire message is enclosed within C<[> and C<]> for visual clarity when STDERR is intermixed with STDOUT. + +=head2 normalize_name + +C takes a string and ensures that it is suitable for +use as an identifier. This means: ensure that it starts with a letter +or underscore, and that the rest of the string consists of only +letters, numbers, and underscores. A string that begins with +something other than [a-zA-Z] will be prefixer with an underscore, and +all other characters in the string will be replaced with underscores. +Finally, a trailing underscore will be removed, because that's ugly. + + normalize_name("Hello, world"); + +Produces: + + Hello_world + +A more useful example, from the C test +suite: + + normalize_name("silly field (with random characters)"); + +returns: + + silly_field_with_random_characters + +=head2 header_comment + +Create the header comment. Takes 1 mandatory argument (the producer +classname), an optional comment character (defaults to $DEFAULT_COMMENT), +and 0 or more additional comments, which will be appended to the header, +prefixed with the comment character. If additional comments are provided, +then a comment string must be provided ($DEFAULT_COMMENT is exported for +this use). For example, this: + + package My::Producer; + + use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT); + + print header_comment(__PACKAGE__, + $DEFAULT_COMMENT, + "Hi mom!"); + +produces: + + -- + -- Created by My::Prodcuer + -- Created on Fri Apr 25 06:56:02 2003 + -- + -- Hi mom! + -- + +Note the gratuitous spacing. + +=head2 parse_list_arg + +Takes a string, list or arrayref (all of which could contain +comma-separated values) and returns an array reference of the values. +All of the following will return equivalent values: + + parse_list_arg('id'); + parse_list_arg('id', 'name'); + parse_list_arg( 'id, name' ); + parse_list_arg( [ 'id', 'name' ] ); + parse_list_arg( qw[ id name ] ); + +=head2 truncate_id_uniquely + +Takes a string ($desired_name) and int ($max_symbol_length). Truncates +$desired_name to $max_symbol_length by including part of the hash of +the full name at the end of the truncated name, giving a high +probability that the symbol will be unique. For example, + + truncate_id_uniquely( 'a' x 100, 64 ) + truncate_id_uniquely( 'a' x 99 . 'b', 64 ); + truncate_id_uniquely( 'a' x 99, 64 ) + +Will give three different results; specifically: + + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_7f900025 + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_6191e39a + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa_8cd96af2 + +=head2 $DEFAULT_COMMENT + +This is the default comment string, '-- ' by default. Useful for +C. + +=head2 parse_mysql_version + +Used by both L and +L in order to provide a +consistent format for both C<< parser_args->{mysql_parser_version} >> and +C<< producer_args->{mysql_version} >> respectively. Takes any of the following +version specifications: + + 5.0.3 + 4.1 + 3.23.2 + 5 + 5.001005 (perl style) + 30201 (mysql style) + +=head1 AUTHORS + +Darren Chamberlain Edarren@cpan.orgE, +Ken Y. Clark Ekclark@cpan.orgE. + +=cut