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