File Coverage

blib/lib/SQL/Statement/Functions.pm
Criterion Covered Total %
statement 294 323 91.0
branch 46 70 65.7
condition 94 173 54.3
subroutine 127 132 96.2
pod 0 95 0.0
total 561 793 70.7


line stmt bran cond sub pod time code
1             package SQL::Statement::Functions;
2              
3             ######################################################################
4             #
5             # This module is copyright (c), 2001,2005 by Jeff Zucker.
6             # This module is copyright (c), 2011,2012 by Brendan Byrd.
7             # This module is copyright (c), 2009-2020 by Jens Rehsack.
8             # All rights reserved.
9             #
10             # It may be freely distributed under the same terms as Perl itself.
11             # See below for help and copyright information (search for SYNOPSIS).
12             #
13             ######################################################################
14              
15 17     17   118 use strict;
  17         33  
  17         570  
16 17     17   93 use warnings FATAL => "all";
  17         31  
  17         597  
17             # no warnings 'uninitialized'; # please don't bother me with these useless warnings...
18              
19 17     17   93 use Carp qw(croak);
  17         44  
  17         892  
20 17     17   106 use Params::Util qw(_ARRAY0 _HASH0 _INSTANCE);
  17         36  
  17         867  
21 17     17   105 use Scalar::Util qw(looks_like_number);
  17         48  
  17         826  
22 17     17   134 use List::Util qw(max); # core module since Perl 5.8.0
  17         39  
  17         1905  
23 17     17   9292 use Time::HiRes qw(time); # core module since Perl 5.7.2
  17         24768  
  17         68  
24 17     17   13565 use Encode; # core module since Perl 5.7.1
  17         175850  
  17         1282  
25 17     17   8382 use Math::Trig; # core module since Perl 5.004
  17         221268  
  17         2658  
26 17     17   9383 use Module::Runtime qw(require_module use_module);
  17         30698  
  17         118  
