While trying to create CDBI classes myself, I found some of the decisions
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Utils.pm
CommitLineData
1a24938d 1package SQL::Translator::Utils;
2
3# ----------------------------------------------------------------------
977651a5 4# $Id: Utils.pm,v 1.12 2004-02-09 23:04:26 kycl4rk Exp $
1a24938d 5# ----------------------------------------------------------------------
977651a5 6# Copyright (C) 2002-4 SQLFairy Authors
1a24938d 7#
8# This program is free software; you can redistribute it and/or
9# modify it under the terms of the GNU General Public License as
10# published by the Free Software Foundation; version 2.
11#
12# This program is distributed in the hope that it will be useful, but
13# WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15# General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with this program; if not, write to the Free Software
19# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
20# 02111-1307 USA
21# -------------------------------------------------------------------
22
23use strict;
24use base qw(Exporter);
a2ba36ba 25use vars qw($VERSION $DEFAULT_COMMENT @EXPORT_OK);
1a24938d 26
27use Exporter;
28
977651a5 29$VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
a2ba36ba 30$DEFAULT_COMMENT = '-- ';
118bb73f 31@EXPORT_OK = qw(
32 debug normalize_name header_comment parse_list_arg $DEFAULT_COMMENT
33);
1a24938d 34
35# ----------------------------------------------------------------------
36# debug(@msg)
37#
38# Will send debugging messages to STDERR, if the caller's $DEBUG global
39# is set.
40#
41# This debug() function has a neat feature: Occurances of the strings
42# PKG, LINE, and SUB in each message will be replaced with elements
43# from caller():
44#
45# debug("PKG: Bad things happened on line LINE!");
46#
47# Will be warned as:
48#
49# [SQL::Translator: Bad things happened on line 643]
50#
51# If called from Translator.pm, on line 643.
52# ----------------------------------------------------------------------
53sub debug {
a2ba36ba 54 my ($pkg, $file, $line, $sub) = caller(0);
1a24938d 55 {
56 no strict qw(refs);
57 return unless ${"$pkg\::DEBUG"};
58 }
59
60 $sub =~ s/^$pkg\:://;
61
62 while (@_) {
63 my $x = shift;
64 chomp $x;
65 $x =~ s/\bPKG\b/$pkg/g;
66 $x =~ s/\bLINE\b/$line/g;
67 $x =~ s/\bSUB\b/$sub/g;
68 #warn '[' . $x . "]\n";
69 print STDERR '[' . $x . "]\n";
70 }
71}
72
118bb73f 73# ----------------------------------------------------------------------
93d12e9c 74sub normalize_name {
ae48473b 75 my $name = shift or return '';
93d12e9c 76
77 # The name can only begin with a-zA-Z_; if there's anything
78 # else, prefix with _
79 $name =~ s/^([^a-zA-Z_])/_$1/;
80
81 # anything other than a-zA-Z0-9_ in the non-first position
82 # needs to be turned into _
83 $name =~ tr/[a-zA-Z0-9_]/_/c;
84
85 # All duplicated _ need to be squashed into one.
86 $name =~ tr/_/_/s;
87
88 # Trim a trailing _
89 $name =~ s/_$//;
90
91 return $name;
92}
93
118bb73f 94# ----------------------------------------------------------------------
a2ba36ba 95sub header_comment {
96 my $producer = shift || caller;
97 my $comment_char = shift;
98 my $now = scalar localtime;
99
100 $comment_char = $DEFAULT_COMMENT
101 unless defined $comment_char;
102
103 my $header_comment =<<"HEADER_COMMENT";
104${comment_char}
105${comment_char}Created by $producer
106${comment_char}Created on $now
107${comment_char}
108HEADER_COMMENT
109
110 # Any additional stuff passed in
111 for my $additional_comment (@_) {
112 $header_comment .= "${comment_char}${additional_comment}\n";
113 }
114
115 return $header_comment;
116}
117
118bb73f 118# ----------------------------------------------------------------------
51bb6fe0 119# parse_list_arg
120#
121# Meant to accept a list, an array reference, or a string of
122# comma-separated values. Retuns an array reference of the
123# arguments. Modified to also handle a list of references.
124# ----------------------------------------------------------------------
e545d971 125sub parse_list_arg {
126 my $list = UNIVERSAL::isa( $_[0], 'ARRAY' ) ? shift : [ @_ ];
127
51bb6fe0 128 #
129 # This protects stringification of references.
130 #
131 if ( @$list && ref $list->[0] ) {
132 return $list;
133 }
134 #
135 # This processes string-like arguments.
136 #
137 else {
138 return [
139 map { s/^\s+|\s+$//g; $_ }
140 map { split /,/ }
141 grep { defined && length } @$list
142 ];
143 }
118bb73f 144}
145
1a24938d 1461;
147
118bb73f 148# ----------------------------------------------------------------------
149
150=pod
1a24938d 151
152=head1 NAME
153
154SQL::Translator::Utils - SQL::Translator Utility functions
155
156=head1 SYNOPSIS
157
158 use SQL::Translator::Utils qw(debug);
159 debug("PKG: Bad things happened");
160
161=head1 DESCSIPTION
162
163C<SQL::Translator::Utils> contains utility functions designed to be
164used from the other modules within the C<SQL::Translator> modules.
165
a2ba36ba 166Nothing is exported by default.
1a24938d 167
a2ba36ba 168=head1 EXPORTED FUNCTIONS AND CONSTANTS
1a24938d 169
170=head2 debug
171
172C<debug> takes 0 or more messages, which will be sent to STDERR using
173C<warn>. Occurances of the strings I<PKG>, I<SUB>, and I<LINE>
174will be replaced by the calling package, subroutine, and line number,
e545d971 175respectively, as reported by C<caller(1)>.
1a24938d 176
177For example, from within C<foo> in F<SQL/Translator.pm>, at line 666:
178
179 debug("PKG: Error reading file at SUB/LINE");
180
181Will warn
182
183 [SQL::Translator: Error reading file at foo/666]
184
185The entire message is enclosed within C<[> and C<]> for visual clarity
186when STDERR is intermixed with STDOUT.
93d12e9c 187
188=head2 normalize_name
189
190C<normalize_name> takes a string and ensures that it is suitable for
191use as an identifier. This means: ensure that it starts with a letter
192or underscore, and that the rest of the string consists of only
193letters, numbers, and underscores. A string that begins with
194something other than [a-zA-Z] will be prefixer with an underscore, and
195all other characters in the string will be replaced with underscores.
196Finally, a trailing underscore will be removed, because that's ugly.
197
198 normalize_name("Hello, world");
199
200Produces:
201
202 Hello_world
203
204A more useful example, from the C<SQL::Translator::Parser::Excel> test
205suite:
206
207 normalize_name("silly field (with random characters)");
208
209returns:
210
211 silly_field_with_random_characters
212
a2ba36ba 213=head2 header_comment
214
215Create the header comment. Takes 1 mandatory argument (the producer
216classname), an optional comment character (defaults to $DEFAULT_COMMENT),
217and 0 or more additional comments, which will be appended to the header,
218prefixed with the comment character. If additional comments are provided,
219then a comment string must be provided ($DEFAULT_COMMENT is exported for
220this use). For example, this:
221
222 package My::Producer;
223
224 use SQL::Translator::Utils qw(header_comment $DEFAULT_COMMENT);
225
226 print header_comment(__PACKAGE__,
e545d971 227 $DEFAULT_COMMENT,
a2ba36ba 228 "Hi mom!");
229
230produces:
231
e545d971 232 --
a2ba36ba 233 -- Created by My::Prodcuer
234 -- Created on Fri Apr 25 06:56:02 2003
e545d971 235 --
a2ba36ba 236 -- Hi mom!
e545d971 237 --
a2ba36ba 238
239Note the gratuitous spacing.
240
118bb73f 241=head2 parse_list_arg
242
243Takes a string, list or arrayref (all of which could contain
244comma-separated values) and returns an array reference of the values.
245All of the following will return equivalent values:
246
247 parse_list_arg('id');
248 parse_list_arg('id', 'name');
249 parse_list_arg( 'id, name' );
250 parse_list_arg( [ 'id', 'name' ] );
251 parse_list_arg( qw[ id name ] );
252
a2ba36ba 253=head2 $DEFAULT_COMMENT
254
255This is the default comment string, '-- ' by default. Useful for
256C<header_comment>.
257
118bb73f 258=head1 AUTHORS
259
260Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
261Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
262
263=cut
264
265=cut