← Index
NYTProf Performance Profile   « line view »
For /home/ss5/perl5/perlbrew/perls/perl-5.22.0/bin/benchmarkanything-storage
  Run on Mon Jan 29 16:55:34 2018
Reported on Mon Jan 29 16:57:07 2018

Filename/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/SQL/SplitStatement.pm
StatementsExecuted 46 statements in 2.39ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1111.04ms1.60msSQL::SplitStatement::::BEGIN@16SQL::SplitStatement::BEGIN@16
111575µs638µsSQL::SplitStatement::::BEGIN@14SQL::SplitStatement::BEGIN@14
2525110µs10µsSQL::SplitStatement::::CORE:qrSQL::SplitStatement::CORE:qr (opcode)
1119µs114µsSQL::SplitStatement::::BEGIN@18SQL::SplitStatement::BEGIN@18
1116µs6µsSQL::SplitStatement::::BEGIN@3SQL::SplitStatement::BEGIN@3
1115µs183µsSQL::SplitStatement::::BEGIN@15SQL::SplitStatement::BEGIN@15
1115µs6µsSQL::SplitStatement::::BEGIN@8SQL::SplitStatement::BEGIN@8
1115µs20µsSQL::SplitStatement::::BEGIN@13SQL::SplitStatement::BEGIN@13
1114µs10µsSQL::SplitStatement::::BEGIN@9SQL::SplitStatement::BEGIN@9
1114µs1.11msSQL::SplitStatement::::BEGIN@11SQL::SplitStatement::BEGIN@11
0000s0sSQL::SplitStatement::::__ANON__[:727]SQL::SplitStatement::__ANON__[:727]
0000s0sSQL::SplitStatement::::__ANON__[:730]SQL::SplitStatement::__ANON__[:730]
0000s0sSQL::SplitStatement::::__ANON__[:743]SQL::SplitStatement::__ANON__[:743]
0000s0sSQL::SplitStatement::::__ANON__[:746]SQL::SplitStatement::__ANON__[:746]
0000s0sSQL::SplitStatement::::_add_to_current_statementSQL::SplitStatement::_add_to_current_statement
0000s0sSQL::SplitStatement::::_custom_delimiter_def_foundSQL::SplitStatement::_custom_delimiter_def_found
0000s0sSQL::SplitStatement::::_dollar_placeholder_foundSQL::SplitStatement::_dollar_placeholder_found
0000s0sSQL::SplitStatement::::_dollar_quote_close_foundSQL::SplitStatement::_dollar_quote_close_found
0000s0sSQL::SplitStatement::::_dollar_quote_open_foundSQL::SplitStatement::_dollar_quote_open_found
0000s0sSQL::SplitStatement::::_is_BEGIN_of_blockSQL::SplitStatement::_is_BEGIN_of_block
0000s0sSQL::SplitStatement::::_is_END_of_blockSQL::SplitStatement::_is_END_of_block
0000s0sSQL::SplitStatement::::_is_commentSQL::SplitStatement::_is_comment
0000s0sSQL::SplitStatement::::_is_custom_delimiterSQL::SplitStatement::_is_custom_delimiter
0000s0sSQL::SplitStatement::::_is_terminatorSQL::SplitStatement::_is_terminator
0000s0sSQL::SplitStatement::::_named_placeholder_foundSQL::SplitStatement::_named_placeholder_found
0000s0sSQL::SplitStatement::::_next_significant_token_idxSQL::SplitStatement::_next_significant_token_idx
0000s0sSQL::SplitStatement::::_peek_at_next_significant_tokenSQL::SplitStatement::_peek_at_next_significant_token
0000s0sSQL::SplitStatement::::_peek_at_package_nameSQL::SplitStatement::_peek_at_package_name
0000s0sSQL::SplitStatement::::_questionmark_placeholder_foundSQL::SplitStatement::_questionmark_placeholder_found
0000s0sSQL::SplitStatement::::keep_terminatorSQL::SplitStatement::keep_terminator
0000s0sSQL::SplitStatement::::newSQL::SplitStatement::new
0000s0sSQL::SplitStatement::::splitSQL::SplitStatement::split
0000s0sSQL::SplitStatement::::split_with_placeholdersSQL::SplitStatement::split_with_placeholders
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1## no critic
2package SQL::SplitStatement;
3
# spent 6µs within SQL::SplitStatement::BEGIN@3 which was called: # once (6µs+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 5
BEGIN {
413µs $SQL::SplitStatement::VERSION = '1.00020';
5113µs16µs}
# spent 6µs making 1 call to SQL::SplitStatement::BEGIN@3
6## use critic
7
8214µs28µs
# spent 6µs (5+1) within SQL::SplitStatement::BEGIN@8 which was called: # once (5µs+1µs) by DBIx::MultiStatementDo::BEGIN@11 at line 8
use strict;
# spent 6µs making 1 call to SQL::SplitStatement::BEGIN@8 # spent 1µs making 1 call to strict::import
9215µs215µs
# spent 10µs (4+5) within SQL::SplitStatement::BEGIN@9 which was called: # once (4µs+5µs) by DBIx::MultiStatementDo::BEGIN@11 at line 9
use warnings;
# spent 10µs making 1 call to SQL::SplitStatement::BEGIN@9 # spent 5µs making 1 call to warnings::import
10
11220µs22.21ms
# spent 1.11ms (4µs+1.10) within SQL::SplitStatement::BEGIN@11 which was called: # once (4µs+1.10ms) by DBIx::MultiStatementDo::BEGIN@11 at line 11
use base 'Class::Accessor::Fast';
# spent 1.11ms making 1 call to SQL::SplitStatement::BEGIN@11 # spent 1.10ms making 1 call to base::import
12
13239µs236µs
# spent 20µs (5+16) within SQL::SplitStatement::BEGIN@13 which was called: # once (5µs+16µs) by DBIx::MultiStatementDo::BEGIN@11 at line 13
use Carp qw(croak);
# spent 20µs making 1 call to SQL::SplitStatement::BEGIN@13 # spent 16µs making 1 call to Exporter::import
14381µs3664µs
# spent 638µs (575+63) within SQL::SplitStatement::BEGIN@14 which was called: # once (575µs+63µs) by DBIx::MultiStatementDo::BEGIN@11 at line 14
use SQL::Tokenizer 0.22 qw(tokenize_sql);
# spent 638µs making 1 call to SQL::SplitStatement::BEGIN@14 # spent 20µs making 1 call to Exporter::import # spent 6µs making 1 call to UNIVERSAL::VERSION
15222µs2360µs
# spent 183µs (5+178) within SQL::SplitStatement::BEGIN@15 which was called: # once (5µs+178µs) by DBIx::MultiStatementDo::BEGIN@11 at line 15
use List::MoreUtils qw(firstval firstidx each_array);
# spent 183µs making 1 call to SQL::SplitStatement::BEGIN@15 # spent 178µs making 1 call to Exporter::Tiny::import
16279µs22.00ms
# spent 1.60ms (1.04+556µs) within SQL::SplitStatement::BEGIN@16 which was called: # once (1.04ms+556µs) by DBIx::MultiStatementDo::BEGIN@11 at line 16
use Regexp::Common qw(delimited);
# spent 1.60ms making 1 call to SQL::SplitStatement::BEGIN@16 # spent 403µs making 1 call to Regexp::Common::import
17
18
# spent 114µs (9+105) within SQL::SplitStatement::BEGIN@18 which was called: # once (9µs+105µs) by DBIx::MultiStatementDo::BEGIN@11 at line 32
use constant {
1918µs1105µs NEWLINE => "\n",
# spent 105µs making 1 call to constant::import
20 SEMICOLON => ';',
21 DOT => '.',
22 FORWARD_SLASH => '/',
23 QUESTION_MARK => '?',
24 SINGLE_DOLLAR => '$',
25 DOUBLE_DOLLAR => '$$',
26 OPEN_BRACKET => '(',
27 CLOSED_BRACKET => ')',
28
29 SEMICOLON_TERMINATOR => 1,
30 SLASH_TERMINATOR => 2,
31 CUSTOM_DELIMITER => 3
3212.02ms1114µs};
# spent 114µs making 1 call to SQL::SplitStatement::BEGIN@18
33
34116µs11µsmy $transaction_RE = qr[^(?:
# spent 1µs making 1 call to SQL::SplitStatement::CORE:qr
35 ;
36 |/
37 |WORK
38 |TRAN
39 |TRANSACTION
40 |ISOLATION
41 |READ
42)$]xi;
4312µs1400nsmy $procedural_END_RE = qr/^(?:IF|CASE|LOOP)$/i;
# spent 400ns making 1 call to SQL::SplitStatement::CORE:qr
4412µs1300nsmy $terminator_RE = qr[
# spent 300ns making 1 call to SQL::SplitStatement::CORE:qr
45 ;\s*\n\s*\.\s*\n\s*/\s*\n?
46 |;\s*\n\s*/\s*\n?
47 |\.\s*\n\s*/\s*\n?
48 |\n\s*/\s*\n?
49 |;
50]x;
5111µs1200nsmy $begin_comment_RE = qr/^(?:--|\/\*)/;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
5217µs231µsmy $quoted_RE = $RE{delimited}{ -delim=>q{"'`} };
# spent 31µs making 2 calls to Regexp::Common::FETCH, avg 16µs/call
5312µs1400nsmy $dollar_placeholder_RE = qr/^\$\d+$/;
# spent 400ns making 1 call to SQL::SplitStatement::CORE:qr
5411µs1200nsmy $inner_identifier_RE = qr/[_a-zA-Z][_a-zA-Z0-9]*/;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
55
5612µs1200nsmy $CURSOR_RE = qr/^CURSOR$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
5711µs1200nsmy $DELIMITER_RE = qr/^DELIMITER$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
5812µs1200nsmy $DECLARE_RE = qr/^DECLARE$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
5911µs1300nsmy $PROCEDURE_FUNCTION_RE = qr/^(?:FUNCTION|PROCEDURE)$/i;
# spent 300ns making 1 call to SQL::SplitStatement::CORE:qr
6011µs1200nsmy $PACKAGE_RE = qr/^PACKAGE$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6111µs1200nsmy $BEGIN_RE = qr/^BEGIN$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6211µs1200nsmy $END_RE = qr/^END$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6311µs1200nsmy $AS_RE = qr/^AS$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6416µs14µsmy $IS_RE = qr/^IS$/i;
# spent 4µs making 1 call to SQL::SplitStatement::CORE:qr
6512µs1200nsmy $TYPE_RE = qr/^TYPE$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6611µs1200nsmy $BODY_RE = qr/^BODY$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6711µs1200nsmy $DROP_RE = qr/^DROP$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
6811µs1200nsmy $CRUD_RE = qr/^(?:DELETE|INSERT|SELECT|UPDATE)$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
69
7011µs1200nsmy $GRANT_REVOKE_RE = qr/^(?:GRANT|REVOKE)$/i;;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
7111µs1200nsmy $CREATE_ALTER_RE = qr/^(?:CREATE|ALTER)$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
7211µs1200nsmy $CREATE_REPLACE_RE = qr/^(?:CREATE|REPLACE)$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
7311µs1200nsmy $OR_REPLACE_RE = qr/^(?:OR|REPLACE)$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
7411µs1200nsmy $OR_REPLACE_PACKAGE_RE = qr/^(?:OR|REPLACE|PACKAGE)$/i;
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
75
7611µs1200nsmy $pre_identifier_RE = qr/^(?:
# spent 200ns making 1 call to SQL::SplitStatement::CORE:qr
77 BODY
78 |CONSTRAINT
79 |CURSOR
80 |DECLARE
81 |FUNCTION
82 |INDEX
83 |PACKAGE
84 |PROCEDURE
85 |REFERENCES
86 |TABLE
87 |[.,(]
88)$/xi;
89
9012µs1152µsSQL::SplitStatement->mk_accessors( qw/
# spent 152µs making 1 call to Class::Accessor::mk_accessors
91 keep_terminators
92 keep_extra_spaces
93 keep_empty_statements
94 keep_comments
95 slash_terminates
96 _tokens
97 _current_statement
98 _custom_delimiter
99 _terminators
100 _tokens_in_custom_delimiter
101/);
102
103# keep_terminators alias
104sub keep_terminator { shift->keep_terminators(@_) }
105
106sub new {
107 my $class = shift;
108 my $parameters = @_ > 1 ? { @_ } : $_[0] || {};
109 if ( exists $parameters->{keep_terminators} ) {
110 croak( q[keep_terminator and keep_terminators can't be both assigned'] )
111 if exists $parameters->{keep_terminator}
112 }
113 elsif ( exists $parameters->{keep_terminator} ) {
114 $parameters->{keep_terminators} = delete $parameters->{keep_terminator}
115 }
116 $parameters->{slash_terminates} = 1
117 unless exists $parameters->{slash_terminates};
118 $class->SUPER::new( $parameters )
119}
120
121sub split {
122 my ($self, $code) = @_;
123 my ($statements, undef) = $self->split_with_placeholders($code);
124 return @{ $statements }
125}
126
127sub split_with_placeholders {
128 my ($self, $code) = @_;
129
130 my @placeholders = ();
131 my @statements = ();
132 my $statement_placeholders = 0;
133
134 my $inside_block = 0;
135 my $inside_brackets = 0;
136 my $inside_sub = 0;
137 my $inside_is_as = 0;
138 my $inside_cursor = 0;
139 my $inside_is_cursor = 0;
140 my $inside_declare = 0;
141 my $inside_package = 0;
142 my $inside_grant_revoke = 0;
143 my $inside_crud = 0;
144 my $extra_end_found = 0;
145
146 my @sub_names = ();
147 my $package_name = '';
148
149 my $dollar_quote;
150 my $dollar_quote_to_add;
151
152 my $prev_token = '';
153 my $prev_keyword = '';
154
155 my $custom_delimiter_def_found = 0;
156
157 if ( !defined $code ) {
158 $code = "\n"
159 } else {
160 $code .= "\n"
161 };
162 $self->_tokens( [ tokenize_sql($code) ] );
163 $self->_terminators( [] ); # Needed (only) to remove them afterwards
164 # when keep_terminators is false.
165
166 $self->_current_statement('');
167
168 while ( defined( my $token = shift @{ $self->_tokens } ) ) {
169 my $terminator_found = 0;
170
171 # Skip this token if it's a comment and we don't want to keep it.
172 next if $self->_is_comment($token) && ! $self->keep_comments;
173
174 # Append the token to the current statement;
175 $self->_add_to_current_statement($token);
176
177 # The token is gathered even if it was a space-only token,
178 # but in this case we can skip any further analysis.
179 next if $token =~ /^\s+$/;
180
181 if ( $dollar_quote ) {
182 if ( $self->_dollar_quote_close_found($token, $dollar_quote) ) {
183 $self->_add_to_current_statement($dollar_quote_to_add);
184 undef $dollar_quote;
185 # Saving $prev_token not necessary in this case.
186
187 $inside_sub = 0; # Silence sub opening before dollar quote.
188 @sub_names = ();
189 $inside_is_as = 0; # Silence is_as opening before dollar quote.
190 $inside_declare = 0;
191
192 next
193 }
194 }
195
196 if (
197 $prev_token =~ $AS_RE
198 and !$dollar_quote
199 and $dollar_quote = $self->_dollar_quote_open_found($token)
200 ) {
201 ( $dollar_quote_to_add = $dollar_quote ) =~ s/^\Q$token//;
202 $self->_add_to_current_statement($dollar_quote_to_add)
203 }
204 elsif ( $token =~ $DELIMITER_RE && !$prev_token ) {
205 my $tokens_to_shift = $self->_custom_delimiter_def_found;
206 $self->_add_to_current_statement(
207 join '', splice @{ $self->_tokens }, 0, $tokens_to_shift
208 );
209 $custom_delimiter_def_found = 1;
210 $self->_custom_delimiter(undef)
211 if $self->_custom_delimiter eq SEMICOLON
212 }
213 elsif ( $token eq OPEN_BRACKET ) {
214 $inside_brackets++
215 }
216 elsif ( $token eq CLOSED_BRACKET ) {
217 $inside_brackets--
218 }
219 elsif ( $self->_is_BEGIN_of_block($token, $prev_token) ) {
220 $extra_end_found = 0 if $extra_end_found;
221 $inside_block++
222 }
223 elsif ( $token =~ $CREATE_ALTER_RE ) {
224 my $next_token = $self->_peek_at_next_significant_token(
225 $OR_REPLACE_RE
226 );
227 if ( $next_token =~ $PACKAGE_RE ) {
228 $inside_package = 1;
229 $package_name = $self->_peek_at_package_name
230 }
231 }
232 elsif (
233 $token =~ $PROCEDURE_FUNCTION_RE
234 || $token =~ $BODY_RE && $prev_token =~ $TYPE_RE
235 ) {
236 if (
237 !$inside_block && !$inside_brackets
238 && $prev_token !~ $DROP_RE
239 && $prev_token !~ $pre_identifier_RE
240 ) {
241 $inside_sub++;
242 $prev_keyword = $token;
243 push @sub_names, $self->_peek_at_next_significant_token
244 }
245 }
246 elsif ( $token =~ /$IS_RE|$AS_RE/ ) {
247 if (
248 $prev_keyword =~ /$PROCEDURE_FUNCTION_RE|$BODY_RE/
249 && !$inside_block && $prev_token !~ $pre_identifier_RE
250 ) {
251 $inside_is_as++;
252 $prev_keyword = ''
253 }
254
255 $inside_is_cursor = 1
256 if $inside_declare && $inside_cursor
257 }
258 elsif ( $token =~ $DECLARE_RE ) {
259 # In MySQL a declare can only appear inside a BEGIN ... END block.
260 $inside_declare = 1
261 if !$inside_block
262 && $prev_token !~ $pre_identifier_RE
263 }
264 elsif ( $token =~ $CURSOR_RE ) {
265 $inside_cursor = 1
266 if $inside_declare
267 && $prev_token !~ $DROP_RE
268 && $prev_token !~ $pre_identifier_RE
269 }
270 elsif ( $token =~ /$GRANT_REVOKE_RE/ ) {
271 $inside_grant_revoke = 1 unless $prev_token
272 }
273 elsif (
274 defined ( my $name = $self->_is_END_of_block($token) )
275 ) {
276 $extra_end_found = 1 if !$inside_block;
277
278 $inside_block-- if $inside_block;
279
280 if ( !$inside_block ) {
281 # $name contains the next (significant) token.
282 if ( $name eq SEMICOLON ) {
283 # Keep this order!
284 if ( $inside_sub && $inside_is_as ) {
285 $inside_sub--;
286 $inside_is_as--;
287 pop @sub_names if $inside_sub < @sub_names
288 } elsif ( $inside_declare ) {
289 $inside_declare = 0
290 } elsif ( $inside_package ) {
291 $inside_package = 0;
292 $package_name = ''
293 }
294 }
295
296 if ( $inside_sub && @sub_names && $name eq $sub_names[-1] ) {
297 $inside_sub--;
298 pop @sub_names if $inside_sub < @sub_names
299 }
300
301 if ( $inside_package && $name eq $package_name ) {
302 $inside_package = 0;
303 $package_name = ''
304 }
305 }
306 }
307 elsif ( $token =~ $CRUD_RE ) {
308 $inside_crud = 1
309 }
310 elsif (
311 $inside_crud && (
312 my $placeholder_token
313 = $self->_questionmark_placeholder_found($token)
314 || $self->_named_placeholder_found($token)
315 || $self->_dollar_placeholder_found($token)
316 )
317 ) {
318 $statement_placeholders++
319 if !$self->_custom_delimiter
320 || $self->_custom_delimiter ne $placeholder_token;
321
322# Needed by SQL::Tokenizer pre-0.21
323 # The only multi-token placeholder is a dollar placeholder.
324# if ( ( my $token_to_add = $placeholder_token ) =~ s[^\$][] ) {
325# $self->_add_to_current_statement($token_to_add)
326# }
327 }
328 else {
329 $terminator_found = $self->_is_terminator($token);
330
331 if (
332 $terminator_found && $terminator_found == SEMICOLON_TERMINATOR
333 && !$inside_brackets
334 ) {
335 if ( $inside_sub && !$inside_is_as && !$inside_block ) {
336 # Needed to close PL/SQL sub forward declarations such as:
337 # PROCEDURE proc(number1 NUMBER);
338 $inside_sub--
339 }
340
341 if ( $inside_declare && $inside_cursor && !$inside_is_cursor ) {
342 # Needed to close CURSOR decl. other than those in PL/SQL
343 # inside a DECLARE;
344 $inside_declare = 0
345 }
346
347 $inside_crud = 0 if $inside_crud
348 }
349 }
350
351 $prev_token = $token
352 if $token =~ /\S/ && ! $self->_is_comment($token);
353
354 # If we've just found a new custom DELIMITER definition, we certainly
355 # have a new statement (and no terminator).
356 unless (
357 $custom_delimiter_def_found
358 || $terminator_found && $terminator_found == CUSTOM_DELIMITER
359 ) {
360 # Let's examine any condition that can make us remain in the
361 # current statement.
362 next if
363 !$terminator_found || $dollar_quote || $inside_brackets
364 || $self->_custom_delimiter;
365
366 next if
367 $terminator_found
368 && $terminator_found == SEMICOLON_TERMINATOR
369 && (
370 $inside_block || $inside_sub
371 || $inside_declare || $inside_package || $inside_crud
372 ) && !$inside_grant_revoke && !$extra_end_found
373 }
374
375 # Whenever we get this far, we have a new statement.
376
377 push @statements, $self->_current_statement;
378 push @placeholders, $statement_placeholders;
379
380 # If $terminator_found == CUSTOM_DELIMITER
381 # @{ $self->_terminators } element has already been pushed,
382 # so we have to set it only in the case tested below.
383 push @{ $self->_terminators }, [ $terminator_found, undef ]
384 if (
385 $terminator_found == SEMICOLON_TERMINATOR
386 || $terminator_found == SLASH_TERMINATOR
387 );
388
389 $self->_current_statement('');
390 $statement_placeholders = 0;
391
392 $prev_token = '';
393 $prev_keyword = '';
394
395 $inside_brackets = 0;
396 $inside_block = 0;
397 $inside_cursor = 0;
398 $inside_is_cursor = 0;
399 $inside_sub = 0;
400 $inside_is_as = 0;
401 $inside_declare = 0;
402 $inside_package = 0;
403 $inside_grant_revoke = 0;
404 $inside_crud = 0;
405 $extra_end_found = 0;
406 @sub_names = ();
407
408 $custom_delimiter_def_found = 0
409 }
410
411 # Last statement.
412 chomp( my $last_statement = $self->_current_statement );
413 push @statements, $last_statement;
414 push @{ $self->_terminators }, [undef, undef];
415 push @placeholders, $statement_placeholders;
416
417 my @filtered_statements;
418 my @filtered_terminators;
419 my @filtered_placeholders;
420
421 if ( $self->keep_empty_statements ) {
422 @filtered_statements = @statements;
423 @filtered_terminators = @{ $self->_terminators };
424 @filtered_placeholders = @placeholders
425 } else {
426 my $sp = each_array(
427 @statements, @{ $self->_terminators }, @placeholders
428 );
429 while ( my ($statement, $terminator, $placeholder_num) = $sp->() ) {
430 my $only_terminator_RE
431 = $terminator->[0] && $terminator->[0] == CUSTOM_DELIMITER
432 ? qr/^\s*\Q$terminator->[1]\E?\s*$/
433 : qr/^\s*$terminator_RE?\z/;
434 unless ( $statement =~ $only_terminator_RE ) {
435 push @filtered_statements, $statement;
436 push @filtered_terminators, $terminator;
437 push @filtered_placeholders, $placeholder_num
438 }
439 }
440 }
441
442 unless ( $self->keep_terminators ) {
443 for ( my $i = 0; $i < @filtered_statements; $i++ ) {
444 my $terminator = $filtered_terminators[$i];
445 if ( $terminator->[0] ) {
446 if ( $terminator->[0] == CUSTOM_DELIMITER ) {
447 $filtered_statements[$i] =~ s/\Q$terminator->[1]\E$//
448 } else {
449 $filtered_statements[$i] =~ s/$terminator_RE$//
450 }
451 }
452 }
453 }
454
455 unless ( $self->keep_extra_spaces ) {
456 s/^\s+|\s+$//g foreach @filtered_statements
457 }
458
459 return ( \@filtered_statements, \@filtered_placeholders )
460}
461
462sub _add_to_current_statement {
463 my ($self, $token) = @_;
464 $self->_current_statement( $self->_current_statement() . $token )
465}
466
467sub _is_comment {
468 my ($self, $token) = @_;
469 return $token =~ $begin_comment_RE
470}
471
472sub _is_BEGIN_of_block {
473 my ($self, $token, $prev_token) = @_;
474 return
475 $token =~ $BEGIN_RE
476 && $prev_token !~ $pre_identifier_RE
477 && $self->_peek_at_next_significant_token !~ $transaction_RE
478}
479
480sub _is_END_of_block {
481 my ($self, $token) = @_;
482 my $next_token = $self->_peek_at_next_significant_token;
483
484 # Return possible package name.
485 if (
486 $token =~ $END_RE && (
487 !defined($next_token)
488 || $next_token !~ $procedural_END_RE
489 )
490 ) { return defined $next_token ? $next_token : '' }
491
492 return
493}
494
495sub _dollar_placeholder_found {
496 my ($self, $token) = @_;
497
498 return $token =~ $dollar_placeholder_RE ? $token : '';
499
500# Needed by SQL::Tokenizer pre-0.21
501# return '' if $token ne SINGLE_DOLLAR;
502#
503# # $token must be: '$'
504# my $tokens = $self->_tokens;
505#
506# return $tokens->[0] =~ /^\d+$/ && $tokens->[1] !~ /^\$/
507# ? $token . shift( @$tokens ) : ''
508}
509
510sub _named_placeholder_found {
511 my ($self, $token) = @_;
512
513 return $token =~ /^:(?:\d+|[_a-z][_a-z\d]*)$/ ? $token : ''
514}
515
516sub _questionmark_placeholder_found {
517 my ($self, $token) = @_;
518
519 return $token eq QUESTION_MARK ? $token : ''
520}
521
522sub _dollar_quote_open_found {
523 my ($self, $token) = @_;
524
525 return '' if $token !~ /^\$/;
526
527 # Includes the DOUBLE_DOLLAR case
528 return $token if $token =~ /^\$$inner_identifier_RE?\$$/;
529# Used with SQL::Tokenizer pre-0.21
530# return $token if $token eq DOUBLE_DOLLAR;
531
532 # $token must be: '$' or '$1', '$2' etc.
533 return '' if $token =~ $dollar_placeholder_RE;
534
535 # $token must be: '$'
536 my $tokens = $self->_tokens;
537
538 # False alarm!
539 return '' if $tokens->[1] !~ /^\$/;
540
541 return $token . shift( @$tokens ) . shift( @$tokens )
542 if $tokens->[0] =~ /^$inner_identifier_RE$/
543 && $tokens->[1] eq SINGLE_DOLLAR;
544
545 # $tokens->[1] must match: /$.+/
546 my $quote = $token . shift( @$tokens ) . '$';
547 $tokens->[0] = substr $tokens->[0], 1;
548 return $quote
549}
550
551sub _dollar_quote_close_found {
552 my ($self, $token, $dollar_quote) = @_;
553
554 return if $token !~ /^\$/;
555 return 1 if $token eq $dollar_quote; # $token matches /$.*$/
556
557 # $token must be: '$' or '$1', '$2' etc.
558 return if $token =~ $dollar_placeholder_RE;
559
560 # $token must be: '$'
561 my $tokens = $self->_tokens;
562
563 # False alarm!
564 return if $tokens->[1] !~ /^\$/;
565
566 if ( $dollar_quote eq $token . $tokens->[0] . $tokens->[1] ) {
567 shift( @$tokens ); shift( @$tokens );
568 return 1
569 }
570
571 # $tokens->[1] must match: /$.+/
572 if ( $dollar_quote eq $token . $tokens->[0] . '$' ) {
573 shift( @$tokens );
574 $tokens->[0] = substr $tokens->[0], 1;
575 return 1
576 }
577
578 return
579}
580
581sub _peek_at_package_name {
582 shift->_peek_at_next_significant_token(
583 qr/$OR_REPLACE_PACKAGE_RE|$BODY_RE/
584 )
585}
586
587sub _custom_delimiter_def_found {
588 my $self = shift;
589
590 my $tokens = $self->_tokens;
591
592 my $base_index = 0;
593 $base_index++ while $tokens->[$base_index] =~ /^\s$/;
594
595 my $first_token_in_delimiter = $tokens->[$base_index];
596 my $delimiter = '';
597 my $tokens_in_delimiter;
598 my $tokens_to_shift;
599
600 if ( $first_token_in_delimiter =~ $quoted_RE ) {
601 # Quoted custom delimiter: it's just a single token (to shift)...
602 $tokens_to_shift = $base_index + 1;
603 # ... However it can be composed by several tokens
604 # (according to SQL::Tokenizer), once removed the quotes.
605 $delimiter = substr $first_token_in_delimiter, 1, -1;
606 $tokens_in_delimiter =()= tokenize_sql($delimiter)
607 } else {
608 # Gather an unquoted custom delimiter, which could be composed
609 # by several tokens (that's the SQL::Tokenizer behaviour).
610 foreach ( $base_index .. $#{ $tokens } ) {
611 last if $tokens->[$_] =~ /^\s+$/;
612 $delimiter .= $tokens->[$_];
613 $tokens_in_delimiter++
614 }
615 $tokens_to_shift = $base_index + $tokens_in_delimiter
616 }
617
618 $self->_custom_delimiter($delimiter);
619
620 # We've just found a custom delimiter definition,
621 # which means that this statement has no (additional) terminator,
622 # therefore we won't have to delete anything.
623 push @{ $self->_terminators }, [undef, undef];
624
625 $self->_tokens_in_custom_delimiter($tokens_in_delimiter);
626
627 return $tokens_to_shift
628}
629
630sub _is_custom_delimiter {
631 my ($self, $token) = @_;
632
633 my $tokens = $self->_tokens;
634 my @delimiter_tokens
635 = splice @{$tokens}, 0, $self->_tokens_in_custom_delimiter() - 1;
636 my $lookahead_delimiter = join '', @delimiter_tokens;
637 if ( $self->_custom_delimiter eq $token . $lookahead_delimiter ) {
638 $self->_add_to_current_statement($lookahead_delimiter);
639 push @{ $self->_terminators },
640 [ CUSTOM_DELIMITER, $self->_custom_delimiter ];
641 return 1
642 } else {
643 unshift @{$tokens}, @delimiter_tokens;
644 return
645 }
646}
647
648sub _is_terminator {
649 my ($self, $token) = @_;
650
651 # This is the first test to perform!
652 if ( $self->_custom_delimiter ) {
653 # If a custom delimiter is currently defined,
654 # no other token can terminate a statement.
655 return CUSTOM_DELIMITER if $self->_is_custom_delimiter($token);
656
657 return
658 }
659
660 return if $token ne FORWARD_SLASH && $token ne SEMICOLON;
661
662 my $tokens = $self->_tokens;
663
664 if ( $token eq FORWARD_SLASH ) {
665 # Remove the trailing FORWARD_SLASH from the current statement
666 chop( my $current_statement = $self->_current_statement );
667
668 my $next_token = $tokens->[0];
669 my $next_next_token = $tokens->[1];
670
671 if (
672 !defined($next_token)
673 || $next_token eq NEWLINE
674 || $next_token =~ /^\s+$/ && $next_next_token eq NEWLINE
675 ) {
676 return SLASH_TERMINATOR
677 if $current_statement =~ /;\s*\n\s*\z/
678 || $current_statement =~ /\n\s*\.\s*\n\s*\z/;
679
680 # Slash with no preceding semicolon or period:
681 # this is to be treated as a semicolon terminator...
682 my $next_significant_token_idx
683 = $self->_next_significant_token_idx;
684 # ... provided that it's not a division operator
685 # (at least not a blatant one ;-)
686 return SEMICOLON_TERMINATOR
687 if $self->slash_terminates
688 && $current_statement =~ /\n\s*\z/
689 && (
690 $next_significant_token_idx == -1
691 ||
692 $tokens->[$next_significant_token_idx] ne OPEN_BRACKET
693 && $tokens->[$next_significant_token_idx] !~ /^\d/
694 && !(
695 $tokens->[$next_significant_token_idx] eq DOT
696 && $tokens->[$next_significant_token_idx + 1] =~ /^\d/
697 )
698 )
699 }
700
701 return
702 }
703
704 # $token eq SEMICOLON.
705
706 my $next_code_portion = '';
707 my $i = 0;
708 $next_code_portion .= $tokens->[$i++]
709 while $i <= 8 && defined $tokens->[$i];
710
711 return SEMICOLON_TERMINATOR
712 if $token eq SEMICOLON
713 && $next_code_portion !~ m#\A\s*\n\s*/\s*$#m
714 && $next_code_portion !~ m#\A\s*\n\s*\.\s*\n\s*/\s*$#m;
715
716 # there is a FORWARD_SLASH next: let's wait for it to terminate.
717 return
718}
719
720sub _peek_at_next_significant_token {
721 my ($self, $skiptoken_RE) = @_;
722
723 my $tokens = $self->_tokens;
724 my $next_significant_token = $skiptoken_RE
725 ? firstval {
726 /\S/ && ! $self->_is_comment($_) && ! /$skiptoken_RE/
727 } @{ $tokens }
728 : firstval {
729 /\S/ && ! $self->_is_comment($_)
730 } @{ $tokens };
731
732 return $next_significant_token if defined $next_significant_token;
733 return ''
734}
735
736sub _next_significant_token_idx {
737 my ($self, $skiptoken_RE) = @_;
738
739 my $tokens = $self->_tokens;
740 return $skiptoken_RE
741 ? firstidx {
742 /\S/ && ! $self->_is_comment($_) && ! /$skiptoken_RE/
743 } @{ $tokens }
744 : firstidx {
745 /\S/ && ! $self->_is_comment($_)
746 } @{ $tokens }
747}
748
74919µs1;
750
751__END__
 
# spent 10µs within SQL::SplitStatement::CORE:qr which was called 25 times, avg 420ns/call: # once (4µs+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 64 # once (1µs+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 34 # once (400ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 53 # once (400ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 43 # once (300ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 59 # once (300ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 44 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 54 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 73 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 61 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 60 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 76 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 71 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 74 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 68 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 66 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 63 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 51 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 58 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 67 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 70 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 62 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 65 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 56 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 72 # once (200ns+0s) by DBIx::MultiStatementDo::BEGIN@11 at line 57
sub SQL::SplitStatement::CORE:qr; # opcode