← Back to branch summary

~starbuggers/sakila-server/mysql-5.1-wl820

« back to all changes in this revision

Viewing changes to plugin/perl_udf/MySQLUDF.pm

  • Committer: Antony T Curtis
  • Date: 2008-04-10 06:09:05 UTC
  • mto: (2542.76.4 mysql-5.1-wl820)
  • mto: This revision was merged to the branch mainline in revision 2772.
  • Revision ID: antony@anubis.xiphis.org-20080410060905-itpom5iyz8ae4dhh
Initial import into Bazaar repository

Show diffs side-by-side

added added

removed removed

Lines of Context:
plugin/perl_udf/MySQLUDF.pm
 
1
package MySQLUDF;
 
2
 
 
3
use 5.008008;
 
4
use strict;
 
5
use warnings;
 
6
use Symbol qw(delete_package);
 
7
 
 
8
require Exporter;
 
9
 
 
10
our @ISA = qw(Exporter);
 
11
 
 
12
# Items to export into callers namespace by default. Note: do not export
 
13
# names by default without a very good reason. Use EXPORT_OK instead.
 
14
# Do not simply export all your public functions/methods/constants.
 
15
 
 
16
# This allows declaration       use MySQLUDF ':all';
 
17
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
 
18
# will save memory.
 
19
our %EXPORT_TAGS = ( 'all' => [ qw(
 
20
 
 
21
) ] );
 
22
 
 
23
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 
24
 
 
25
our @EXPORT = qw(
 
26
 
 
27
);
 
28
 
 
29
our $VERSION = '0.01';
 
30
 
 
31
require XSLoader;
 
32
XSLoader::load('MySQLUDF', $VERSION);
 
33
 
 
34
our %Cache;
 
35
 
 
36
# Preloaded methods go here.
 
37
 
 
38
sub valid_package_name
 
39
{
 
40
  my($string)= @_;
 
41
  $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 
42
  # second pass only for words starting with a digit
 
43
  $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 
44
  # Dress it up as a real package name
 
45
  $string =~ s|/|::|g;
 
46
  return "MyUDF" . $string;
 
47
}
 
48
 
 
49
 
 
50
 
 
51
sub load_func {
 
52
  my ($filename,$funcname)= @_;
 
53
  my $package= valid_package_name($filename);
 
54
  if (!defined $Cache{$package})
 
55
  {
 
56
    my $handler= eval
 
57
      "package $package;".
 
58
      'my (%filename,$package,$mtime,$funcname);'.
 
59
      "require $filename;".
 
60
      'sub handler'.
 
61
      '{my($func)=shift;'.
 
62
      'die "not found" if eval "!defined &'.$filename.'::$func";'.
 
63
      'my $function= eval \'\\&'.$filename.'::\'.$func;'.
 
64
      'die "unknown error" if !defined $function;'.
 
65
      'my $prototype= prototype $function;'.
 
66
      'my @ref= ($function, $prototype);'.
 
67
      'return \@ref;'.
 
68
      '} return \&'.$package.'::handler;';
 
69
    die $@ if $@;
 
70
    $Cache{$package}= $handler;
 
71
  }
 
72
  my $func= $Cache{$package}->($funcname);
 
73
  return $func;
 
74
}
 
75
 
 
76
sub find_udf_routine
 
