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 / Mimer.pm < prev    next >
Encoding:
Text File  |  2003-11-25  |  13.5 KB  |  507 lines
  1. # $Id: ODBC.pm,v 1.12 1998/08/14 19:29:50 timbo Exp $
  2. #
  3. # Copyright (c) 1994,1995,1996,1998  Tim Bunce
  4. # portions Copyright (c) 1997,1998,1999,2000,2001,2002  Jeff Urlwin
  5. # portions Copyright (c) 1997  Thomas K. Wenrich
  6. #
  7. # You may distribute under the terms of either the GNU General Public
  8. # License or the Artistic License, as specified in the Perl README file.
  9.  
  10. require 5.004;
  11.  
  12. $DBD::Mimer::VERSION = '1.00';
  13.  
  14. {
  15.     package DBD::Mimer;
  16.  
  17.     use DBI ();
  18.     use DynaLoader ();
  19.  
  20.     @ISA = qw(DynaLoader);
  21.     use Exporter ();
  22.  
  23.     my $Revision = substr(q$Revision: 1.12 $, 10);
  24.  
  25.     require_version DBI 1.21;
  26.  
  27.     bootstrap DBD::Mimer $VERSION;
  28.  
  29.     $err = 0;        # holds error code   for DBI::err
  30.     $errstr = "";    # holds error string for DBI::errstr
  31.     $sqlstate = "00000";
  32.     $drh = undef;    # holds driver handle once initialised
  33.  
  34.     sub driver{
  35.     return $drh if $drh;
  36.     my($class, $attr) = @_;
  37.  
  38.     $class .= "::dr";
  39.  
  40.     # not a 'my' since we use it above to prevent multiple drivers
  41.  
  42.     $drh = DBI::_new_drh($class, {
  43.         'Name' => 'Mimer',
  44.         'Version' => $VERSION,
  45.         'Err'    => \$DBD::Mimer::err,
  46.         'Errstr' => \$DBD::Mimer::errstr,
  47.         'State' => \$DBD::Mimer::sqlstate,
  48.         'Attribution' => 'DBD for Mimer SQL (Upright Database Technology and Jeff Urlwin)',
  49.         });
  50.  
  51.     $drh;
  52.     }
  53.  
  54.     sub CLONE { undef $drh  }
  55.     1;
  56. }
  57.  
  58.  
  59. {   package DBD::Mimer::dr; # ====== DRIVER ======
  60.     use strict;
  61.  
  62.     sub connect {
  63.     my $drh = shift;
  64.     my($dbname, $user, $auth, $attr)= @_;
  65.     $user = '' unless defined $user;
  66.     $auth = '' unless defined $auth;
  67.  
  68.     # create a 'blank' dbh
  69.     my $this = DBI::_new_dbh($drh, {
  70.         'Name' => $dbname,
  71.         'USER' => $user, 
  72.         'CURRENT_USER' => $user,
  73.         });
  74.  
  75.     # Call ODBC logon func in Mimer.xs file
  76.     # and populate internal handle data.
  77.  
  78.     DBD::Mimer::db::_login($this, $dbname, $user, $auth, $attr) or return undef;
  79.  
  80.     $this;
  81.     }
  82.  
  83.     sub data_sources {
  84.     my $drh = shift;
  85.     return sql_data_sources($drh) if ($^O eq "MSWin32" || $^O eq "cygwin");
  86.  
  87.     my $sqlhosts = "/etc/sqlhosts";
  88.     $sqlhosts = "MIMER_SQLHOSTS" if ($^O eq "VMS");
  89.  
  90.     my @res = ();
  91.  
  92.     open(SQLHOSTS,$sqlhosts) || return sql_data_sources($_);
  93.     my $section = "";
  94.     while (<SQLHOSTS>) {
  95.         s/(^([^-]|-[^-])*)--.*$/$1/;
  96.         $section = "LOCAL" if (/LOCAL:/);
  97.         $section = "REMOTE" if (/REMOTE:/);
  98.         next if ($section ne "LOCAL" && $section ne "REMOTE");
  99.  
  100.         if (/^[ \t]+(\w+)[ \t]+([^ \t]+)/) {
  101.         push(@res,$1);
  102.         } 
  103.     }
  104.     close(SQLHOSTS);
  105.  
  106.     return @res;
  107.     }
  108.  
  109. }
  110.  
  111.  
  112. {   package DBD::Mimer::db; # ====== DATABASE ======
  113.     use strict;
  114.  
  115.     sub prepare {
  116.     my($dbh, $statement, @attribs)= @_;
  117.  
  118.     # create a 'blank' dbh
  119.     my $sth = DBI::_new_sth($dbh, {
  120.         'Statement' => $statement,
  121.         });
  122.  
  123.     # Call ODBC func in Mimer.xs file.
  124.     # (This will actually also call SQLPrepare for you.)
  125.     # and populate internal handle data.
  126.  
  127.     DBD::Mimer::st::_prepare($sth, $statement, @attribs)
  128.         or return undef;
  129.  
  130.     $sth;
  131.     }
  132.  
  133.     sub column_info {
  134.     my ($dbh, $catalog, $schema, $table, $column) = @_;
  135.  
  136.     $catalog = "" if (!$catalog);
  137.     $schema = "" if (!$schema);
  138.     $table = "" if (!$table);
  139.     $column = "" if (!$column);
  140.     # create a "blank" statement handle
  141.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLColumns" });
  142.  
  143.     _columns($dbh,$sth, $catalog, $schema, $table, $column)
  144.         or return undef;
  145.  
  146.     $sth;
  147.     }
  148.     
  149.  
  150.     sub columns {
  151.     my ($dbh, $catalog, $schema, $table, $column) = @_;
  152.  
  153.     $catalog = "" if (!$catalog);
  154.     $schema = "" if (!$schema);
  155.     $table = "" if (!$table);
  156.     $column = "" if (!$column);
  157.     # create a "blank" statement handle
  158.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLColumns" });
  159.  
  160.     _columns($dbh,$sth, $catalog, $schema, $table, $column)
  161.         or return undef;
  162.  
  163.     $sth;
  164.     }
  165.  
  166.  
  167.     sub table_info {
  168.      my($dbh, $catalog, $schema, $table, $type) = @_;
  169.  
  170.     if ($#_ == 1) {
  171.        my $attrs = $_[1];
  172.        $catalog = $attrs->{TABLE_CAT};
  173.        $schema = $attrs->{TABLE_SCHEM};
  174.        $table = $attrs->{TABLE_NAME};
  175.        $type = $attrs->{TABLE_TYPE};
  176.      }
  177.  
  178.     $catalog = "" if (!$catalog);
  179.     $schema = "" if (!$schema);
  180.     $table = "" if (!$table);
  181.     $type = "" if (!$type);
  182.  
  183.     # create a "blank" statement handle
  184.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLTables" });
  185.  
  186.     DBD::Mimer::st::_tables($dbh,$sth, $catalog, $schema, $table, $type)
  187.           or return undef;
  188.     $sth;
  189.     }
  190.  
  191.     sub primary_key_info {
  192.        my ($dbh, $catalog, $schema, $table ) = @_;
  193.  
  194.        # create a "blank" statement handle
  195.        my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLPrimaryKeys" });
  196.  
  197.        $catalog = "" if (!$catalog);
  198.        $schema = "" if (!$schema);
  199.        $table = "" if (!$table);
  200.        DBD::Mimer::st::_primary_keys($dbh,$sth, $catalog, $schema, $table )
  201.          or return undef;
  202.        $sth;
  203.     }
  204.  
  205.     sub foreign_key_info {
  206.        my ($dbh, $pkcatalog, $pkschema, $pktable, $fkcatalog, $fkschema, $fktable ) = @_;
  207.  
  208.        # create a "blank" statement handle
  209.        my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLForeignKeys" });
  210.  
  211.        $pkcatalog = "" if (!$pkcatalog);
  212.        $pkschema = "" if (!$pkschema);
  213.        $pktable = "" if (!$pktable);
  214.        $fkcatalog = "" if (!$fkcatalog);
  215.        $fkschema = "" if (!$fkschema);
  216.        $fktable = "" if (!$fktable);
  217.        _GetForeignKeys($dbh, $sth, $pkcatalog, $pkschema, $pktable, $fkcatalog, $fkschema, $fktable) or return undef;
  218.        $sth;
  219.     }
  220.  
  221.     sub ping {
  222.     my $dbh = shift;
  223.     my $state = undef;
  224.  
  225.      my ($catalog, $schema, $table, $type);
  226.  
  227.     $catalog = "";
  228.     $schema = "";
  229.     $table = "NOXXTABLE";
  230.     $type = "";
  231.  
  232.     # create a "blank" statement handle
  233.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLTables_PING" });
  234.  
  235.     DBD::Mimer::st::_tables($dbh,$sth, $catalog, $schema, $table, $type)
  236.           or return 0;
  237.     $sth->finish;
  238.     return 1;
  239.  
  240.     }
  241.  
  242.     sub oldping {
  243.     my $dbh = shift;
  244.     my $state = undef;
  245.     # should never 'work' but if it does, that's okay!
  246.     # JLU incorporated patches from Jon Smirl 5/4/99
  247.     {
  248.         local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
  249.         # JLU added local PrintError handling for completeness.
  250.         # it shouldn't print, I think.
  251.         local $dbh->{PrintError} = 0 if $dbh->{PrintError};
  252.         my $sql = "select sysdate from dual1__NOT_FOUND__CANNOT";
  253.         my $sth = $dbh->prepare($sql);
  254.         # fixed "my" $state = below.  Was causing problem with
  255.         # ping!  Also, fetching fields as some drivers (Oracle 8)
  256.         # may not actually check the database for activity until
  257.         # the query is "described".
  258.         # Right now, Oracle8 is the only known version which
  259.         # does not actually check the server during prepare.
  260.         my $ok = $sth && $sth->execute();
  261.  
  262.         $state = $dbh->state;
  263.         $DBD::Mimer::err = 0;
  264.         $DBD::Mimer::errstr = "";
  265.         $DBD::Mimer::sqlstate = "00000";
  266.         return 1 if $ok;
  267.     }
  268.     return 1 if $state eq 'S0002';    # Base table not found
  269.      return 1 if $state eq '42S02';  # Base table not found.Solid EE v3.51
  270.     return 1 if $state eq 'S0022';    # Column not found
  271.     return 1 if $state eq '37000';  # statement could not be prepared (19991011, JLU)
  272.     # return 1 if $state eq "S1000';  # General Error? ? 5/30/02
  273.     # We assume that any other error means the database
  274.     # is no longer connected.
  275.     # Some special cases may need to be added to the code above.
  276.     return 0;
  277.     }
  278.  
  279.     # New support for the next DBI which will have a get_info command.
  280.     # leaving support for ->func(xxx, GetInfo) (above) for a period of time
  281.     # to support older applications which used this.
  282.     sub get_info {
  283.     my ($dbh, $item) = @_;
  284.     # handle SQL_DRIVER_HSTMT, SQL_DRIVER_HLIB and
  285.     # SQL_DRIVER_HDESC specially
  286.     if ($item == 5 || $item == 135 || $item == 76) {
  287.        return undef;
  288.     }
  289.     return _GetInfo($dbh, $item);
  290.     }
  291.  
  292.     # new override of do method provided by Merijn Broeren
  293.     # this optimizes "do" to use SQLExecDirect for simple
  294.     # do statements without parameters.
  295.     sub do {
  296.         my($dbh, $statement, $attr, @params) = @_;
  297.         my $rows = 0;
  298.  
  299.         if( -1 == $#params )
  300.         {
  301.           # No parameters, use execute immediate
  302.           $rows = ExecDirect( $dbh, $statement );
  303.           if( 0 == $rows )
  304.           {
  305.             $rows = "0E0";
  306.           }
  307.           elsif( $rows < -1 )
  308.           {
  309.             undef $rows;
  310.           }
  311.         }
  312.         else
  313.         {
  314.           $rows = $dbh->SUPER::do( $statement, $attr, @params );
  315.         }
  316.         return $rows
  317.     }
  318.  
  319.     #
  320.     # can also be called as $dbh->func($sql, ExecDirect);
  321.     # if, for some reason, there are compatibility issues
  322.     # later with DBI's do.
  323.     #
  324.     sub ExecDirect {
  325.        my ($dbh, $sql) = @_;
  326.        _ExecDirect($dbh, $sql);
  327.     }
  328.  
  329.     # Call the ODBC function SQLGetInfo
  330.     # Args are:
  331.     #    $dbh - the database handle
  332.     #    $item: the requested item.  For example, pass 6 for SQL_DRIVER_NAME
  333.     # See the ODBC documentation for more information about this call.
  334.     #
  335.     sub GetInfo {
  336.     my ($dbh, $item) = @_;
  337.     get_info($dbh, $item);
  338.     }
  339.  
  340.     # Call the ODBC function SQLStatistics
  341.     # Args are:
  342.     # See the ODBC documentation for more information about this call.
  343.     #
  344.     sub GetStatistics {
  345.             my ($dbh, $Catalog, $Schema, $Table, $Unique) = @_;
  346.             # create a "blank" statement handle
  347.             my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLStatistics" });
  348.             _GetStatistics($dbh, $sth, $Catalog, $Schema, $Table, $Unique) or return undef;
  349.             $sth;
  350.     }
  351.  
  352.     # Call the ODBC function SQLForeignKeys
  353.     # Args are:
  354.     # See the ODBC documentation for more information about this call.
  355.     #
  356.     sub GetForeignKeys {
  357.             my ($dbh, $PK_Catalog, $PK_Schema, $PK_Table, $FK_Catalog, $FK_Schema, $FK_Table) = @_;
  358.             # create a "blank" statement handle
  359.             my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLForeignKeys" });
  360.             _GetForeignKeys($dbh, $sth, $PK_Catalog, $PK_Schema, $PK_Table, $FK_Catalog, $FK_Schema, $FK_Table) or return undef;
  361.             $sth;
  362.     }
  363.  
  364.     # Call the ODBC function SQLPrimaryKeys
  365.     # Args are:
  366.     # See the ODBC documentation for more information about this call.
  367.     #
  368.     sub GetPrimaryKeys {
  369.             my ($dbh, $Catalog, $Schema, $Table) = @_;
  370.             # create a "blank" statement handle
  371.             my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLPrimaryKeys" });
  372.             _GetPrimaryKeys($dbh, $sth, $Catalog, $Schema, $Table) or return undef;
  373.             $sth;
  374.     }
  375.  
  376.     # Call the ODBC function SQLSpecialColumns
  377.     # Args are:
  378.     # See the ODBC documentation for more information about this call.
  379.     #
  380.     sub GetSpecialColumns {
  381.     my ($dbh, $Identifier, $Catalog, $Schema, $Table, $Scope, $Nullable) = @_;
  382.     # create a "blank" statement handle
  383.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLSpecialColumns" });
  384.     _GetSpecialColumns($dbh, $sth, $Identifier, $Catalog, $Schema, $Table, $Scope, $Nullable) or return undef;
  385.     $sth;
  386.     }
  387.     
  388.     sub GetTypeInfo {
  389.     my ($dbh, $sqltype) = @_;
  390.     # create a "blank" statement handle
  391.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLGetTypeInfo" });
  392.     # print "SQL Type is $sqltype\n";
  393.     _GetTypeInfo($dbh, $sth, $sqltype) or return undef;
  394.     $sth;
  395.     }
  396.  
  397.     sub type_info_all {
  398.     my ($dbh, $sqltype) = @_;
  399.     $sqltype = DBI::SQL_ALL_TYPES unless defined $sqltype;
  400.     my $sth = DBI::_new_sth($dbh, { 'Statement' => "SQLGetTypeInfo" });
  401.     _GetTypeInfo($dbh, $sth, $sqltype) or return undef;
  402.     my $info = $sth->fetchall_arrayref;
  403.     unshift @$info, {
  404.         map { ($sth->{NAME}->[$_] => $_) } 0..$sth->{NUM_OF_FIELDS}-1
  405.     };
  406.     return $info;
  407.     }
  408.  
  409. }
  410.  
  411.  
  412. {   package DBD::Mimer::st; # ====== STATEMENT ======
  413.     use strict;
  414.  
  415.     sub ColAttributes {        # maps to SQLColAttributes
  416.     my ($sth, $colno, $desctype) = @_;
  417.     # print "before ColAttributes $colno\n";
  418.     my $tmp = _ColAttributes($sth, $colno, $desctype);
  419.     # print "After ColAttributes\n";
  420.     $tmp;
  421.     }
  422.  
  423.     sub cancel {
  424.     my $sth = shift;
  425.     my $tmp = _Cancel($sth);
  426.     $tmp;
  427.     }
  428. }
  429.  
  430. 1;
  431. __END__
  432.  
  433. =head1 NAME
  434.  
  435. DBD::Mimer - Mimer SQL Driver for DBI
  436.  
  437. =head1 SYNOPSIS
  438.  
  439.   use DBI;
  440.  
  441.   $dbh = DBI->connect('dbi:Mimer:DSN', 'user', 'password');
  442.  
  443. See L<DBI> for more information.
  444.  
  445. =head1 DESCRIPTION
  446.  
  447. DBD::Mimer is a Perl5 database interface for the Mimer SQL
  448. database.
  449.  
  450. Using this module is one of several ways of accessing Mimer SQL 
  451. from the Perl programming language. The most portable way is
  452. to use DBD::ODBC through a driver manager. The driver manager
  453. offers an abstraction layer which improves portability. In some
  454. situations, using a driver manager is not feasible. This could be true
  455. because you don't want to install a driver manager on your system,
  456. or that there is no driver manager available for your type of system.
  457.  
  458. DBD::Mimer offers the same features as DBD::ODBC but links statically
  459. with the Mimer ODBC driver, thus skipping the driver manager. 
  460.  
  461. Most of the code, build scripts and documentation is derived from
  462. DBD::ODBC. Development of DBD::Mimer will not extend beyond features
  463. offered by DBD::ODBC. This way, anyone using DBD::Mimer can easily switch 
  464. to DBD::ODBC when a driver manager is preferred.
  465.  
  466. =head2 Recent Updates
  467.  
  468. =over 4
  469. =item B<DBD::Mimer 1.00>
  470.  
  471.  This is the first DBD::Mimer release. 
  472.  
  473.  Most of the code has been forked from DBD::ODBC 1.06. Our compliments
  474.  to the original author and subsequent maintainers. Code was added to
  475.  handle Mimer data sources. Tests, included in DBD::ODBC, not coded
  476.  against SQL-99 was dropped. Some tests in DBD::ODBC was hardcoded
  477.  using Microsoft SQL Server and Oracle specific SQL constructs.
  478.  
  479. =back
  480.  
  481. =cut
  482.  
  483.  
  484.  
  485.  
  486.  
  487.  
  488.  
  489.  
  490.  
  491.  
  492.  
  493.  
  494.  
  495.  
  496.  
  497.  
  498.  
  499.  
  500.  
  501.  
  502.  
  503.  
  504.  
  505.  
  506.  
  507.