oracle.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

#   Oracle.pm
#
#   Copyright (c) 1994-2005 Tim Bunce, Ireland
#
#   See COPYRIGHT section in the documentation below

require 5.003;

$DBD::Oracle::VERSION = '1.20';

my $ORACLE_ENV  = ($^O eq 'VMS') ? 'ORA_ROOT' : 'ORACLE_HOME';

{
    package DBD::Oracle;

    use DBI ();
    use DynaLoader ();
    use Exporter ();
    @ISA = qw(DynaLoader Exporter);
    %EXPORT_TAGS = (
	ora_types => [ qw(
	    ORA_VARCHAR2 ORA_STRING ORA_NUMBER ORA_LONG ORA_ROWID ORA_DATE
	    ORA_RAW ORA_LONGRAW ORA_CHAR ORA_CHARZ ORA_MLSLABEL ORA_NTY
	    ORA_CLOB ORA_BLOB ORA_RSET ORA_VARCHAR2_TABLE ORA_NUMBER_TABLE
	    SQLT_INT SQLT_FLT
	) ],
        ora_session_modes => [ qw( ORA_SYSDBA ORA_SYSOPER ) ],
    );
    @EXPORT_OK = qw(ORA_OCI SQLCS_IMPLICIT SQLCS_NCHAR ora_env_var ora_cygwin_set_env);
    #unshift @EXPORT_OK, 'ora_cygwin_set_env' if $^O eq 'cygwin';
    Exporter::export_ok_tags(qw(ora_types ora_session_modes));

    my $Revision = substr(q$Revision: 1.103 $, 10);

    require_version DBI 1.51;

    bootstrap DBD::Oracle $VERSION;

    $drh = undef;	# holds driver handle once initialised

    sub CLONE {
        $drh = undef ;
    }
              
    sub driver{
	return $drh if $drh;
	my($class, $attr) = @_;
	my $oci = DBD::Oracle::ORA_OCI();

	$class .= "::dr";

	# not a 'my' since we use it above to prevent multiple drivers

	$drh = DBI::_new_drh($class, {
	    'Name' => 'Oracle',
	    'Version' => $VERSION,
	    'Err'    => \my $err,
	    'Errstr' => \my $errstr,
	    'Attribution' => "DBD::Oracle $VERSION using OCI$oci by Tim Bunce",
	    });
	DBD::Oracle::dr::init_oci($drh) ;
	$drh->STORE('ShowErrorStatement', 1);

        DBD::Oracle::db->install_method("ora_lob_read");
        DBD::Oracle::db->install_method("ora_lob_write");
        DBD::Oracle::db->install_method("ora_lob_append");
        DBD::Oracle::db->install_method("ora_lob_trim");
        DBD::Oracle::db->install_method("ora_lob_length");
        DBD::Oracle::db->install_method("ora_nls_parameters");
        DBD::Oracle::db->install_method("ora_can_unicode");

	$drh;
    }


    END {
	# Used to silence 'Bad free() ...' warnings caused by bugs in Oracle's code
	# being detected by Perl's malloc.
	$ENV{PERL_BADFREE} = 0;
	#undef $Win32::TieRegistry::Registry if $Win32::TieRegistry::Registry;
    }

    sub AUTOLOAD {
    	(my $constname = $AUTOLOAD) =~ s/.*:://;
    	my $val = constant($constname);
    	*$AUTOLOAD = sub { $val };
    	goto &$AUTOLOAD;
    }

}


