file.pm

Astercon2 开源软交换 2.2.0

# -*- perl -*-
#
#   DBD::File - A base class for implementing DBI drivers that
#               act on plain files
#
#  This module is currently maintained by
#
#      Jeff Zucker < jzucker AT cpan.org >
#
#  The original author is Jochen Wiedmann.
#
#  Copyright (C) 2004 by Jeff Zucker
#  Copyright (C) 1998 by Jochen Wiedmann
#
#  All rights reserved.
#
#  You may distribute this module under the terms of either the GNU
#  General Public License or the Artistic License, as specified in
#  the Perl README file.
#
require 5.004;
use strict;

use DBI ();
require DBI::SQL::Nano;
my $haveFileSpec = eval { require File::Spec };

package DBD::File;

use vars qw(@ISA $VERSION $drh $valid_attrs);

$VERSION = '0.35';

$drh = undef;		# holds driver handle(s) once initialised

sub driver ($;$) {
    my($class, $attr) = @_;

    # Drivers typically use a singleton object for the $drh
    # We use a hash here to have one singleton per subclass.
    # (Otherwise DBD::CSV and DBD::DBM, for example, would
    # share the same driver object which would cause problems.)
    # An alternative would be not not cache the $drh here at all
    # and require that subclasses do that. Subclasses should do
    # their own caching, so caching here just provides extra safety.
    return $drh->{$class} if $drh->{$class};

    DBI->setup_driver('DBD::File'); # only needed once but harmless to repeat
    $attr ||= {};
    no strict qw(refs);
    if (!$attr->{Attribution}) {
	$attr->{Attribution} = "$class by Jeff Zucker"
	    if $class eq 'DBD::File';
	$attr->{Attribution} ||= ${$class . '::ATTRIBUTION'}
	    || "oops the author of $class forgot to define this";
    }
    $attr->{Version} ||= ${$class . '::VERSION'};
    ($attr->{Name} = $class) =~ s/^DBD\:\:// unless $attr->{Name};

    $drh->{$class} = DBI::_new_drh($class . "::dr", $attr);
    $drh->{$class}->STORE(ShowErrorStatement => 1);
    return $drh->{$class};
}

sub CLONE {
    undef $drh;
}

package DBD::File::dr; # ====== DRIVER ======

$DBD::File::dr::imp_data_size = 0;

sub connect ($$;$$$) {
    my($drh, $dbname, $user, $auth, $attr)= @_;

    # create a 'blank' dbh
    my $this = DBI::_new_dbh($drh, {
	'Name' => $dbname,
	'USER' => $user,
	'CURRENT_USER' => $user,
    });

    if ($this) {
	my($var, $val);
	$this->{f_dir} = $haveFileSpec ? File::Spec->curdir() : '.';
	while (length($dbname)) {
	    if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) {
		$var = $1;
	    } else {
		$var = $dbname;
		$dbname = '';
	    }
	    if ($var =~ /^(.+?)=(.*)/s) {
		$var = $1;
		($val = $2) =~ s/\\(.)/$1/g;
		$this->{$var} = $val;
	    }
	}
        $this->{f_valid_attrs} = {
            f_version    => 1  # DBD::File version
          , f_dir        => 1  # base directory
          , f_tables     => 1  # base directory
        };
        $this->{sql_valid_attrs} = {
            sql_handler           => 1  # Nano or S:S
          , sql_nano_version      => 1  # Nano version
          , sql_statement_version => 1  # S:S version
        };
    }
    $this->STORE('Active',1);
    return set_versions($this);
}

sub set_versions {
    my $this = shift;
    $this->{f_version} = $DBD::File::VERSION;
    for (qw( nano_version statement_version)) {
        $this->{'sql_'.$_} = $DBI::SQL::Nano::versions->{$_}||'';
    }
    $this->{sql_handler} = ($this->{sql_statement_version})
                         ? 'SQL::Statement'
	                 : 'DBI::SQL::Nano';
    return $this;
}

