X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FUtils.pm;h=ea39bd99a84c443186ab4f66d1d9ddc27cc917f7;hb=4cdd7bf11607f949721a43dd9c3663096422dbf3;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..ea39bd9 100644 --- a/lib/SQL/Translator/Utils.pm +++ b/lib/SQL/Translator/Utils.pm @@ -1,7 +1,7 @@ package SQL::Translator::Utils; # ---------------------------------------------------------------------- -# $Id: Utils.pm,v 1.1 2003-03-12 14:17:11 dlc Exp $ +# $Id: Utils.pm,v 1.8 2003-06-27 16:30:35 kycl4rk Exp $ # ---------------------------------------------------------------------- # Copyright (C) 2003 darren chamberlain # @@ -22,12 +22,15 @@ 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 Exporter; -$VERSION = 1.00; -@EXPORT_OK = ('debug'); +$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/; +$DEFAULT_COMMENT = '-- '; +@EXPORT_OK = qw( + debug normalize_name header_comment parse_list_arg $DEFAULT_COMMENT +); # ---------------------------------------------------------------------- # 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,66 @@ sub debug { } } +# ---------------------------------------------------------------------- +sub normalize_name { + my $name = shift; + + # 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; +} + +# ---------------------------------------------------------------------- +sub parse_list_arg { + my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ]; + + return [ map { s/^\s+|\s+$//g; $_ } + map { split /,/ } + grep { defined && length } @$list + ]; +} + 1; -__END__ +# ---------------------------------------------------------------------- + +=pod =head1 NAME @@ -85,16 +145,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 +166,82 @@ 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 $DEFAULT_COMMENT + +This is the default comment string, '-- ' by default. Useful for +C. + +=head1 AUTHORS + +Darren Chamberlain Edarren@cpan.orgE, +Ken Y. Clark Ekclark@cpan.orgE. + +=cut + +=cut