home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / ExampleP.pm < prev    next >
Encoding:
Text File  |  2004-05-11  |  11.5 KB  |  413 lines
  1. {
  2.     package DBD::ExampleP;
  3.  
  4.     use Symbol;
  5.  
  6.     use DBI qw(:sql_types);
  7.  
  8.     @EXPORT = qw(); # Do NOT @EXPORT anything.
  9.     $VERSION = sprintf("%d.%02d", q$Revision: 11.12 $ =~ /(\d+)\.(\d+)/o);
  10.  
  11. #   $Id: ExampleP.pm,v 11.12 2004/01/07 17:38:51 timbo Exp $
  12. #
  13. #   Copyright (c) 1994,1997,1998 Tim Bunce
  14. #
  15. #   You may distribute under the terms of either the GNU General Public
  16. #   License or the Artistic License, as specified in the Perl README file.
  17.  
  18.     @statnames = qw(dev ino mode nlink
  19.     uid gid rdev size
  20.     atime mtime ctime
  21.     blksize blocks name);
  22.     @statnames{@statnames} = (0 .. @statnames-1);
  23.  
  24.     @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
  25.     SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
  26.     SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
  27.     SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR);
  28.     @stattypes{@statnames} = @stattypes;
  29.     @statprec = ((10) x (@statnames-1), 1024);
  30.     @statprec{@statnames} = @statprec;
  31.     die unless @statnames == @stattypes;
  32.     die unless @statprec  == @stattypes;
  33.  
  34.     $drh = undef;    # holds driver handle once initialised
  35.     $err = 0;        # The $DBI::err value
  36.     #$gensym = "SYM000"; # used by st::execute() for filehandles
  37.  
  38.     sub driver{
  39.     return $drh if $drh;
  40.     my($class, $attr) = @_;
  41.     $class .= "::dr";
  42.     ($drh) = DBI::_new_drh($class, {
  43.         'Name' => 'ExampleP',
  44.         'Version' => $VERSION,
  45.         'Attribution' => 'DBD Example Perl stub by Tim Bunce',
  46.         }, ['example implementors private data '.__PACKAGE__]);
  47.     $drh;
  48.     }
  49.  
  50.     sub CLONE {
  51.     undef $drh;
  52.     }
  53. }
  54.  
  55.  
  56. {   package DBD::ExampleP::dr; # ====== DRIVER ======
  57.     $imp_data_size = 0;
  58.     use strict;
  59.  
  60.     sub connect { # normally overridden, but a handy default
  61.         my($drh, $dbname, $user, $auth)= @_;
  62.         my($this) = DBI::_new_dbh($drh, {
  63.         'Name' => $dbname,
  64.         'User' => $user,
  65.         examplep_get_info => {},
  66.         });
  67.     $this->STORE(Active => 1);
  68.         $this;
  69.     }
  70.  
  71.     sub data_sources {
  72.     return ("dbi:ExampleP:dir=.");    # possibly usefully meaningless
  73.     }
  74.  
  75.     sub DESTROY { undef }
  76. }
  77.  
  78.  
  79. {   package DBD::ExampleP::db; # ====== DATABASE ======
  80.     $imp_data_size = 0;
  81.     use strict;
  82.  
  83.     sub prepare {
  84.     my($dbh, $statement)= @_;
  85.     my @fields;
  86.     my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i;
  87.  
  88.     if (defined $fields and defined $dir) {
  89.         @fields = ($fields eq '*')
  90.             ? keys %DBD::ExampleP::statnames
  91.             : split(/\s*,\s*/, $fields);
  92.     }
  93.     else {
  94.         return $dbh->set_err(1, "Syntax error in select statement (\"$statement\")")
  95.         unless $statement =~ m/^\s*set\s+/;
  96.         # the SET syntax is just a hack so the ExampleP driver can
  97.         # be used to test non-select statements.
  98.         # No we have DBI::DBM etc ExampleP should be deprecated
  99.     }
  100.  
  101.     my ($outer, $inner) = DBI::_new_sth($dbh, {
  102.         'Statement'     => $statement,
  103.     }, ['example implementors private data '.__PACKAGE__]);
  104.  
  105.     my @bad = map {
  106.         defined $DBD::ExampleP::statnames{$_} ? () : $_
  107.     } @fields;
  108.     return $dbh->set_err(1, "Unknown field names: @bad")
  109.         if @bad;
  110.  
  111.     $outer->STORE('NUM_OF_FIELDS' => scalar(@fields));
  112.  
  113.     $inner->{'dbd_ex_dir'} = $dir if defined($dir) && $dir !~ /\?/;
  114.     $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0);
  115.  
  116.     if (@fields) {
  117.         $outer->STORE('NAME'     => \@fields);
  118.         $outer->STORE('NULLABLE' => [ (0) x @fields ]);
  119.         $outer->STORE('SCALE'    => [ (0) x @fields ]);
  120.     }
  121.  
  122.     $outer;
  123.     }
  124.  
  125.  
  126.     sub table_info {
  127.     my $dbh = shift;
  128.     my ($catalog, $schema, $table, $type) = @_;
  129.  
  130.     my @types = split(/["']*,["']/, $type || 'TABLE');
  131.     my %types = map { $_=>$_ } @types;
  132.  
  133.     # Return a list of all subdirectories
  134.     my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
  135.     my $haveFileSpec = eval { require File::Spec };
  136.     my $dir = $haveFileSpec ? File::Spec->curdir() : ".";
  137.     my @list;
  138.     if ($types{VIEW}) {    # for use by test harness
  139.         push @list, [ undef, "schema",  "table",  'VIEW', undef ];
  140.         push @list, [ undef, "sch-ema", "table",  'VIEW', undef ];
  141.         push @list, [ undef, "schema",  "ta-ble", 'VIEW', undef ];
  142.         push @list, [ undef, "sch ema", "table",  'VIEW', undef ];
  143.         push @list, [ undef, "schema",  "ta ble", 'VIEW', undef ];
  144.     }
  145.     if ($types{TABLE}) {
  146.         no strict 'refs';
  147.         opendir($dh, $dir)
  148.         or return $dbh->set_err(int($!),
  149.                     "Failed to open directory $dir: $!");
  150.         while (defined(my $file = readdir($dh))) {
  151.         next unless -d $file;
  152.         my($dev, $ino, $mode, $nlink, $uid) = lstat($file);
  153.         my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid;
  154.         push @list, [ $dir, $pwnam, $file, 'TABLE', undef ];
  155.         }
  156.         close($dh);
  157.     }
  158.     # We would like to simply do a DBI->connect() here. However,
  159.     # this is wrong if we are in a subclass like DBI::ProxyServer.
  160.     $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','')
  161.         or return $dbh->set_err($DBI::err,
  162.             "Failed to connect to DBI::Sponge: $DBI::errstr");
  163.  
  164.     my $attr = {
  165.         'rows' => \@list,
  166.         'NUM_OF_FIELDS' => 5,
  167.         'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME',
  168.             'TABLE_TYPE', 'REMARKS'],
  169.         'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(),
  170.             DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ],
  171.         'NULLABLE' => [1, 1, 1, 1, 1]
  172.     };
  173.     my $sdbh = $dbh->{'dbd_sponge_dbh'};
  174.     my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr)
  175.         or return $dbh->set_err($sdbh->err(), $sdbh->errstr());
  176.     $sth;
  177.     }
  178.  
  179.  
  180.     sub type_info_all {
  181.     my ($dbh) = @_;
  182.     my $ti = [
  183.         {    TYPE_NAME    => 0,
  184.         DATA_TYPE    => 1,
  185.         COLUMN_SIZE    => 2,
  186.         LITERAL_PREFIX    => 3,
  187.         LITERAL_SUFFIX    => 4,
  188.         CREATE_PARAMS    => 5,
  189.         NULLABLE    => 6,
  190.         CASE_SENSITIVE    => 7,
  191.         SEARCHABLE    => 8,
  192.         UNSIGNED_ATTRIBUTE=> 9,
  193.         FIXED_PREC_SCALE=> 10,
  194.         AUTO_UNIQUE_VALUE => 11,
  195.         LOCAL_TYPE_NAME    => 12,
  196.         MINIMUM_SCALE    => 13,
  197.         MAXIMUM_SCALE    => 14,
  198.         },
  199.         [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
  200.         [ 'INTEGER', DBI::SQL_INTEGER,   10, "","",   undef, 0, 0, 1, 0, 0,0,undef,0,0 ],
  201.     ];
  202.     return $ti;
  203.     }
  204.  
  205.  
  206.     sub disconnect {
  207.     shift->STORE(Active => 0);
  208.     return 1;
  209.     }
  210.  
  211.  
  212.     sub get_info {
  213.     my ($dbh, $info_type) = @_;
  214.     return $dbh->{examplep_get_info}->{$info_type};
  215.     }
  216.  
  217.  
  218.     sub FETCH {
  219.     my ($dbh, $attrib) = @_;
  220.     # In reality this would interrogate the database engine to
  221.     # either return dynamic values that cannot be precomputed
  222.     # or fetch and cache attribute values too expensive to prefetch.
  223.     # else pass up to DBI to handle
  224.     return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path';
  225.     return $dbh->SUPER::FETCH($attrib);
  226.     }
  227.  
  228.  
  229.     sub STORE {
  230.     my ($dbh, $attrib, $value) = @_;
  231.     # would normally validate and only store known attributes
  232.     # else pass up to DBI to handle
  233.     if ($attrib eq 'AutoCommit') {
  234.         # convert AutoCommit values to magic ones to let DBI
  235.         # know that the driver has 'handled' the AutoCommit attribute
  236.         $value = ($value) ? -901 : -900;
  237.     }
  238.     return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/;
  239.     return $dbh->SUPER::STORE($attrib, $value);
  240.     }
  241.  
  242.     sub DESTROY {
  243.     my $dbh = shift;
  244.     $dbh->disconnect if $dbh->FETCH('Active');
  245.     undef
  246.     }
  247.  
  248.  
  249.     # This is an example to demonstrate the use of driver-specific
  250.     # methods via $dbh->func().
  251.     # Use it as follows:
  252.     #   my @tables = $dbh->func($re, 'examplep_tables');
  253.     #
  254.     # Returns all the tables that match the regular expression $re.
  255.     sub examplep_tables {
  256.     my $dbh = shift; my $re = shift;
  257.     grep { $_ =~ /$re/ } $dbh->tables();
  258.     }
  259.  
  260.     sub parse_trace_flag {
  261.     my ($h, $name) = @_;
  262.     return 0x01000000 if $name eq 'foo';
  263.     return 0x02000000 if $name eq 'bar';
  264.     return 0x04000000 if $name eq 'baz';
  265.     return 0x08000000 if $name eq 'boo';
  266.     return 0x10000000 if $name eq 'bop';
  267.     return $h->SUPER::parse_trace_flag($name);
  268.     }
  269.  
  270. }
  271.  
  272.  
  273. {   package DBD::ExampleP::st; # ====== STATEMENT ======
  274.     $imp_data_size = 0;
  275.     use strict; no strict 'refs'; # cause problems with filehandles
  276.  
  277.     my $haveFileSpec = eval { require File::Spec };
  278.  
  279.     sub bind_param {
  280.     my($sth, $param, $value, $attribs) = @_;
  281.     $sth->{'dbd_param'}->[$param-1] = $value;
  282.     return 1;
  283.     }
  284.  
  285.  
  286.     sub execute {
  287.     my($sth, @dir) = @_;
  288.     my $dir;
  289.  
  290.     if (@dir) {
  291.         $sth->bind_param($_, $dir[$_-1]) or return
  292.         foreach (1..@dir);
  293.     }
  294.  
  295.     my $dbd_param = $sth->{'dbd_param'} || [];
  296.     return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected")
  297.         unless @$dbd_param == $sth->{NUM_OF_PARAMS};
  298.  
  299.     return 0 unless $sth->{NUM_OF_FIELDS}; # not a select
  300.  
  301.     $dir = $dbd_param->[0] || $sth->{dbd_ex_dir};
  302.     return $sth->set_err(2, "No bind parameter supplied")
  303.         unless defined $dir;
  304.  
  305.     $sth->finish;
  306.  
  307.     #
  308.     # If the users asks for directory "long_list_4532", then we fake a
  309.     # directory with files "file4351", "file4350", ..., "file0".
  310.     # This is a special case used for testing, especially DBD::Proxy.
  311.     #
  312.     if ($dir =~ /^long_list_(\d+)$/) {
  313.         $sth->{dbd_dir} = [ $1 ];    # array ref indicates special mode
  314.         $sth->{dbd_datahandle} = undef;
  315.     }
  316.     else {
  317.         $sth->{dbd_dir} = $dir;
  318.         $sth->{dbd_datahandle} = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
  319.         opendir($sth->{dbd_datahandle}, $dir)
  320.         or return $sth->set_err(2, "opendir($dir): $!");
  321.     }
  322.     $sth->STORE(Active => 1);
  323.     return 1;
  324.     }
  325.  
  326.  
  327.     sub fetch {
  328.     my $sth = shift;
  329.     my $dh  = $sth->{dbd_datahandle};
  330.     my $dir = $sth->{dbd_dir};
  331.     my %s;
  332.  
  333.     if (ref $dir) {        # special fake-data test mode
  334.         my $num = $dir->[0]--;
  335.         unless ($num > 0) {
  336.         $sth->finish();
  337.         return;
  338.         }
  339.         my $time = time;
  340.         @s{@DBD::ExampleP::statnames} =
  341.         ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024,
  342.               $time, $time, $time, 512, 2, "file$num")
  343.     }
  344.     else {            # normal mode
  345.         my $f = readdir($dh);
  346.         unless ($f) {
  347.         $sth->finish;
  348.         return;
  349.         }
  350.         # untaint $f so that we can use this for DBI taint tests
  351.         ($f) = ($f =~ m/^(.*)$/);
  352.         my $file = $haveFileSpec
  353.         ? File::Spec->catfile($dir, $f) : "$dir/$f";
  354.         # put in all the data fields
  355.         @s{ @DBD::ExampleP::statnames } = (lstat($file), $f);
  356.     }
  357.  
  358.     # return just what fields the query asks for
  359.     my @new = @s{ @{$sth->{NAME}} };
  360.  
  361.     return $sth->_set_fbav(\@new);
  362.     }
  363.     *fetchrow_arrayref = \&fetch;
  364.  
  365.  
  366.     sub finish {
  367.     my $sth = shift;
  368.     closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle};
  369.     $sth->{dbd_datahandle} = undef;
  370.     $sth->{dbd_dir} = undef;
  371.     $sth->SUPER::finish();
  372.     return 1;
  373.     }
  374.  
  375.  
  376.     sub FETCH {
  377.     my ($sth, $attrib) = @_;
  378.     # In reality this would interrogate the database engine to
  379.     # either return dynamic values that cannot be precomputed
  380.     # or fetch and cache attribute values too expensive to prefetch.
  381.     if ($attrib eq 'TYPE'){
  382.         return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ];
  383.     }
  384.     elsif ($attrib eq 'PRECISION'){
  385.         return [ @DBD::ExampleP::statprec{  @{ $sth->FETCH(q{NAME_lc}) } } ];
  386.     }
  387.     elsif ($attrib eq 'ParamValues') {
  388.         my $dbd_param = $sth->{dbd_param} || [];
  389.         my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param;
  390.         return \%pv;
  391.     }
  392.     # else pass up to DBI to handle
  393.     return $sth->SUPER::FETCH($attrib);
  394.     }
  395.  
  396.  
  397.     sub STORE {
  398.     my ($sth, $attrib, $value) = @_;
  399.     # would normally validate and only store known attributes
  400.     # else pass up to DBI to handle
  401.     return $sth->{$attrib} = $value
  402.         if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION';
  403.     return $sth->SUPER::STORE($attrib, $value);
  404.     }
  405.  
  406.     sub DESTROY { undef }
  407.  
  408.     *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag;
  409. }
  410.  
  411. 1;
  412. # vim: sw=4:ts=8
  413.