home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / ExampleP.pm < prev    next >
Encoding:
Text File  |  2004-01-07  |  10.4 KB  |  389 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.  
  86.     my($fields, $dir)
  87.         = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i;
  88.     return $dbh->DBI::set_err(1, "Syntax error in select statement (\"$statement\")")
  89.         unless defined $fields and defined $dir;
  90.  
  91.     my ($outer, $inner) = DBI::_new_sth($dbh, {
  92.         'Statement'     => $statement,
  93.     }, ['example implementors private data '.__PACKAGE__]);
  94.  
  95.     my @fields = ($fields eq '*')
  96.             ? keys %DBD::ExampleP::statnames
  97.             : split(/\s*,\s*/, $fields);
  98.  
  99.     my @bad = map {
  100.         defined $DBD::ExampleP::statnames{$_} ? () : $_
  101.     } @fields;
  102.     return $dbh->DBI::set_err(1, "Unknown field names: @bad")
  103.         if @bad;
  104.  
  105.     $inner->{dbd_param} = [];
  106.     @{ $inner->{'dbd_param'} } = ($dir) if $dir !~ /\?/;
  107.  
  108.     $outer->STORE('NAME' => \@fields);
  109.     $outer->STORE('NULLABLE' => [ (0) x @fields ]);
  110.     $outer->STORE('NUM_OF_FIELDS' => scalar(@fields));
  111.     $outer->STORE('NUM_OF_PARAMS' => ($dir !~ /\?/) ? 0 : 1);
  112.     $outer->STORE('SCALE'     => [ (0) x @fields ] );
  113.  
  114.     $outer;
  115.     }
  116.  
  117.  
  118.     sub table_info {
  119.     my $dbh = shift;
  120.     my ($catalog, $schema, $table, $type) = @_;
  121.  
  122.     my @types = split(/["']*,["']/, $type || 'TABLE');
  123.     my %types = map { $_=>$_ } @types;
  124.  
  125.     # Return a list of all subdirectories
  126.     my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
  127.     my $haveFileSpec = eval { require File::Spec };
  128.     my $dir = $haveFileSpec ? File::Spec->curdir() : ".";
  129.     my @list;
  130.     if ($types{VIEW}) {    # for use by test harness
  131.         push @list, [ undef, "schema",  "table",  'VIEW', undef ];
  132.         push @list, [ undef, "sch-ema", "table",  'VIEW', undef ];
  133.         push @list, [ undef, "schema",  "ta-ble", 'VIEW', undef ];
  134.         push @list, [ undef, "sch ema", "table",  'VIEW', undef ];
  135.         push @list, [ undef, "schema",  "ta ble", 'VIEW', undef ];
  136.     }
  137.     if ($types{TABLE}) {
  138.         no strict 'refs';
  139.         opendir($dh, $dir)
  140.         or return $dbh->DBI::set_err(int($!),
  141.                     "Failed to open directory $dir: $!");
  142.         while (defined(my $file = readdir($dh))) {
  143.         next unless -d $file;
  144.         my($dev, $ino, $mode, $nlink, $uid) = lstat($file);
  145.         my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid;
  146.         push @list, [ $dir, $pwnam, $file, 'TABLE', undef ];
  147.         }
  148.         close($dh);
  149.     }
  150.     # We would like to simply do a DBI->connect() here. However,
  151.     # this is wrong if we are in a subclass like DBI::ProxyServer.
  152.     $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','')
  153.         or return $dbh->DBI::set_err($DBI::err,
  154.             "Failed to connect to DBI::Sponge: $DBI::errstr");
  155.  
  156.     my $attr = {
  157.         'rows' => \@list,
  158.         'NUM_OF_FIELDS' => 5,
  159.         'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME',
  160.             'TABLE_TYPE', 'REMARKS'],
  161.         'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(),
  162.             DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ],
  163.         'NULLABLE' => [1, 1, 1, 1, 1]
  164.     };
  165.     my $sdbh = $dbh->{'dbd_sponge_dbh'};
  166.     my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr)
  167.         or return $dbh->DBI::set_err($sdbh->err(), $sdbh->errstr());
  168.     $sth;
  169.     }
  170.  
  171.  
  172.     sub type_info_all {
  173.     my ($dbh) = @_;
  174.     my $ti = [
  175.         {    TYPE_NAME    => 0,
  176.         DATA_TYPE    => 1,
  177.         COLUMN_SIZE    => 2,
  178.         LITERAL_PREFIX    => 3,
  179.         LITERAL_SUFFIX    => 4,
  180.         CREATE_PARAMS    => 5,
  181.         NULLABLE    => 6,
  182.         CASE_SENSITIVE    => 7,
  183.         SEARCHABLE    => 8,
  184.         UNSIGNED_ATTRIBUTE=> 9,
  185.         FIXED_PREC_SCALE=> 10,
  186.         AUTO_UNIQUE_VALUE => 11,
  187.         LOCAL_TYPE_NAME    => 12,
  188.         MINIMUM_SCALE    => 13,
  189.         MAXIMUM_SCALE    => 14,
  190.         },
  191.         [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
  192.         [ 'INTEGER', DBI::SQL_INTEGER,   10, "","",   undef, 0, 0, 1, 0, 0,0,undef,0,0 ],
  193.     ];
  194.     return $ti;
  195.     }
  196.  
  197.  
  198.     sub disconnect {
  199.     shift->STORE(Active => 0);
  200.     return 1;
  201.     }
  202.  
  203.  
  204.     sub get_info {
  205.     my ($dbh, $info_type) = @_;
  206.     return $dbh->{examplep_get_info}->{$info_type};
  207.     }
  208.  
  209.  
  210.     sub FETCH {
  211.     my ($dbh, $attrib) = @_;
  212.     # In reality this would interrogate the database engine to
  213.     # either return dynamic values that cannot be precomputed
  214.     # or fetch and cache attribute values too expensive to prefetch.
  215.     # else pass up to DBI to handle
  216.     return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path';
  217.     return $dbh->SUPER::FETCH($attrib);
  218.     }
  219.  
  220.  
  221.     sub STORE {
  222.     my ($dbh, $attrib, $value) = @_;
  223.     # would normally validate and only store known attributes
  224.     # else pass up to DBI to handle
  225.     if ($attrib eq 'AutoCommit') {
  226.         # convert AutoCommit values to magic ones to let DBI
  227.         # know that the driver has 'handled' the AutoCommit attribute
  228.         $value = ($value) ? -901 : -900;
  229.     }
  230.     return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/;
  231.     return $dbh->SUPER::STORE($attrib, $value);
  232.     }
  233.  
  234.     sub DESTROY {
  235.     my $dbh = shift;
  236.     $dbh->disconnect if $dbh->FETCH('Active');
  237.     undef
  238.     }
  239.  
  240.  
  241.     # This is an example to demonstrate the use of driver-specific
  242.     # methods via $dbh->func().
  243.     # Use it as follows:
  244.     #   my @tables = $dbh->func($re, 'examplep_tables');
  245.     #
  246.     # Returns all the tables that match the regular expression $re.
  247.     sub examplep_tables {
  248.     my $dbh = shift; my $re = shift;
  249.     grep { $_ =~ /$re/ } $dbh->tables();
  250.     }
  251. }
  252.  
  253.  
  254. {   package DBD::ExampleP::st; # ====== STATEMENT ======
  255.     $imp_data_size = 0;
  256.     use strict; no strict 'refs'; # cause problems with filehandles
  257.  
  258.     my $haveFileSpec = eval { require File::Spec };
  259.  
  260.     sub bind_param {
  261.     my($sth, $param, $value, $attribs) = @_;
  262.     $sth->{'dbd_param'}->[$param-1] = $value;
  263.     return 1;
  264.     }
  265.  
  266.  
  267.     sub execute {
  268.     my($sth, @dir) = @_;
  269.     my $dir;
  270.  
  271.     if (@dir) {
  272.         $sth->bind_param($_, $dir[$_-1]) or return
  273.         foreach (1..@dir);
  274.     }
  275.  
  276.     my $dbd_param = $sth->{'dbd_param'} || [];
  277.     return $sth->DBI::set_err(2, @$dbd_param." values bound when 1 expected")
  278.         unless @$dbd_param == 1;
  279.  
  280.     $dir = $dbd_param->[0];
  281.     return $sth->DBI::set_err(2, "No bind parameter supplied")
  282.         unless defined $dir;
  283.  
  284.     $sth->finish;
  285.  
  286.     #
  287.     # If the users asks for directory "long_list_4532", then we fake a
  288.     # directory with files "file4351", "file4350", ..., "file0".
  289.     # This is a special case used for testing, especially DBD::Proxy.
  290.     #
  291.     if ($dir =~ /^long_list_(\d+)$/) {
  292.         $sth->{dbd_dir} = [ $1 ];    # array ref indicates special mode
  293.         $sth->{dbd_datahandle} = undef;
  294.     }
  295.     else {
  296.         $sth->{dbd_dir} = $dir;
  297.         $sth->{dbd_datahandle} = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
  298.         opendir($sth->{dbd_datahandle}, $dir)
  299.         or return $sth->DBI::set_err(2, "opendir($dir): $!");
  300.     }
  301.     $sth->STORE(Active => 1);
  302.     return 1;
  303.     }
  304.  
  305.  
  306.     sub fetch {
  307.     my $sth = shift;
  308.     my $dh  = $sth->{dbd_datahandle};
  309.     my $dir = $sth->{dbd_dir};
  310.     my %s;
  311.  
  312.     if (ref $dir) {        # special fake-data test mode
  313.         my $num = $dir->[0]--;
  314.         unless ($num > 0) {
  315.         $sth->finish();
  316.         return;
  317.         }
  318.         my $time = time;
  319.         @s{@DBD::ExampleP::statnames} =
  320.         ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024,
  321.               $time, $time, $time, 512, 2, "file$num")
  322.     }
  323.     else {            # normal mode
  324.         my $f = readdir($dh);
  325.         unless ($f) {
  326.         $sth->finish;
  327.         return;
  328.         }
  329.         # untaint $f so that we can use this for DBI taint tests
  330.         ($f) = ($f =~ m/^(.*)$/);
  331.         my $file = $haveFileSpec
  332.         ? File::Spec->catfile($dir, $f) : "$dir/$f";
  333.         # put in all the data fields
  334.         @s{ @DBD::ExampleP::statnames } = (lstat($file), $f);
  335.     }
  336.  
  337.     # return just what fields the query asks for
  338.     my @new = @s{ @{$sth->{NAME}} };
  339.  
  340.     return $sth->_set_fbav(\@new);
  341.     }
  342.     *fetchrow_arrayref = \&fetch;
  343.  
  344.  
  345.     sub finish {
  346.     my $sth = shift;
  347.     closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle};
  348.     $sth->{dbd_datahandle} = undef;
  349.     $sth->{dbd_dir} = undef;
  350.     $sth->SUPER::finish();
  351.     return 1;
  352.     }
  353.  
  354.  
  355.     sub FETCH {
  356.     my ($sth, $attrib) = @_;
  357.     # In reality this would interrogate the database engine to
  358.     # either return dynamic values that cannot be precomputed
  359.     # or fetch and cache attribute values too expensive to prefetch.
  360.     if ($attrib eq 'TYPE'){
  361.         return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ];
  362.     }
  363.     elsif ($attrib eq 'PRECISION'){
  364.         return [ @DBD::ExampleP::statprec{  @{ $sth->FETCH(q{NAME_lc}) } } ];
  365.     }
  366.     elsif ($attrib eq 'ParamValues') {
  367.         my $dbd_param = $sth->{dbd_param} || [];
  368.         my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param;
  369.         return \%pv;
  370.     }
  371.     # else pass up to DBI to handle
  372.     return $sth->SUPER::FETCH($attrib);
  373.     }
  374.  
  375.  
  376.     sub STORE {
  377.     my ($sth, $attrib, $value) = @_;
  378.     # would normally validate and only store known attributes
  379.     # else pass up to DBI to handle
  380.     return $sth->{$attrib} = $value
  381.         if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION';
  382.     return $sth->SUPER::STORE($attrib, $value);
  383.     }
  384.  
  385.     sub DESTROY { undef }
  386. }
  387.  
  388. 1;
  389.