[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/i586-linux-thread-multi/DBD/ -> ExampleP.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1