sub data_sources ($;$) {
    my($drh, $attr) = @_;
    my($dir) = ($attr and exists($attr->{'f_dir'})) ?
	$attr->{'f_dir'} : $haveFileSpec ? File::Spec->curdir() : '.';
    my($dirh) = Symbol::gensym();
    if (!opendir($dirh, $dir)) {
        $drh->set_err(1, "Cannot open directory $dir: $!");
	return undef;
    }
    my($file, @dsns, %names, $driver);
    if ($drh->{'ImplementorClass'} =~ /^dbd\:\:([^\:]+)\:\:/i) {
	$driver = $1;
    } else {
	$driver = 'File';
    }
    while (defined($file = readdir($dirh))) {
	my $d = $haveFileSpec ?
	    File::Spec->catdir($dir, $file) : "$dir/$file";
        # allow current dir ... it can be a data_source too
	if ( $file ne ($haveFileSpec ? File::Spec->updir() : '..')
	    and  -d $d) {
	    push(@dsns, "DBI:$driver:f_dir=$d");
	}
    }
    @dsns;
}

sub disconnect_all {
}

sub DESTROY {
    undef;
}


package DBD::File::db; # ====== DATABASE ======

$DBD::File::db::imp_data_size = 0;

sub ping { return (shift->FETCH('Active')) ? 1 : 0 };

sub prepare ($$;@) {
    my($dbh, $statement, @attribs)= @_;

    # create a 'blank' sth
    my $sth = DBI::_new_sth($dbh, {'Statement' => $statement});

    if ($sth) {
	my $class = $sth->FETCH('ImplementorClass');
	$class =~ s/::st$/::Statement/;
	my($stmt);

        # if using SQL::Statement version > 1
        # cache the parser object if the DBD supports parser caching
        # SQL::Nano and older SQL::Statements don't support this

	if ( $dbh->{sql_handler} eq 'SQL::Statement'
             and $dbh->{sql_statement_version} > 1)
           {
            my $parser = $dbh->{csv_sql_parser_object};
            $parser ||= eval { $dbh->func('csv_cache_sql_parser_object') };
            if ($@) {
  	        $stmt = eval { $class->new($statement) };
	    }
            else {
  	        $stmt = eval { $class->new($statement,$parser) };
	    }
        }
        else {
	    $stmt = eval { $class->new($statement) };
	}
	if ($@) {
	    $dbh->set_err(1, $@);
	    undef $sth;
	} else {
	    $sth->STORE('f_stmt', $stmt);
	    $sth->STORE('f_params', []);
	    $sth->STORE('NUM_OF_PARAMS', scalar($stmt->params()));
	}
    }
    $sth;
}
sub csv_cache_sql_parser_object {
    my $dbh = shift;
    my $parser = {
            dialect    => 'CSV',
            RaiseError => $dbh->FETCH('RaiseError'),
            PrintError => $dbh->FETCH('PrintError'),
        };
    my $sql_flags  = $dbh->FETCH('sql_flags') || {};
    %$parser = (%$parser,%$sql_flags);
    $parser = SQL::Parser->new($parser->{dialect},$parser);
    $dbh->{csv_sql_parser_object} = $parser;
    return $parser;
}
sub disconnect ($) {
    shift->STORE('Active',0);
    1;
}
sub FETCH ($$) {
    my ($dbh, $attrib) = @_;
    if ($attrib eq 'AutoCommit') {
	return 1;
    } elsif ($attrib eq (lc $attrib)) {
	# Driver private attributes are lower cased

        # Error-check for valid attributes
        # not implemented yet, see STORE
        #
        return $dbh->{$attrib};
    }
    # else pass up to DBI to handle
    return $dbh->SUPER::FETCH($attrib);
}

sub STORE ($$$) {
    my ($dbh, $attrib, $value) = @_;

    if ($attrib eq 'AutoCommit') {
	return 1 if $value; # is already set
	die("Can't disable AutoCommit");
    } elsif ($attrib eq (lc $attrib)) {
	# Driver private attributes are lower cased

  # I'm not implementing this yet becuase other drivers may be
  # setting f_ and sql_ attrs I don't know about
  # I'll investigate and publicize warnings to DBD authors
  # then implement this
  #
        # return to implementor if not f_ or sql_
        # not implemented yet
        # my $class = $dbh->FETCH('ImplementorClass');
        #
        # if ( !$dbh->{f_valid_attrs}->{$attrib}
        # and !$dbh->{sql_valid_attrs}->{$attrib}
        # ) {
	#    return $dbh->set_err( 1,"Invalid attribute '$attrib'");
        # }
        # else {
  	#    $dbh->{$attrib} = $value;
	# }

        if ($attrib eq 'f_dir') {
  	    return $dbh->set_err( 1,"No such directory '$value'")
                unless -d $value;
	}
	$dbh->{$attrib} = $value;
	return 1;
    }
    return $dbh->SUPER::STORE($attrib, $value);
}