{   package DBD::Oracle::dr; # ====== DRIVER ======
    use strict;

    my %dbnames = ();	# holds list of known databases (oratab + tnsnames)

    sub load_dbnames {
	my ($drh) = @_;
	my $debug = $drh->debug;
	my $oracle_home = DBD::Oracle::ora_env_var($ORACLE_ENV);
	local *FH;
	my $d;

	if (($^O eq 'MSWin32') or ($^O =~ /cygwin/i)) {
	  # XXX experimental, will probably change
	  $drh->trace_msg("Trying to fetch ORACLE_HOME and ORACLE_SID from the registry.\n")
		if $debug;
	  my $sid = DBD::Oracle::ora_env_var("ORACLE_SID");
	  $dbnames{$sid} = $oracle_home if $sid and $oracle_home;
	  $drh->trace_msg("Found $sid \@ $oracle_home.\n") if $debug && $sid;
	}

	# get list of 'local' database SIDs from oratab
	foreach $d (qw(/etc /var/opt/oracle), DBD::Oracle::ora_env_var("TNS_ADMIN")) {
	    next unless defined $d;
	    next unless open(FH, "<$d/oratab");
	    $drh->trace_msg("Loading $d/oratab\n") if $debug;
	    my $ot;
	    while (defined($ot = <FH>)) {
		next unless $ot =~ m/^\s*(\w+)\s*:\s*(.*?)\s*:/;
		$dbnames{$1} = $2;	# store ORACLE_HOME value
		$drh->trace_msg("Found $1 \@ $2.\n") if $debug;
	    }
	    close FH;
	    last;
	}

	# get list of 'remote' database connection identifiers
	my @tns_admin;
	push @tns_admin, (
	  "$oracle_home/network/admin",	# OCI 7 and 8.1
	  "$oracle_home/net80/admin",	# OCI 8.0
	) if $oracle_home;
	push @tns_admin, "/var/opt/oracle";
	foreach $d ( DBD::Oracle::ora_env_var("TNS_ADMIN"), ".", @tns_admin  ) {
	    next unless $d && open(FH, "<$d/tnsnames.ora");
	    $drh->trace_msg("Loading $d/tnsnames.ora\n") if $debug;
	    local *_;
	    while (<FH>) {
		next unless m/^\s*([-\w\.]+)\s*=/;
		my $name = $1;
		$drh->trace_msg("Found $name. ".($dbnames{$name} ? "(oratab entry overridden)" : "")."\n")
		    if $debug;
		$dbnames{$name} = 0; # exists but false (to distinguish from oratab)
	    }
	    close FH;
	    last;
	}

	$dbnames{0} = 1;	# mark as loaded (even if empty)
    }

    sub data_sources {
	my $drh = shift;
	load_dbnames($drh) unless %dbnames;
	my @names = sort  keys %dbnames;
	my @sources = map { $_ ? ("dbi:Oracle:$_") : () } @names;
	return @sources;
    }


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

	if ($dbname =~ /;/) {
	    my ($n,$v);
	    $dbname =~ s/^\s+//;
	    $dbname =~ s/\s+$//;
	    my @dbname = map {
		($n,$v) = split /\s*=\s*/, $_, -1;
		Carp::carp("DSN component '$_' is not in 'name=value' format")
		    unless defined $v && defined $n;
                (uc($n), $v)
	    } split /\s*;\s*/, $dbname;
	    my %dbname = ( PROTOCOL => 'tcp', @dbname );

	    # extract main attributes for connect_data portion
	    my @connect_data_attr = qw(SID INSTANCE_NAME SERVER SERVICE_NAME);
	    my %connect_data = map { ($_ => delete $dbname{$_}) }
		grep { exists $dbname{$_} } @connect_data_attr;
	    my $connect_data = join "", map { "($_=$connect_data{$_})" } keys %connect_data;

	    return $drh->DBI::set_err(-1,
		"Can't connect using this syntax without specifying a HOST and one of @connect_data_attr")
		unless $dbname{HOST} and %connect_data;

	    my @addrs = map { "($_=$dbname{$_})" } keys %dbname;
	    my $addrs = join "", @addrs;
	    if ($dbname{PORT}) {
		$addrs = "(ADDRESS=$addrs)";
	    }
	    else {
		$addrs = "(ADDRESS_LIST=(ADDRESS=$addrs(PORT=1526))"
				     . "(ADDRESS=$addrs(PORT=1521)))";
	    }
	    $dbname = "(DESCRIPTION=$addrs(CONNECT_DATA=$connect_data))";
	    $drh->trace_msg("connect using '$dbname'");
	}

	# If the application is asking for specific database
	# then we may have to mung the dbname

	$dbname = $1 if !$dbname && $user && $user =~ s/\@(.*)//s;

	$drh->trace_msg("$ORACLE_ENV environment variable not set\n")
		if !$ENV{$ORACLE_ENV} and $^O ne "MSWin32";

	# create a 'blank' dbh

	$user = '' if not defined $user;
        (my $user_only = $user) =~ s:/.*::;
	my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
	    'Name' => $dbname,
	    # these two are just for backwards compatibility
	    'USER' => uc $user_only, 'CURRENT_USER' => uc $user_only,
	    });

	# Call Oracle OCI logon func in Oracle.xs file
	# and populate internal handle data.
	DBD::Oracle::db::_login($dbh, $dbname, $user, $auth, $attr)
	    or return undef;

	if ($attr && $attr->{ora_module_name}) {
	    eval {
		$dbh->do(q{BEGIN DBMS_APPLICATION_INFO.SET_MODULE(:1,NULL); END;},
		       undef, $attr->{ora_module_name});
	    };
	}
	unless (length $user_only) {
	    $user_only = $dbh->selectrow_array(q{
		SELECT SYS_CONTEXT('userenv','session_user') FROM DUAL
	    });
	    $dbh_inner->{Username} = $user_only;
	    # these two are just for backwards compatibility
	    $dbh_inner->{USER} = $dbh_inner->{CURRENT_USER} = uc $user_only;
	}

	$dbh;
    }
    
     sub private_attribute_info {
            return { ora_home_key=>undef};
    }

}