27              
28             =pod
29              
30             =head1 NAME
31              
32             SQL::Statement::Functions - built-in & user-defined SQL functions
33              
34             =head1 SYNOPSIS
35              
36             SELECT Func(args);
37             SELECT * FROM Func(args);
38             SELECT * FROM x WHERE Funcs(args);
39             SELECT * FROM x WHERE y < Funcs(args);
40              
41             =head1 DESCRIPTION
42              
43             This module contains the built-in functions for L and L. All of the functions are also available in any DBDs that subclass those modules (e.g. DBD::CSV, DBD::DBM, DBD::File, DBD::AnyData, DBD::Excel, etc.).
44              
45             This documentation covers built-in functions and also explains how to create your own functions to supplement the built-in ones. It's easy. If you create one that is generally useful, see below for how to submit it to become a built-in function.
46              
47             =head1 Function syntax
48              
49             When using L/L directly to parse SQL, functions (either built-in or user-defined) may occur anywhere in a SQL statement that values, column names, table names, or predicates may occur. When using the modules through a DBD or in any other context in which the SQL is both parsed and executed, functions can occur in the same places except that they can not occur in the column selection clause of a SELECT statement that contains a FROM clause.
50              
51             # valid for both parsing and executing
52              
53             SELECT MyFunc(args);
54             SELECT * FROM MyFunc(args);
55             SELECT * FROM x WHERE MyFuncs(args);
56             SELECT * FROM x WHERE y < MyFuncs(args);
57              
58             # valid only for parsing (won't work from a DBD)
59              
60             SELECT MyFunc(args) FROM x WHERE y;
61              
62             =head1 User-Defined Functions
63              
64             =head2 Loading User-Defined Functions
65              
66             In addition to the built-in functions, you can create any number of your own user-defined functions (UDFs). In order to use a UDF in a script, you first have to create a perl subroutine (see below), then you need to make the function available to your database handle with the CREATE FUNCTION or LOAD commands:
67              
68             # load a single function "foo" from a subroutine
69             # named "foo" in the current package
70              
71             $dbh->do(" CREATE FUNCTION foo EXTERNAL ");
72              
73             # load a single function "foo" from a subroutine
74             # named "bar" in the current package
75              
76             $dbh->do(" CREATE FUNCTION foo EXTERNAL NAME bar");
77              
78              
79             # load a single function "foo" from a subroutine named "foo"
80             # in another package
81              
82             $dbh->do(' CREATE FUNCTION foo EXTERNAL NAME "Bar::Baz::foo" ');
83              
84             # load all the functions in another package
85              
86             $dbh->do(' LOAD "Bar::Baz" ');
87              
88             Functions themselves should follow SQL identifier naming rules. Subroutines loaded with CREATE FUNCTION can have any valid perl subroutine name. Subroutines loaded with LOAD must start with SQL_FUNCTION_ and then the actual function name. For example:
89              
90             package Qux::Quimble;
91             sub SQL_FUNCTION_FOO { ... }
92             sub SQL_FUNCTION_BAR { ... }
93             sub some_other_perl_subroutine_not_a_function { ... }
94             1;
95              
96             # in another package
97             $dbh->do("LOAD Qux::Quimble");
98              
99             # This loads FOO and BAR as SQL functions.
100              
101             =head2 Creating User-Defined Functions
102              
103             User-defined functions (UDFs) are perl subroutines that return values appropriate to the context of the function in a SQL statement. For example the built-in CURRENT_TIME returns a string value and therefore may be used anywhere in a SQL statement that a string value can. Here' the entire perl code for the function:
104              
105             # CURRENT_TIME
106             #
107             # arguments : none
108             # returns : string containing current time as hh::mm::ss
109             #
110             sub SQL_FUNCTION_CURRENT_TIME {
111             sprintf "%02s::%02s::%02s",(localtime)[2,1,0]
112             }
113              
114             More complex functions can make use of a number of arguments always passed to functions automatically. Functions always receive these values in @_:
115              
116             sub FOO {
117             my($self,$sth,@params);
118             }
119              
120             The first argument, $self, is whatever class the function is defined in, not generally useful unless you have an entire module to support the function.
121              
122             The second argument, $sth is the active statement handle of the current statement. Like all active statement handles it contains the current database handle in the {Database} attribute so you can have access to the database handle in any function:
123              
124             sub FOO {
125             my($self,$sth,@params);
126             my $dbh = $sth->{Database};
127             # $dbh->do( ...), etc.
128             }
129              
130             In actual practice you probably want to use $sth->{Database} directly rather than making a local copy, so $sth->{Database}->do(...).
131              
132             The remaining arguments, @params, are arguments passed by users to the function, either directly or with placeholders; another silly example which just returns the results of multiplying the arguments passed to it:
133              
134             sub MULTIPLY {
135             my($self,$sth,@params);
136             return $params[0] * $params[1];
137             }
138              
139             # first make the function available
140             #
141             $dbh->do("CREATE FUNCTION MULTIPLY");
142              
143             # then multiply col3 in each row times seven
144             #
145             my $sth=$dbh->prepare("SELECT col1 FROM tbl1 WHERE col2 = MULTIPLY(col3,7)");
146             $sth->execute;
147             #
148             # or
149             #
150             my $sth=$dbh->prepare("SELECT col1 FROM tbl1 WHERE col2 = MULTIPLY(col3,?)");
151             $sth->execute(7);
152              
153             =head2 Creating In-Memory Tables with functions
154              
155             A function can return almost anything, as long is it is an appropriate return for the context the function will be used in. In the special case of table-returning functions, the function should return a reference to an array of array references with the first row being the column names and the remaining rows the data. For example:
156              
157             B<1. create a function that returns an AoA>,
158              
159             sub Japh {[
160             [qw( id word )],
161             [qw( 1 Hacker )],
162             [qw( 2 Perl )],
163             [qw( 3 Another )],
164             [qw( 4 Just )],
165             ]}
166              
167             B<2. make your database handle aware of the function>
168              
169             $dbh->do("CREATE FUNCTION 'Japh');
170              
171             B<3. Access the data in the AoA from SQL>
172              
173             $sth = $dbh->prepare("SELECT word FROM Japh ORDER BY id DESC");
174              
175             Or here's an example that does a join on two in-memory tables:
176              
177             sub Prof {[ [qw(pid pname)],[qw(1 Sue )],[qw(2 Bob)],[qw(3 Tom )] ]}
178             sub Class {[ [qw(pid cname)],[qw(1 Chem)],[qw(2 Bio)],[qw(2 Math)] ]}
179             $dbh->do("CREATE FUNCTION $_) for qw(Prof Class);
180             $sth = $dbh->prepare("SELECT * FROM Prof NATURAL JOIN Class");
181              
182             The "Prof" and "Class" functions return tables which can be used like any SQL table.
183              
184             More complex functions might do something like scrape an RSS feed, or search a file system and put the results in AoA. For example, to search a directory with SQL:
185              
186             sub Dir {
187             my($self,$sth,$dir)=@_;
188             opendir D, $dir or die "'$dir':$!";
189             my @files = readdir D;
190             my $data = [[qw(fileName fileExt)]];
191             for (@files) {
192             my($fn,$ext) = /^(.*)(\.[^\.]+)$/;
193             push @$data, [$fn,$ext];
194             }
195             return $data;
196             }
197             $dbh->do("CREATE FUNCTION Dir");
198             printf "%s\n", join' ',@{ $dbh->selectcol_arrayref("
199             SELECT fileName FROM Dir('./') WHERE fileExt = '.pl'
200             ")};
201              
202             Obviously, that function could be expanded with File::Find and/or stat to provide more information and it could be made to accept a list of directories rather than a single directory.
203              
204             Table-Returning functions are a way to turn *anything* that can be modeled as an AoA into a DBI data source.
205              
206             =head1 Built-in Functions
207              
208             =head2 SQL-92/ODBC Compatibility
209              
210             All ODBC 3.0 functions are available except for the following:
211              
212             ### SQL-92 / ODBC Functions
213            
214             # CONVERT / CAST - Complex to implement, but a draft is in the works.
215             # DIFFERENCE - Function is not clearly defined in spec and has very limited applications
216             # EXTRACT - Contains a FROM keyword and requires rather freeform datetime/interval expression
217            
218             ### ODBC 3.0 Time/Date Functions only
219            
220             # DAYOFMONTH, DAYOFWEEK, DAYOFYEAR, HOUR, MINUTE, MONTH, MONTHNAME, QUARTER, SECOND, TIMESTAMPDIFF,
221             # WEEK, YEAR - Requires freeform datetime/interval expressions. In a later release, these could
222             # be implemented with the help of Date::Parse.
223              
224             ODBC 3.0 functions that are implemented with differences include:
225              
226             # SOUNDEX - Returns true/false, instead of a SOUNDEX code
227             # RAND - Seed value is a second parameter with a new first parameter for max limit
228             # LOG - Returns base X (or 10) log of number, not natural log. LN is used for natural log, and
229             # LOG10 is still available for standards compatibility.
230             # POSITION - Does not use 'IN' keyword; cannot be fixed as previous versions of SQL::Statement defined
231             # the function as such.
232             # REPLACE / SUBSTITUTE - Uses a regular expression string for the second parameter, replacing the last two
233             # parameters of the typical ODBC function
234              
235             =cut
236              
237 17     17   2006 use vars qw($VERSION);
  17         41  
  17         1750  
238             $VERSION = '1.413_001';
239              
240             =pod
241              
242             =head2 Aggregate Functions
243              
244             =head3 MIN, MAX, AVG, SUM, COUNT
245              
246             Aggregate functions are handled elsewhere, see L for documentation.
247              
248             =pod
249              
250             =head2 Date and Time Functions
251              
252             These functions can be used without parentheses.
253              
254             =head3 CURRENT_DATE aka CURDATE
255              
256             # purpose : find current date
257             # arguments : none
258             # returns : string containing current date as yyyy-mm-dd
259              
260             =cut
261              
262             sub SQL_FUNCTION_CURRENT_DATE
263             {
264 2     2 0 97 my ( $sec, $min, $hour, $day, $mon, $year ) = localtime;
265 2         28 return sprintf( '%4s-%02s-%02s', $year + 1900, $mon + 1, $day );
266             }
267 17     17   156 no warnings 'once';
  17         46  
  17         1040  
268             *SQL_FUNCTION_CURDATE = \&SQL_FUNCTION_CURRENT_DATE;
269 17     17   110 use warnings 'all';
  17         40  
  17         1388  
270              
271             =pod
272              
273             =head3 CURRENT_TIME aka CURTIME
274              
275             # purpose : find current time
276             # arguments : optional seconds precision
277             # returns : string containing current time as hh:mm:ss (or ss.sss...)
278              
279             =cut
280              
281             sub SQL_FUNCTION_CURRENT_TIME
282             {
283 4     4 0 17 return substr( SQL_FUNCTION_CURRENT_TIMESTAMP( @_[ 0 .. 2 ] ), 11 );
284             }
285 17     17   133 no warnings 'once';
  17         41  
  17         733  
286             *SQL_FUNCTION_CURTIME = \&SQL_FUNCTION_CURRENT_TIME;
287 17     17   109 use warnings 'all';
  17         35  
  17         2663  
288              
289             =pod
290              
291             =head3 CURRENT_TIMESTAMP aka NOW
292              
293             # purpose : find current date and time
294             # arguments : optional seconds precision
295             # returns : string containing current timestamp as yyyy-mm-dd hh:mm:ss (or ss.sss...)
296              
297             =cut
298              
299             sub SQL_FUNCTION_CURRENT_TIMESTAMP
300             {
301 8     8 0 11 my $prec;
302              
303 8         26 my $curtime = time;
304 8         233 my ( $sec, $min, $hour, $day, $mon, $year ) = localtime($curtime);
305              
306 8         28 my $sec_frac;
307 8 100       48 if ( $_[2] )
308             {
309 4         15 $prec = int( $_[2] );
310 4         40 $sec_frac = sprintf( '%.*f', $prec, $curtime - int($curtime) );
311 4         14 $sec_frac = substr( $sec_frac, 2 ); # truncate 0. from decimal
312             }
313              
314 8 100       99 return sprintf(
    100          
315             '%4s-%02s-%02s %02s:%02s:%02s' . ( $prec ? '.%s' : '' ),
316             $year + 1900,
317             $mon + 1, $day, $hour, $min, $sec, ( $prec ? $sec_frac : ())
318             );
319             }
320 17     17   136 no warnings 'once';
  17         55  
  17         1041  
321             *SQL_FUNCTION_NOW = \&SQL_FUNCTION_CURRENT_TIMESTAMP;
322 17     17   129 use warnings 'all';
  17         42  
  17         5386  
323              
324             =pod
325              
326             =head3 UNIX_TIMESTAMP
327              
328             # purpose : find the current time in UNIX epoch format
329             # arguments : optional seconds precision (unlike the MySQL version)
330             # returns : a (64-bit) number, possibly with decimals
331              
332             =cut
333              
334 3 100   3 0 47 sub SQL_FUNCTION_UNIX_TIMESTAMP { return sprintf( "%.*f", $_[2] ? int( $_[2] ) : 0, time ); }
335              
336             =pod
337              
338             =head2 String Functions
339              
340             =head3 ASCII & CHAR
341              
342             # purpose : same as ord and chr, respectively (NULL for any NULL args)
343             # arguments : string or character (or number for CHAR); CHAR can have any amount of numbers for a string
344              
345             =cut
346              
347 2 50   2 0 27 sub SQL_FUNCTION_ASCII { return defined $_[2] ? ord( $_[2] ) : undef; }
348              
349             sub SQL_FUNCTION_CHAR
350             {
351 9     9 0 28 my ( $self, $owner, @params ) = @_;
352 9   50     43 ( defined || return undef ) for (@params);
353 9         22 return join '', map { chr } @params;
  21         94  
354             }
355              
356             =pod
357              
358             =head3 BIT_LENGTH
359              
360             # purpose : length of the string in bits
361             # arguments : string
362              
363             =cut
364              
365             sub SQL_FUNCTION_BIT_LENGTH
366             {
367 3     3 0 9 my @v = @_[ 0 .. 1 ];
368 3         8 my $str = $_[2];
369             # Number of bits on first character = INT(LOG2(ord($str)) + 1) + rest of string = OCTET_LENGTH(substr($str, 1)) * 8
370 3         12 return int( SQL_FUNCTION_LOG( @v, 2, ord($str) ) + 1 ) + SQL_FUNCTION_OCTET_LENGTH( @v, substr( $str, 1 ) ) * 8;
371             }
372              
373             =pod
374              
375             =head3 CHARACTER_LENGTH aka CHAR_LENGTH
376              
377             # purpose : find length in characters of a string
378             # arguments : a string
379             # returns : a number - the length of the string in characters
380              
381             =cut
382              
383             sub SQL_FUNCTION_CHAR_LENGTH
384             {
385 21     21 0 46 my ( $self, $owner, $str ) = @_;
386 21         74 return length($str);
387             }
388 17     17   137 no warnings 'once';
  17         51  
  17         911  
389             *SQL_FUNCTION_CHARACTER_LENGTH = \&SQL_FUNCTION_CHAR_LENGTH;
390 17     17   132 use warnings 'all';
  17         43  
  17         1768  
391              
392             =pod
393            
394             =head3 COALESCE aka NVL aka IFNULL
395            
396             # purpose : return the first non-NULL value from a list
397             # arguments : 1 or more expressions
398             # returns : the first expression (reading left to right)
399             # which is not NULL; returns NULL if all are NULL
400             #
401            
402             =cut
403              
404             sub SQL_FUNCTION_COALESCE
405             {
406 3     3 0 10 my ( $self, $owner, @params ) = @_;
407              
408             #
409             # eval each expr in list until a non-null
410             # is encountered, then return it
411             #
412 3         8 foreach (@params)
413             {
414 6 100       22 return $_
415             if defined($_);
416             }
417 0         0 return undef;
418             }
419 17     17   138 no warnings 'once';
  17         54  
  17         1065  
420             *SQL_FUNCTION_NVL = \&SQL_FUNCTION_COALESCE;
421             *SQL_FUNCTION_IFNULL = \&SQL_FUNCTION_COALESCE;
422 17     17   124 use warnings 'all';
  17         70  
  17         3960  
423              
424             =pod
425              
426             =head3 CONCAT
427              
428             # purpose : concatenate 1 or more strings into a single string;
429             # an alternative to the '||' operator
430             # arguments : 1 or more strings
431             # returns : the concatenated string
432             #
433             # example : SELECT CONCAT(first_string, 'this string', ' that string')
434             # returns "this string that string"
435             # note : if any argument evaluates to NULL, the returned value is NULL
436              
437             =cut
438              
439             sub SQL_FUNCTION_CONCAT
440             {
441 16     16 0 42 my ( $self, $owner, @params ) = @_;
442 16   100     83 ( defined || return undef ) for (@params);
443 15         73 return join '', @params;
444             }
445              
446             =pod
447              
448             =head3 CONV
449              
450             # purpose : convert a number X from base Y to base Z (from base 2 to 64)
451             # arguments : X (can by a number or string depending on the base), Y, Z (Z defaults to 10)
452             Valid bases for Y and Z are: 2, 8, 10, 16 and 64
453             # returns : either a string or number, in base Z
454             # notes : Behavioral table
455             #
456             # base | valuation
457             # ------+-----------
458             # 2 | binary, base 2 - (0,1)
459             # 8 | octal, base 8 - (0..7)
460             # 10 | decimal, base 10 - (0..9)
461             # 16 | hexadecimal, base 16 - (0..9,a..f)
462             # 64 | 0-63 from MIME::Base64
463             #
464              
465             =cut
466              
467             sub SQL_FUNCTION_CONV
468             {
469 23     23 0 74 my ( $self, $owner, $num, $sbase, $ebase ) = @_;
470              
471 23   100     80 $ebase ||= 10;
472 23   66     280 $_ and $_ != 2 and $_ != 8 and $_ != 10 and $_ != 16 and $_ != 64 and croak("Invalid base: $_") for ($sbase, $ebase);
      100        
      100        
      100        
      66        
      33        
473              
474 23         78 scalar use_module("Math::Base::Convert")->new($sbase, $ebase)->cnv($num);
475             }
476              
477             =pod
478              
479             =head3 DECODE
480              
481             # purpose : compare the first argument against
482             # succeeding arguments at position 1 + 2N
483             # (N = 0 to (# of arguments - 2)/2), and if equal,
484             # return the value of the argument at 1 + 2N + 1; if no
485             # arguments are equal, the last argument value is returned
486             # arguments : 4 or more expressions, must be even # of arguments
487             # returns : the value of the argument at 1 + 2N + 1 if argument 1 + 2N
488             # is equal to argument1; else the last argument value
489             #
490             # example : SELECT DECODE(some_column,
491             # 'first value', 'first value matched'
492             # '2nd value', '2nd value matched'
493             # 'no value matched'
494             # )
495              
496             =cut
497              
498             #
499             # emulate Oracle DECODE; behaves same as
500             # CASE expr WHEN THEN expr3
501             # WHEN expr4 THEN expr5
502             # ...
503             # ELSE exprN END
504             #
505             sub SQL_FUNCTION_DECODE
506             {
507 5     5 0 18 my ( $self, $owner, @params ) = @_;
508              
509             #
510             # check param list size, must be at least 4,
511             # and even in length
512             #
513 17     17   160 no warnings 'precedence';
  17         60  
  17         4130  
514 5 50 33     24 die 'Invalid DECODE argument list!' unless ( ( scalar @params > 3 ) && ( $#params & 1 == 1 ) );
515              
516             #
517             # eval first argument, and last argument,
518             # then eval and compare each succeeding pair of args
519             # be careful about NULLs!
520             #
521 5         12 my $lhs = shift @params;
522 5         9 my $default = pop @params;
523 5 50       11 return $default unless defined($lhs);
524 5         14 my $lhs_isnum = looks_like_number($lhs);
525              
526 5         12 while (@params)
527             {
528 7         12 my $rhs = shift @params;
529 7 50       14 shift @params, next
530             unless defined($rhs);
531             return shift @params
532 7 100 33     47 if ( ( looks_like_number($rhs) && $lhs_isnum && ( $lhs == $rhs ) )
      33        
      66        
533             || ( $lhs eq $rhs ) );
534 3         7 shift @params;
535             }
536 1         6 return $default;
537             }
538              
539             =pod
540              
541             =head3 INSERT
542              
543             # purpose : string where L characters have been deleted from STR1, beginning at S,
544             # and where STR2 has been inserted into STR1, beginning at S. NULL for any NULL args.
545             # arguments : STR1, S, L, STR2
546              
547             =cut
548              
549             sub SQL_FUNCTION_INSERT
550             { # just like a 4-parameter substr in Perl
551 4   100 4 0 29 ( defined || return undef ) for ( @_[ 2 .. 5 ] );
552 2         6 my $str = $_[2];
553 17     17   133 no warnings 'void';
  17         75  
  17         6639  
554 2         8 substr( $str, $_[3] - 1, $_[4], $_[5] );
555 2         9 return $str;
556             }
557              
558             =pod
559              
560             =head3 HEX & OCT & BIN
561              
562             # purpose : convert number X from decimal to hex/octal/binary; equiv. to CONV(X, 10, 16/8/2)
563             # arguments : X
564              
565             =cut
566              
567 1     1 0 6 sub SQL_FUNCTION_HEX { return shift->SQL_FUNCTION_CONV( @_[ 0 .. 1 ], 10, 16 ); }
568 1     1 0 7 sub SQL_FUNCTION_OCT { return shift->SQL_FUNCTION_CONV( @_[ 0 .. 1 ], 10, 8 ); }
569 1     1 0 7 sub SQL_FUNCTION_BIN { return shift->SQL_FUNCTION_CONV( @_[ 0 .. 1 ], 10, 2 ); }
570              
571             =pod
572              
573             =head3 LEFT & RIGHT
574              
575             # purpose : leftmost or rightmost L characters in STR, or NULL for any NULL args
576             # arguments : STR1, L
577              
578             =cut
579              
580             sub SQL_FUNCTION_LEFT
581             {
582 3   100 3 0 20 ( defined || return undef ) for ( @_[ 2 .. 3 ] );
583 1         5 return substr( $_[2], 0, $_[3] );
584             }
585              
586             sub SQL_FUNCTION_RIGHT
587             {
588 3   100 3 0 21 ( defined || return undef ) for ( @_[ 2 .. 3 ] );
589 1         7 return substr( $_[2], -$_[3] );
590             }
591              
592             =pod
593              
594             =head3 LOCATE aka POSITION
595              
596             # purpose : starting position (one-based) of the first occurrence of STR1
597             within STR2; 0 if it doesn't occur and NULL for any NULL args
598             # arguments : STR1, STR2, and an optional S (starting position to search)
599              
600             =cut
601              
602             sub SQL_FUNCTION_LOCATE
603             {
604 4   50 4 0 23 ( defined || return undef ) for ( @_[ 2 .. 3 ] );
605 4         14 my ( $self, $owner, $substr, $str, $s ) = @_;
606 4   100     15 $s = int( $s || 0 );
607 4         13 my $pos = index( substr( $str, $s ), $substr ) + 1;
608 4   33     23 return $pos && $pos + $s;
609             }
610 17     17   140 no warnings 'once';
  17         43  
  17         888  
611             *SQL_FUNCTION_POSITION = \&SQL_FUNCTION_LOCATE;
612 17     17   128 use warnings 'all';
  17         57  
  17         1814  
613              
614             =pod
615              
616             =head3 LOWER & UPPER aka LCASE & UCASE
617              
618             # purpose : lower-case or upper-case a string
619             # arguments : a string
620             # returns : the sting lower or upper cased
621              
622             =cut
623              
624             sub SQL_FUNCTION_LOWER
625             {
626 2     2 0 8 my ( $self, $owner, $str ) = @_;
627 2         9 return lc($str);
628             }
629              
630             sub SQL_FUNCTION_UPPER
631             {
632 17     17 0 43 my ( $self, $owner, $str ) = @_;
633 17         66 return uc($str);
634             }
635              
636 17     17   151 no warnings 'once';
  17         39  
  17         1148  
637             *SQL_FUNCTION_UCASE = \&SQL_FUNCTION_UPPER;
638             *SQL_FUNCTION_LCASE = \&SQL_FUNCTION_LOWER;
639 17     17   121 use warnings 'all';
  17         59  
  17         7605  
640              
641             =pod
642              
643             =head3 LTRIM & RTRIM
644              
645             # purpose : left/right counterparts for TRIM
646             # arguments : string
647              
648             =cut
649              
650             sub SQL_FUNCTION_LTRIM
651             {
652 1     1 0 4 my $str = $_[2];
653 1         6 $str =~ s/^\s+//;
654 1         5 return $str;
655             }
656              
657             sub SQL_FUNCTION_RTRIM
658             {
659 1     1 0 4 my $str = $_[2];
660 1         9 $str =~ s/\s+$//;
661 1         5 return $str;
662             }
663              
664             =pod
665              
666             =head3 OCTET_LENGTH
667              
668             # purpose : length of the string in bytes (not characters)
669             # arguments : string
670              
671             =cut
672              
673 5     5 0 25 sub SQL_FUNCTION_OCTET_LENGTH { return length( Encode::encode_utf8( $_[2] ) ); } # per Perldoc
674              
675             =pod
676              
677             =head3 REGEX
678              
679             # purpose : test if a string matches a perl regular expression
680             # arguments : a string and a regex to match the string against
681             # returns : boolean value of the regex match
682             #
683             # example : ... WHERE REGEX(col3,'/^fun/i') ... matches rows
684             # in which col3 starts with "fun", ignoring case
685              
686             =cut
687              
688             sub SQL_FUNCTION_REGEX
689             {
690 2     2 0 9 my ( $self, $owner, @params ) = @_;
691 2   50     13 ( defined || return 0 ) for ( @params[ 0 .. 1 ] );
692 2         16 my ( $pattern, $modifier ) = $params[1] =~ m~^/(.+)/([a-z]*)$~;
693 2 100       9 $pattern = "(?$modifier:$pattern)" if ($modifier);
694 2 100       54 return ( $params[0] =~ qr($pattern) ) ? 1 : 0;
695             }
696              
697             =pod
698              
699             =head3 REPEAT
700              
701             # purpose : string composed of STR1 repeated C times, or NULL for any NULL args
702             # arguments : STR1, C
703              
704             =cut
705              
706             sub SQL_FUNCTION_REPEAT
707             {
708 1   50 1 0 14 ( defined || return undef ) for ( @_[ 2 .. 3 ] );
709 1         8 return $_[2] x int( $_[3] );
710             }
711              
712             =pod
713              
714             =head3 REPLACE aka SUBSTITUTE
715              
716             # purpose : perform perl subsitution on input string
717             # arguments : a string and a substitute pattern string
718             # returns : the result of the substitute operation
719             #
720             # example : ... WHERE REPLACE(col3,'s/fun(\w+)nier/$1/ig') ... replaces
721             # all instances of /fun(\w+)nier/ in col3 with the string
722             # between 'fun' and 'nier'
723              
724             =cut
725              
726             sub SQL_FUNCTION_REPLACE
727             {
728 2     2 0 8 my ( $self, $owner, @params ) = @_;
729 2 50 33     12 return undef unless defined $params[0] and defined $params[1];
730              
731 2         241 eval "\$params[0]=~$params[1]";
732 2 50       20 return $@ ? undef : $params[0];
733             }
734 17     17   134 no warnings 'once';
  17         51  
  17         896  
735             *SQL_FUNCTION_SUBSTITUTE = \&SQL_FUNCTION_REPLACE;
736 17     17   107 use warnings 'all';
  17         40  
  17         12182  
737              
738             =pod
739              
740             =head3 SOUNDEX
741              
742             # purpose : test if two strings have matching soundex codes
743             # arguments : two strings
744             # returns : true if the strings share the same soundex code
745             #
746             # example : ... WHERE SOUNDEX(col3,'fun') ... matches rows
747             # in which col3 is a soundex match for "fun"
748              
749             =cut
750              
751             sub SQL_FUNCTION_SOUNDEX
752             {
753 2     2 0 8 my ( $self, $owner, @params ) = @_;
754 2         12 require_module("Text::Soundex");
755 2 50       78 my $s1 = Text::Soundex::soundex( $params[0] ) or return 0;
756 2 50       10 my $s2 = Text::Soundex::soundex( $params[1] ) or return 0;
757 2 100       10 return ( $s1 eq $s2 ) ? 1 : 0;
758             }
759              
760             =pod
761              
762             =head3 SPACE
763              
764             # purpose : a string of spaces
765             # arguments : number of spaces
766              
767             =cut
768              
769 1     1 0 7 sub SQL_FUNCTION_SPACE { return ' ' x int( $_[2] ); }
770              
771             =pod
772              
773             =head3 SUBSTRING
774              
775             SUBSTRING( string FROM start_pos [FOR length] )
776              
777             Returns the substring starting at start_pos and extending for
778             "length" character or until the end of the string, if no
779             "length" is supplied. Examples:
780              
781             SUBSTRING( 'foobar' FROM 4 ) # returns "bar"
782              
783             SUBSTRING( 'foobar' FROM 4 FOR 2) # returns "ba"
784              
785             Note: The SUBSTRING function is implemented in L and L and, at the current time, can not be over-ridden.
786              
787             =head3 SUBSTR
788              
789             # purpose : same as SUBSTRING, except with comma-delimited params, instead of
790             words (NULL for any NULL args)
791             # arguments : string, start_pos, [length]
792              
793             =cut
794              
795             sub SQL_FUNCTION_SUBSTR
796             {
797 1     1 0 6 my ( $self, $owner, @params ) = @_;
798 1   50     10 ( defined || return undef ) for ( @params[ 0 .. 2 ] );
799 1   50     4 my $string = $params[0] || '';
800 1   50     5 my $start = $params[1] || 0;
801 1   33     5 my $offset = $params[2] || length $string;
802 1         2 my $value = '';
803 1 50       7 $value = substr( $string, $start - 1, $offset )
804             if length $string >= $start - 2 + $offset;
805 1         5 return $value;
806             }
807              
808             =pod
809              
810             =head3 TRANSLATE
811              
812             # purpose : transliteration; replace a set of characters in a string with another
813             set of characters (a la tr///), or NULL for any NULL args
814             # arguments : string, string to replace, replacement string
815              
816             =cut
817              
818             sub SQL_FUNCTION_TRANSLATE
819             {
820 1     1 0 5 my ( $self, $owner, $str, $oldlist, $newlist ) = @_;
821 1         3 $oldlist =~ s{(/\-)}{\\$1}g;
822 1         3 $newlist =~ s{(/\-)}{\\$1}g;
823 1         74 eval "\$str =~ tr/$oldlist/$newlist/";
824 1         6 return $str;
825             }
826              
827             =pod
828              
829             =head3 TRIM
830              
831             TRIM ( [ [LEADING|TRAILING|BOTH] ['trim_char'] FROM ] string )
832              
833             Removes all occurrences of from the front, back, or
834             both sides of a string.
835              
836             BOTH is the default if neither LEADING nor TRAILING is specified.
837              
838             Space is the default if no trim_char is specified.
839              
840             Examples:
841              
842             TRIM( string )
843             trims leading and trailing spaces from string
844              
845             TRIM( LEADING FROM str )
846             trims leading spaces from string
847              
848             TRIM( 'x' FROM str )
849             trims leading and trailing x's from string
850              
851             Note: The TRIM function is implemented in L and L and, at the current time, can not be over-ridden.
852              
853             =pod
854              
855             =head3 UNHEX
856              
857             # purpose : convert each pair of hexadecimal digits to a byte (or a Unicode character)
858             # arguments : string of hex digits, with an optional encoding name of the data string
859              
860             =cut
861              
862             sub SQL_FUNCTION_UNHEX
863             {
864 2     2 0 9 my ( $self, $owner, $hex, $encoding ) = @_;
865 2 50       9 return undef unless ( defined $hex );
866              
867 2         6 $hex =~ s/\s+//g;
868 2         5 $hex =~ s/[^0-9a-fA-F]+//g;
869              
870 2         5 my $str = '';
871 2         10 foreach my $i ( 0 .. int( ( length($hex) - 1 ) / 2 ) )
872             {
873 9         3037 $str .= pack( 'C', SQL_FUNCTION_CONV( $self, $owner, substr( $hex, $i * 2, 2 ), 16, 10 ) );
874             }
875 2 100       917 return $encoding ? Encode::decode( $encoding, $str, Encode::FB_WARN ) : $str;
876             }
877              
878             =head2 Numeric Functions
879              
880             =head3 ABS
881              
882             # purpose : find the absolute value of a given numeric expression
883             # arguments : numeric expression
884              
885             =cut
886              
887 1     1 0 5 sub SQL_FUNCTION_ABS { return abs( $_[2] ); }
888              
889             =pod
890              
891             =head3 CEILING (aka CEIL) & FLOOR
892              
893             # purpose : rounds up/down to the nearest integer
894             # arguments : numeric expression
895              
896             =cut
897              
898             sub SQL_FUNCTION_CEILING
899             {
900 3     3 0 11 my $i = int( $_[2] );
901 3 100       20 return $i == $_[2] ? $i : SQL_FUNCTION_ROUND( @_[ 0 .. 1 ], $_[2] + 0.5, 0 );
902             }
903              
904             sub SQL_FUNCTION_FLOOR
905             {
906 5     5 0 15 my $i = int( $_[2] );
907 5 100       25 return $i == $_[2] ? $i : SQL_FUNCTION_ROUND( @_[ 0 .. 1 ], $_[2] - 0.5, 0 );
908             }
909 17     17   151 no warnings 'once';
  17         38  
  17         877  
910             *SQL_FUNCTION_CEIL = \&SQL_FUNCTION_CEILING;
911 17     17   122 use warnings 'all';
  17         45  
  17         4012  
912              
913             =pod
914              
915             =head3 EXP
916              
917             # purpose : raise e to the power of a number
918             # arguments : numeric expression
919              
920             =cut
921              
922 1     1 0 9 sub SQL_FUNCTION_EXP { return ( sinh(1) + cosh(1) )**$_[2]; } # e = sinh(X)+cosh(X)
923              
924             =pod
925              
926             =head3 LOG
927              
928             # purpose : base B logarithm of X
929             # arguments : B, X or just one argument of X for base 10
930              
931             =cut
932              
933 5 100   5 0 56 sub SQL_FUNCTION_LOG { return $_[3] ? log( $_[3] ) / log( $_[2] ) : log( $_[2] ) / log(10); }
934              
935             =pod
936              
937             =head3 LN & LOG10
938              
939             # purpose : natural logarithm (base e) or base 10 of X
940             # arguments : numeric expression
941              
942             =cut
943              
944 1     1 0 8 sub SQL_FUNCTION_LN { return log( $_[2] ); }
945 0     0 0 0 sub SQL_FUNCTION_LOG10 { return SQL_FUNCTION_LOG( @_[ 0 .. 2 ] ); }
946              
947             =pod
948              
949             =head3 MOD
950              
951             # purpose : modulus, or remainder, left over from dividing X / Y
952             # arguments : X, Y
953              
954             =cut
955              
956 1     1 0 10 sub SQL_FUNCTION_MOD { return $_[2] % $_[3]; }
957              
958             =pod
959              
960             =head3 POWER aka POW
961              
962             # purpose : X to the power of Y
963             # arguments : X, Y
964              
965             =cut
966              
967 2     2 0 9 sub SQL_FUNCTION_POWER { return $_[2]**$_[3]; }
968 17     17   131 no warnings 'once';
  17         54  
  17         830  
969             *SQL_FUNCTION_POW = \&SQL_FUNCTION_POWER;
970 17     17   161 use warnings 'all';
  17         44  
  17         3889  
971              
972             =pod
973              
974             =head3 RAND
975              
976             # purpose : random fractional number greater than or equal to 0 and less than the value of X
977             # arguments : X (with optional seed value of Y)
978              
979             =cut
980              
981 2 50   2 0 9 sub SQL_FUNCTION_RAND { $_[3] && srand( $_[3] ); return rand( $_[2] ); }
  2         17  
982              
983             =pod
984              
985             =head3 ROUND
986              
987             # purpose : round X with Y number of decimal digits (precision)
988             # arguments : X, optional Y defaults to 0
989              
990             =cut
991              
992 8 100   8 0 79 sub SQL_FUNCTION_ROUND { return sprintf( "%.*f", $_[3] ? int( $_[3] ) : 0, $_[2] ); }
993              
994             =pod
995              
996             =head3 SIGN
997              
998             # purpose : returns -1, 0, 1, NULL for negative, 0, positive, NULL values, respectively
999             # arguments : numeric expression
1000              
1001             =cut
1002              
1003 4 100   4 0 24 sub SQL_FUNCTION_SIGN { return defined( $_[2] ) ? ( $_[2] <=> 0 ) : undef; }
1004              
1005             =pod
1006              
1007             =head3 SQRT
1008              
1009             # purpose : square root of X
1010             # arguments : X
1011              
1012             =cut
1013              
1014 1     1 0 7 sub SQL_FUNCTION_SQRT { return sqrt( $_[2] ); }
1015              
1016             =pod
1017              
1018             =head3 TRUNCATE aka TRUNC
1019              
1020             # purpose : similar to ROUND, but removes the decimal
1021             # arguments : X, optional Y defaults to 0
1022              
1023             =cut
1024              
1025             sub SQL_FUNCTION_TRUNCATE
1026             {
1027 4   100 4 0 22 my $c = int( $_[3] || 0 );
1028 4         10 my $d = 10**$c;
1029 4         60 return sprintf( "%.*f", $c, int( $_[2] * $d ) / $d );
1030             }
1031 17     17   132 no warnings 'once';
  17         51  
  17         845  
1032             *SQL_FUNCTION_TRUNC = \&SQL_FUNCTION_TRUNCATE;
1033 17     17   106 use warnings 'all';
  17         75  
  17         22745  
1034              
1035             =pod
1036              
1037             =head2 Trigonometric Functions
1038              
1039             All of these functions work exactly like their counterparts in L; go there for documentation.
1040              
1041             =cut
1042              
1043             =over
1044              
1045             =item ACOS
1046              
1047             =item ACOSEC
1048              
1049             =item ACOSECH
1050              
1051             =item ACOSH
1052              
1053             =item ACOT
1054              
1055             =item ACOTAN
1056              
1057             =item ACOTANH
1058              
1059             =item ACOTH
1060              
1061             =item ACSC
1062              
1063             =item ACSCH
1064              
1065             =item ASEC
1066              
1067             =item ASECH
1068              
1069             =item ASIN
1070              
1071             =item ASINH
1072              
1073             =item ATAN
1074              
1075             =item ATANH
1076              
1077             =item COS
1078              
1079             =item COSEC
1080              
1081             =item COSECH
1082              
1083             =item COSH
1084              
1085             =item COT
1086              
1087             =item COTAN
1088              
1089             =item COTANH
1090              
1091             =item COTH
1092              
1093             =item CSC
1094              
1095             =item CSCH
1096              
1097             =item SEC
1098              
1099             =item SECH
1100              
1101             =item SIN
1102              
1103             =item SINH
1104              
1105             =item TAN
1106              
1107             =item TANH
1108              
1109             Takes a single parameter. All of L's aliases are included.
1110              
1111             =item ATAN2
1112              
1113             The y,x version of arc tangent.
1114              
1115             =item DEG2DEG
1116              
1117             =item DEG2GRAD
1118              
1119             =item DEG2RAD
1120              
1121             Converts out-of-bounds values into its correct range.
1122              
1123             =item GRAD2DEG
1124              
1125             =item GRAD2GRAD
1126              
1127             =item GRAD2RAD
1128              
1129             =item RAD2DEG
1130              
1131             =item RAD2GRAD
1132              
1133             =item RAD2RAD
1134              
1135             Like their L's counterparts, accepts an optional 2nd boolean parameter (like B) to keep prevent range wrapping.
1136              
1137             =item DEGREES
1138              
1139             =item RADIANS
1140              
1141             B and B are included for SQL-92 compatibility, and map to B and B, respectively.
1142              
1143             =item PI
1144              
1145             B can be used without parentheses.
1146              
1147             =back
1148              
1149             =cut
1150              
1151 1   50 1 0 10 sub SQL_FUNCTION_ACOS { return acos( $_[2] || 0 ); }
1152 1   50 1 0 11 sub SQL_FUNCTION_ACOSEC { return acosec( $_[2] || 0 ); }
1153 1   50 1 0 8 sub SQL_FUNCTION_ACOSECH { return acosech( $_[2] || 0 ); }
1154 1   50 1 0 8 sub SQL_FUNCTION_ACOSH { return acosh( $_[2] || 0 ); }
1155 1   50 1 0 25 sub SQL_FUNCTION_ACOT { return acot( $_[2] || 0 ); }
1156 1   50 1 0 10 sub SQL_FUNCTION_ACOTAN { return acotan( $_[2] || 0 ); }
1157 1   50 1 0 8 sub SQL_FUNCTION_ACOTANH { return acotanh( $_[2] || 0 ); }
1158 1   50 1 0 8 sub SQL_FUNCTION_ACOTH { return acoth( $_[2] || 0 ); }
1159 1   50 1 0 8 sub SQL_FUNCTION_ACSC { return acsc( $_[2] || 0 ); }
1160 2   50 2 0 14 sub SQL_FUNCTION_ACSCH { return acsch( $_[2] || 0 ); }
1161 1   50 1 0 11 sub SQL_FUNCTION_ASEC { return asec( $_[2] || 0 ); }
1162 1   50 1 0 10 sub SQL_FUNCTION_ASECH { return asech( $_[2] || 0 ); }
1163 1   50 1 0 13 sub SQL_FUNCTION_ASIN { return asin( $_[2] || 0 ); }
1164 1   50 1 0 10 sub SQL_FUNCTION_ASINH { return asinh( $_[2] || 0 ); }
1165 1   50 1 0 18 sub SQL_FUNCTION_ATAN { return atan( $_[2] || 0 ); }
1166 3   50 3 0 53 sub SQL_FUNCTION_ATAN2 { return atan2( $_[2] || 0, $_[3] || 0 ); }
      100        
1167 1   50 1 0 9 sub SQL_FUNCTION_ATANH { return atanh( $_[2] || 0 ); }
1168 1   50 1 0 11 sub SQL_FUNCTION_COS { return cos( $_[2] || 0 ); }
1169 1   50 1 0 8 sub SQL_FUNCTION_COSEC { return cosec( $_[2] || 0 ); }
1170 1   50 1 0 9 sub SQL_FUNCTION_COSECH { return cosech( $_[2] || 0 ); }
1171 1   50 1 0 9 sub SQL_FUNCTION_COSH { return cosh( $_[2] || 0 ); }
1172 1   50 1 0 17 sub SQL_FUNCTION_COT { return cot( $_[2] || 0 ); }
1173 1   50 1 0 9 sub SQL_FUNCTION_COTAN { return cotan( $_[2] || 0 ); }
1174 1   50 1 0 9 sub SQL_FUNCTION_COTANH { return cotanh( $_[2] || 0 ); }
1175 5   50 5 0 27 sub SQL_FUNCTION_COTH { return coth( $_[2] || 0 ); }
1176 1   50 1 0 8 sub SQL_FUNCTION_CSC { return csc( $_[2] || 0 ); }
1177 3   50 3 0 20 sub SQL_FUNCTION_CSCH { return csch( $_[2] || 0 ); }
1178 0   0 0 0 0 sub SQL_FUNCTION_DEG2DEG { return deg2deg( $_[2] || 0 ); }
1179 0   0 0 0 0 sub SQL_FUNCTION_RAD2RAD { return rad2rad( $_[2] || 0 ); }
1180 0   0 0 0 0 sub SQL_FUNCTION_GRAD2GRAD { return grad2grad( $_[2] || 0 ); }
1181 1   50 1 0 13 sub SQL_FUNCTION_DEG2GRAD { return deg2grad( $_[2] || 0, $_[3] || 0 ); }
      50        
1182 2   50 2 0 23 sub SQL_FUNCTION_DEG2RAD { return deg2rad( $_[2] || 0, $_[3] || 0 ); }
      50        
1183 1   50 1 0 12 sub SQL_FUNCTION_DEGREES { return rad2deg( $_[2] || 0, $_[3] || 0 ); }
      50        
1184 1   50 1 0 13 sub SQL_FUNCTION_GRAD2DEG { return grad2deg( $_[2] || 0, $_[3] || 0 ); }
      50        
1185 1   50 1 0 12 sub SQL_FUNCTION_GRAD2RAD { return grad2rad( $_[2] || 0, $_[3] || 0 ); }
      50        
1186 5     5 0 18 sub SQL_FUNCTION_PI { return pi; }
1187 3   50 3 0 29 sub SQL_FUNCTION_RAD2DEG { return rad2deg( $_[2] || 0, $_[3] || 0 ); }
      50        
1188 2   50 2 0 19 sub SQL_FUNCTION_RAD2GRAD { return rad2grad( $_[2] || 0, $_[3] || 0 ); }
      50        
1189 1   50 1 0 12 sub SQL_FUNCTION_RADIANS { return deg2rad( $_[2] || 0, $_[3] || 0 ); }
      50        
1190 1   50 1 0 9 sub SQL_FUNCTION_SEC { return sec( $_[2] || 0 ); }
1191 3   50 3 0 22 sub SQL_FUNCTION_SECH { return sech( $_[2] || 0 ); }
1192 1   50 1 0 12 sub SQL_FUNCTION_SIN { return sin( $_[2] || 0 ); }
1193 2   50 2 0 21 sub SQL_FUNCTION_SINH { return sinh( $_[2] || 0 ); }
1194 2   50 2 0 29 sub SQL_FUNCTION_TAN { return tan( $_[2] || 0 ); }
1195 5   50 5 0 33 sub SQL_FUNCTION_TANH { return tanh( $_[2] || 0 ); }
1196              
1197             =head2 System Functions
1198              
1199             =head3 DBNAME & USERNAME (aka USER)
1200              
1201             # purpose : name of the database / username
1202             # arguments : none
1203              
1204             =cut
1205              
1206 1     1 0 7 sub SQL_FUNCTION_DBNAME { return $_[1]->{Database}{Name}; }
1207 2     2 0 8 sub SQL_FUNCTION_USERNAME { return $_[1]->{Database}{CURRENT_USER}; }
1208 17     17   136 no warnings 'once';
  17         51  
  17         902  
1209             *SQL_FUNCTION_USER = \&SQL_FUNCTION_USERNAME;
1210 17     17   128 use warnings 'all';
  17         40  
  17         9667  
1211              
1212             =head2 Special Utility Functions
1213              
1214             =head3 IMPORT
1215              
1216             CREATE TABLE foo AS IMPORT(?) ,{},$external_executed_sth
1217             CREATE TABLE foo AS IMPORT(?) ,{},$AoA
1218              
1219             =cut
1220              
1221             sub SQL_FUNCTION_IMPORT
1222             {
1223 2     2 0 5 my ( $self, $owner, @params ) = @_;
1224 2 50       8 if ( _ARRAY0( $params[0] ) )
    0          
1225             {
1226 2 100       11 return $params[0] unless ( _HASH0( $params[0]->[0] ) );
1227 1         3 my @tbl = ();
1228 1         2 for my $row ( @{ $params[0] } )
  1         4  
1229             {
1230 2         4 my @cols = sort keys %{$row};
  2         9  
1231 2 100       8 push @tbl, \@cols unless @tbl;
1232 2         7 push @tbl, [ @$row{@cols} ];
1233             }
1234 1         5 return \@tbl;
1235             }
1236             elsif ( _INSTANCE( $params[0], 'DBI::st' ) )
1237             {
1238 0           my @cols;
1239 0 0         @cols = @{ $params[0]->{NAME} } unless @cols;
  0            
1240              
1241             # push @{$sth->{org_names}},$_ for @cols;
1242 0           my $tbl = [ \@cols ];
1243 0           while ( my @row = $params[0]->fetchrow_array() )
1244             {
1245 0           push @$tbl, \@row;
1246             }
1247              
1248 0           return $tbl;
1249             }
1250             }
1251              
1252             =head3 RUN
1253              
1254             Takes the name of a file containing SQL statements and runs the statements; see
1255             L for documentation.
1256              
1257             =cut
1258              
1259             sub SQL_FUNCTION_RUN
1260             {
1261 0     0 0   my ( $self, $owner, $file ) = @_;
1262 0           my @params = $owner->{sql_stmt}->params();
1263 0 0         @params = () unless @params;
1264 0           local *IN;
1265 0 0         open( IN, '<', $file ) or die "Couldn't open SQL File '$file': $!\n";
1266 0           my @stmts = split /;\s*\n+/, join '', ;
1267 0           $stmts[-1] =~ s/;\s*$//;
1268 0           close IN;
1269 0           my @results = ();
1270              
1271 0           for my $sql (@stmts)
1272             {
1273 0           my $tmp_sth = $owner->{Database}->prepare($sql);
1274 0           $tmp_sth->execute(@params);
1275 0 0         next unless $tmp_sth->{NUM_OF_FIELDS};
1276 0 0         push @results, $tmp_sth->{NAME} unless @results;
1277 0           while ( my @r = $tmp_sth->fetchrow_array() ) { push @results, \@r }
  0            
1278             }
1279              
1280             #use Data::Dumper; print Dumper \@results and exit if @results;
1281 0           return \@results;
1282             }
1283              
1284             =pod
1285              
1286             =head1 Submitting built-in functions
1287              
1288             If you make a generally useful UDF, why not submit it to me and have it (and your name) included with the built-in functions? Please follow the format shown in the module including a description of the arguments and return values for the function as well as an example. Send them to the dbi-dev@perl.org mailing list (see L).
1289              
1290             Thanks in advance :-).
1291              
1292             =head1 ACKNOWLEDGEMENTS
1293              
1294             Dean Arnold supplied DECODE, COALESCE, REPLACE, many thanks!
1295             Brendan Byrd added in the Numeric/Trig/System functions and filled in the SQL92/ODBC gaps for the date/string functions.
1296              
1297             =head1 AUTHOR & COPYRIGHT
1298              
1299             Copyright (c) 2005 by Jeff Zucker: jzuckerATcpan.org
1300             Copyright (c) 2009-2020 by Jens Rehsack: rehsackATcpan.org
1301              
1302             All rights reserved.
1303              
1304             The module may be freely distributed under the same terms as
1305             Perl itself using either the "GPL License" or the "Artistic
1306             License" as specified in the Perl README file.
1307              
1308             =cut
1309              
1310             1;