sub DESTROY ($) {
    my $dbh = shift;
    $dbh->disconnect if $dbh->SUPER::FETCH('Active');
}

sub type_info_all ($) {
    [
     {   TYPE_NAME         => 0,
	 DATA_TYPE         => 1,
	 PRECISION         => 2,
	 LITERAL_PREFIX    => 3,
	 LITERAL_SUFFIX    => 4,
	 CREATE_PARAMS     => 5,
	 NULLABLE          => 6,
	 CASE_SENSITIVE    => 7,
	 SEARCHABLE        => 8,
	 UNSIGNED_ATTRIBUTE=> 9,
	 MONEY             => 10,
	 AUTO_INCREMENT    => 11,
	 LOCAL_TYPE_NAME   => 12,
	 MINIMUM_SCALE     => 13,
	 MAXIMUM_SCALE     => 14,
     },
     [ 'VARCHAR', DBI::SQL_VARCHAR(),
       undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
       ],
     [ 'CHAR', DBI::SQL_CHAR(),
       undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
       ],
     [ 'INTEGER', DBI::SQL_INTEGER(),
       undef,  "", "", undef,0, 0,1,0,0,0,undef,0,  0
       ],
     [ 'REAL', DBI::SQL_REAL(),
       undef,  "", "", undef,0, 0,1,0,0,0,undef,0,  0
       ],
     [ 'BLOB', DBI::SQL_LONGVARBINARY(),
       undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
       ],
     [ 'BLOB', DBI::SQL_LONGVARBINARY(),
       undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
       ],
     [ 'TEXT', DBI::SQL_LONGVARCHAR(),
       undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
       ]
     ]
}


{
    my $names = ['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME',
                 'TABLE_TYPE', 'REMARKS'];

    sub table_info ($) {
	my($dbh) = @_;
	my($dir) = $dbh->{f_dir};
	my($dirh) = Symbol::gensym();
	if (!opendir($dirh, $dir)) {
	    $dbh->set_err(1, "Cannot open directory $dir: $!");
	    return undef;
	}
	my($file, @tables, %names);
	while (defined($file = readdir($dirh))) {
	    if ($file ne '.'  &&  $file ne '..'  &&  -f "$dir/$file") {
		my $user = eval { getpwuid((stat(_))[4]) };
		push(@tables, [undef, $user, $file, "TABLE", undef]);
	    }
	}
	if (!closedir($dirh)) {
	    $dbh->set_err(1, "Cannot close directory $dir: $!");
	    return undef;
	}

	my $dbh2 = $dbh->{'csv_sponge_driver'};
	if (!$dbh2) {
	    $dbh2 = $dbh->{'csv_sponge_driver'} = DBI->connect("DBI:Sponge:");
	    if (!$dbh2) {
	        $dbh->set_err(1, $DBI::errstr);
		return undef;
	    }
	}

	# Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
	return undef if !@tables;

	my $sth = $dbh2->prepare("TABLE_INFO", { 'rows' => \@tables,
						 'NAMES' => $names });
	if (!$sth) {
	    $dbh->set_err(1, $dbh2->errstr);
	}
	$sth;
    }
}
sub list_tables ($) {
    my $dbh = shift;
    my($sth, @tables);
    if (!($sth = $dbh->table_info())) {
	return ();
    }
    while (my $ref = $sth->fetchrow_arrayref()) {
	push(@tables, $ref->[2]);
    }
    @tables;
}

sub quote ($$;$) {
    my($self, $str, $type) = @_;
    if (defined($type)  &&
	($type == DBI::SQL_NUMERIC()   ||
	 $type == DBI::SQL_DECIMAL()   ||
	 $type == DBI::SQL_INTEGER()   ||
	 $type == DBI::SQL_SMALLINT()  ||
	 $type == DBI::SQL_FLOAT()     ||
	 $type == DBI::SQL_REAL()      ||
	 $type == DBI::SQL_DOUBLE()    ||
	 $type == DBI::SQL_TINYINT())) {
	return $str;
    }
    if (!defined($str)) { return "NULL" }
    $str =~ s/\\/\\\\/sg;
    $str =~ s/\0/\\0/sg;
    $str =~ s/\'/\\\'/sg;
    $str =~ s/\n/\\n/sg;
    $str =~ s/\r/\\r/sg;