77
{
 
78
  my $udf_name= shift;
 
79
  die "unknown error" if !defined $udf_name;
 
80
  die "bad routine name" if !($udf_name=~ m/::([^:]+)$/);
 
81
  my ($filename, $funcname)= ($`,$1);
 
82
  return load_func($filename,$funcname);
 
83
}
 
84
 
 
85
 
 
86
sub get_args
 
87
{
 
88
  my $context= shift;
 
89
  my @values= ();
 
90
  
 
91
  my $arg_count= $context->get_arg_count();
 
92
  my $idx;
 
93
 
 
94
  for ($idx= 0; $idx < $arg_count; $idx++)
 
95
  {  
 
96
    my $arg= undef;
 
97
    $arg= $context->val_string($idx) if !($context->val_null($idx));
 
98
    push @values, $arg;
 
99
  }
 
100
  return @values;
 
101
}
 
102
 
 
103
sub handle_arg
 
104
{
 
105
  my ($prototype,$parameters,$references,$arguments,$index)= @_;
 
106
 
 
107
  if ('\$' eq $prototype)
 
108
  {
 
109
    my $value= $arguments->[$index];
 
110
    push @$references,$index;
 
111
    push @$parameters, \$value;
 
112
    $arguments->[$index++]= \$value;
 
113
  }
 
114
  elsif ('$' eq $prototype)
 
115
  {
 
116
    push @$parameters, $arguments->[$index++];
 
117
  }
 
118
  elsif ('\@' eq $prototype)
 
119
  {
 
120
    while ($index < scalar @$arguments)
 
121
    {
 
122
      push @$references,$index;
 
123
      push @$parameters, $arguments->[$index++];
 
124
    }
 
125
  }
 
126
  elsif ('@' eq $prototype)
 
127
  {
 
128
    while ($index < scalar @$arguments)
 
129
    {
 
130
      push @$parameters, $arguments->[$index++];
 
131
    }
 
132
  }
 
133
  else
 
134
  {
 
135
    die "Unsupported argument type in routine prototype"
 
136
  }
 
137
  return $index;
 
138
}
 
139
 
 
140
sub make_args
 
141
{
 
142
  my ($prototype,$arguments,$references)= @_;
 
143
  my @parameters= ();
 
144
  my $index= 0;
 
145
 
 
146
  while ( $prototype=~ m/\G(\\?[\$\@\%\&\*])/g )
 
147
  {
 
148
    die 'Insufficient number of parameters' if $index >= scalar @$arguments;
 
149
    $index= handle_arg($1, \@parameters, $references, $arguments, $index);
 
150
  }
 
151
 
 
152
  if ($prototype=~ m/;/)
 
153
  {
 
154
    $prototype= $';
 
155
    while ( $prototype=~ m/\G(\\?[\$\@\%\&\*])/g )
 
156
    {
 
157
      last if $index >= scalar @$arguments;
 
158
      $index= handle_arg($1, \@parameters, $references, $arguments, $index);
 
159
    }
 
160
  }
 
161
 
 
162
  # For now, just shove the surplus arguments on the stack
 
163
  while ($index < scalar @$arguments)
 
164
  {
 
165
    push @parameters, $arguments->[$index++];
 
166
  }
 
167
 
 
168
  return \@parameters;
 
169
}
 
170
 
 
171
sub send_elem($$;$)
 
172
{
 
173
  my ($context,$elem,$idx)= @_;
 
174
  $idx=-1 if !defined $idx;
 
175
  $elem= $$elem while 'SCALAR' eq ref $elem;
 
176
  return $context->store_string($idx,"$elem") if defined $elem;
 
177
  return $context->store_null($idx);
 
178
}
 
179
 
 
180
sub send_row
 
181
{
 
182
  my ($context,$cols,$row)= @_;
 
183
  $context->row_prepare();
 
184
  foreach (@$cols)
 
185
  {
 
186
    return 1 if
 
187
    send_elem($context,$row->{$_});
 
188
  }
 
189
  return $context->row_send();
 
190
}
 
191
 
 
192
sub gather_columns
 
193
{
 
194
  my ($result,$row)= @_;
 
195
  foreach (keys %$row)
 
196
  {
 
197
    my $elem= $row->{$_};
 
198
    my $length= length "$elem";
 
199
    next if (defined $result->{$_}) && ($length < $result->{$_});
 
200
    $result->{$_}= $length;
 
201
  } 
 
202
  return $result;
 
203
}
 
204
 
 
205
 
 
206
sub allref
 
207
{
 
208
  my ($data,$type)= @_;
 
209
  my $idx;
 
210
  for ($idx= 0; $idx < scalar @$data; $idx++)
 
211
  {
 
212
    return 0 if $type ne ref $data->[$idx];
 
213
  }
 
214
  return 1;
 
215
}
 
216
 
 
217
sub send_resultset($$;$)
 
218
{
 
219
  my ($context,$result,$cols)= @_;
 
220
  my $columns= {};
 
221
  my $idx;
 
222
  for ($idx= 0; $idx < scalar @$result; $idx++)
 
223
  {
 
224
    $columns= gather_columns($columns, $result->[$idx]);
 
225
  }
 
226
  if (!defined $cols)
 
227
  {
 
228
    my @sorted_cols= sort keys %$columns;
 
229
    $cols= \@sorted_cols;
 
230
  }
 
231
  foreach (@$cols)
 
232
  {
 
233
    die "Unable to send column specifications" if
 
234
    $context->row_field("$_", 254, $columns->{$_});
 
235
  }
 
236
  for ($idx= 0; $idx < scalar @$result; $idx++)
 
237
  {
 
238
    die "Failed to send row result" if
 
239
    send_row($context,$cols,$result->[$idx]);
 
240
  }
 
241
  $context->row_send_eof();
 
242
}
 
243
 
 
244
sub exec_udf_routine
 
245
{
 
246
  my $context= shift;
 
247
  my $func= shift;
 
248
  
 
249
  die "undefined context" if !defined $context;
 
250
  die "undefined function" if !defined $func;
 
251
 
 
252
  my @arguments= get_args($context);
 
253
  my $result= undef;
 
254
  
 
255
  if (defined $func->[1]) 
 
256
  {
 
257
    my @references= ();
 
258
    my $parameters= make_args($func->[1], \@arguments, \@references);
 
259
 
 
260
    $result= $func->[0]->(@$parameters);
 
261
 
 
262
    # If the prototype contains references, then we need 
 
263
    # to return values back to the caller.
 
264
    
 
265
    foreach (@references)
 
266
    {
 
267
      die "Failed to store back parameter $_" if
 
268
      send_elem($context, $arguments[$_], $_);
 
269
    }
 
270
  }
 
271
  else
 
272
  {
 
273
    # We don't have a function prototype so assume the
 
274
    # simple case of a simple function call...
 
275
    $result= $func->[0]->(@arguments);
 
276
  }
 
277
 
 
278
  if (defined $result)
 
279
  {
 
280
    if ('HASH' eq ref $result)
 
281
    {
 
282
      my $columns= {};
 
283
      $columns= gather_columns($columns, $result);
 
284
      my @cols= sort keys %$columns;      
 
285
      foreach (@cols)
 
286
      {
 
287
        die "Unable to send column specifications" if
 
288
        $context->row_field("$_", 254, $columns->{$_});
 
289
      }
 
290
      die "Failed to send row result" if
 
291
      send_row($context,\@cols,$result);
 
292
      $context->row_send_eof();
 
293
    }
 
294
    elsif (('ARRAY' eq ref $result) && allref($result,'HASH'))
 
295
    {
 
296
      send_resultset($context, $result);
 
297
    }
 
298
    elsif (('ARRAY' eq ref $result) && allref($result,'ARRAY'))
 
299
    {
 
300
      my @resultset= ();
 
301
      my @columns= ();
 
302
      my $idx;
 
303
      for ($idx=0; $idx < scalar @$result; $idx++)
 
304
      {
 
305
        my $source= $result->[$idx];
 
306
        my %row= ();
 
307
          my $col;
 
308
        for ($col=0; $col < scalar @$source; $col++)
 
309
        {
 
310
          $row{$col}= $source->[$col];
 
311
        }
 
312
        while (scalar @columns < scalar @$source)
 
313
        {
 
314
          push @columns, scalar @columns;
 
315
        }
 
316
        push @resultset, \%row;
 
317
      }
 
318
      send_resultset($context, \@resultset, \@columns);
 
319
    }
 
320
    elsif ('ARRAY' eq ref $result)
 
321
    {
 
322
      my @resultset= ();
 
323
      my @columns= ();
 
324
      my %hash_result= ();
 
325
      my $idx;
 
326
      for ($idx=0; $idx < scalar @$result; $idx++)
 
327
      {
 
328
        $hash_result{$idx}= $result->[$idx];
 
329
        push @columns, $idx;
 
330
      }
 
331
      push @resultset, \%hash_result;
 
332
      send_resultset($context, \@resultset, \@columns);
 
333
    }    
 
334
    else
 
335
    {
 
336
      die "Unable to store result" if
 
337
      $context->store_string(-1, "$result");
 
338
    }
 
339
  }
 
340
  else
 
341
  {
 
342
    # we ignore any error result here because we may be
 
343
    # called as a procedure with no resultsets
 
344
    $context->store_null(-1);
 
345
  }
 
346
  
 
347
  return 1;
 
348
}
 
349
 
 
350
 
 
351
sub test_dbd_mysql()
 
352
{
 
353
  return eval 'require DBD::mysql;1';
 
354
}
 
355
 
 
356
1;
 
357
__END__
 
358
# Below is stub documentation for your module. You'd better edit it!
 
359
 
 
360
=head1 NAME
 
361
 
 
362
MySQLUDF - Perl extension for blah blah blah
 
363
 
 
364
=head1 SYNOPSIS
 
365
 
 
366
  use MySQLUDF;
 
367
  blah blah blah
 
368
 
 
369
=head1 DESCRIPTION
 
370
 
 
371
Stub documentation for MySQLUDF, created by h2xs. It looks like the
 
372
author of the extension was negligent enough to leave the stub
 
373
unedited.
 
374
 
 
375
Blah blah blah.
 
376
 
 
377
=head2 EXPORT
 
378
 
 
379
None by default.
 
380
 
 
381
 
 
382
 
 
383
=head1 SEE ALSO
 
384
 
 
385
Mention other useful documentation such as the documentation of
 
386
related modules or operating system documentation (such as man pages
 
387
in UNIX), or any relevant external documentation such as RFCs or
 
388
standards.
 
389
 
 
390
If you have a mailing list set up for your module, mention it here.
 
391
 
 
392
If you have a web site set up for your module, mention it here.
 
393
 
 
394
=head1 AUTHOR
 
395
 
 
396
Antony T Curtis, E<lt>antony@mysql.comE<gt>
 
397
     
 
398
=head1 COPYRIGHT AND LICENSE
 
399
 
 
400
Copyright (C) 2007 MySQL AB
 
401
 
 
402
This program is free software; you can redistribute it and/or modify
 
403
it under the terms of the GNU General Public License as published by
 
404
the Free Software Foundation; version 2 of the License.
 
405
 
 
406
 
 
407
=cut
 
408