{   package DBD::Oracle::db; # ====== DATABASE ======
    use strict;
    use DBI qw(:sql_types);

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

	# create a 'blank' sth

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

	# Call Oracle OCI parse func in Oracle.xs file.
	# and populate internal handle data.

	DBD::Oracle::st::_prepare($sth, $statement, @attribs)
	    or return undef;

	$sth;
    }


    sub ping {
	my($dbh) = @_;
	my $ok = 0;
	eval {
	    local $SIG{__DIE__};
	    local $SIG{__WARN__};
	    # we know that Oracle 7 prepare does a describe so this will
	    # actually talk to the server and is this a valid and cheap test.
	    my $sth =  $dbh->prepare("select SYSDATE from DUAL /* ping */");
	    # But Oracle 8+ doesn't talk to server unless we describe the query
	    $ok = $sth && $sth->FETCH('NUM_OF_FIELDS');
	};
	return ($@) ? 0 : $ok;
    }


    sub get_info {
	my($dbh, $info_type) = @_;
	require DBD::Oracle::GetInfo;
	my $v = $DBD::Oracle::GetInfo::info{int($info_type)};
	$v = $v->($dbh) if ref $v eq 'CODE';
	return $v;
    }

    sub private_attribute_info {
        return { ora_max_nested_cursors => undef,
                 ora_array_chunk_size   => undef,
                 ora_ph_type		=> undef,
                 ora_ph_csform		=> undef,
                 ora_parse_error_offset => undef,
                 ora_dbh_share		=> undef,
                 ora_use_proc_connection=> undef,
                 ora_envhp		=> undef,
                 ora_context		=> undef,
                 ora_svchp		=> undef,
                 ora_errhp		=> undef,
                 ora_init_mode		=> undef,
                 ora_charset		=> undef,	
                 ora_ncharset		=> undef,
                 ora_session_mode	=> undef,
                 };
    }
   

    sub table_info {
	my($dbh, $CatVal, $SchVal, $TblVal, $TypVal) = @_;
	# XXX add knowledge of temp tables, etc
	# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
	if (ref $CatVal eq 'HASH') {
	    ($CatVal, $SchVal, $TblVal, $TypVal) =
		@$CatVal{'TABLE_CAT','TABLE_SCHEM','TABLE_NAME','TABLE_TYPE'};
	}
	my @Where = ();
	my $Sql;
	if ( defined $CatVal && $CatVal eq '%' && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19a
		$Sql = <<'SQL';
SELECT NULL TABLE_CAT
     , NULL TABLE_SCHEM
     , NULL TABLE_NAME
     , NULL TABLE_TYPE
     , NULL REMARKS
  FROM DUAL
SQL
	}
	elsif ( defined $SchVal && $SchVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19b
		$Sql = <<'SQL';
SELECT NULL TABLE_CAT
     , s    TABLE_SCHEM
     , NULL TABLE_NAME
     , NULL TABLE_TYPE
     , NULL REMARKS
  FROM
(
  SELECT USERNAME s FROM ALL_USERS
  UNION
  SELECT 'PUBLIC' s FROM DUAL
)
 ORDER BY TABLE_SCHEM
SQL
	}
	elsif ( defined $TypVal && $TypVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19c
		$Sql = <<'SQL';
SELECT NULL TABLE_CAT
     , NULL TABLE_SCHEM
     , NULL TABLE_NAME
     , t.tt TABLE_TYPE
     , NULL REMARKS
  FROM
(
  SELECT 'TABLE'    tt FROM DUAL
    UNION
  SELECT 'VIEW'     tt FROM DUAL
    UNION
  SELECT 'SYNONYM'  tt FROM DUAL
    UNION
  SELECT 'SEQUENCE' tt FROM DUAL
) t
 ORDER BY TABLE_TYPE
SQL
	}
	else {
		$Sql = <<'SQL';
SELECT *
  FROM
(
  SELECT /*+ RULE*/
       NULL         TABLE_CAT
     , t.OWNER      TABLE_SCHEM
     , t.TABLE_NAME TABLE_NAME
     , decode(t.OWNER
	  , 'SYS'    , 'SYSTEM '
	  , 'SYSTEM' , 'SYSTEM '
          , '' ) || t.TABLE_TYPE TABLE_TYPE
     , c.COMMENTS   REMARKS
  FROM ALL_TAB_COMMENTS c
     , ALL_CATALOG      t
 WHERE c.OWNER      (+) = t.OWNER
   AND c.TABLE_NAME (+) = t.TABLE_NAME
   AND c.TABLE_TYPE (+) = t.TABLE_TYPE
)
SQL
		if ( defined $SchVal ) {
			push @Where, "TABLE_SCHEM LIKE '$SchVal' ESCAPE '\\'";
		}
		if ( defined $TblVal ) {