oraperl.pm

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

# Oraperl Emulation Interface for Perl 5 DBD::Oracle DBI
#
# Oraperl.pm
#
#   Copyright (c) 1994,1995 Tim Bunce
#
#   See the COPYRIGHT section in the Oracle.pm file for terms.
#
# To use this interface use one of the following invocations:
#
#       use Oraperl;
# or
#       eval 'use Oraperl; 1;' || die $@ if $] >= 5;
#
# The second form allows oraperl scripts to be used with
# both oraperl and perl 5.

package Oraperl;

require 5.004;

use DBI 1.21;
use Exporter;

$VERSION = substr(q$Revision: 1.44 $, 10);

@ISA = qw(Exporter);

@EXPORT = qw(
    &ora_login &ora_open &ora_bind &ora_fetch &ora_close
    &ora_logoff &ora_do &ora_titles &ora_lengths &ora_types
    &ora_commit &ora_rollback &ora_autocommit &ora_version
    &ora_readblob
    $ora_cache $ora_long $ora_trunc $ora_errno $ora_errstr
    $ora_verno $ora_debug
);

$debug    = 0 unless defined $debug;
$debugdbi = 0;
# $safe		# set true/false before 'use Oraperl' if needed.
$safe = 1 unless defined $safe;

# Help those who get core dumps from non-'safe' Oraperl (bad cursors)
use sigtrap qw(ILL);
if (!$safe) {
    $SIG{BUS} = $SIG{SEGV} = sub {
	print STDERR "Add BEGIN { \$Oraperl::safe=1 } above 'use Oraperl'.\n"
		unless $safe;
	goto &sigtrap::trap;
    };
}


# Install Driver (use of install_driver is a special case here)
$drh = DBI->install_driver('Oracle');
if ($drh) {
    print "DBD::Oracle driver installed as $drh\n" if $debug;
    $drh->trace($debug);
    $drh->{CompatMode} = 1;
    $drh->{Warn}       = 0;
}


use strict;

sub _func_ref {
    my $name = shift;
    my $pkg = ($Oraperl::safe) ? "DBI" : "DBD::Oracle";
    \&{"${pkg}::$name"};
}

sub _warn {
    my $prev_warn = shift;
    if ($_[0] =~ /^(Bad|Duplicate) free/) {
	return unless $ENV{PERL_DBD_DUMP} eq 'dump';
	print STDERR "Aborting with a core dump for diagnostics (PERL_DBD_DUMP)\n";
	CORE::dump;
    }
    $prev_warn ? &$prev_warn(@_) : warn @_;
}


#	-----------------------------------------------------------------
#
#	$lda = &ora_login($system_id, $name, $password)
#	&ora_logoff($lda)

sub ora_login {
    my($system_id, $name, $password) = @_;
    local($Oraperl::prev_warn) = $SIG{'__WARN__'} || 0; # must be local
    local($SIG{'__WARN__'}) = sub { _warn($Oraperl::prev_warn, @_) };
    return DBI->connect("dbi:Oracle:$system_id", $name, $password, {
	PrintError => 0, AutoCommit => 0
    });
}
sub ora_logoff {
    my($dbh) = @_;
    return if !$dbh;
    local($Oraperl::prev_warn) = $SIG{'__WARN__'} || 0; # must be local
    local($SIG{'__WARN__'}) = sub { _warn($Oraperl::prev_warn, @_) };
    $dbh->disconnect();
}



# -----------------------------------------------------------------
#
#   $csr = &ora_open($lda, $stmt [, $cache])
#   &ora_bind($csr, $var, ...)
#   &ora_fetch($csr [, $trunc])
#   &ora_do($lda, $stmt)
#   &ora_close($csr)

sub ora_open {
    my($lda, $stmt) = @_;
    $Oraperl::ora_cache_o = $_[2];	# temp hack to pass cache through

    my $csr = $lda->prepare($stmt) or return undef;

    # only execute here if no bind vars specified
    $csr->execute or return undef unless $csr->{NUM_OF_PARAMS};

    $csr;
}

*ora_bind  = _func_ref('st::execute');
*ora_fetch = \&{"DBD::Oracle::st::ora_fetch"};
*ora_close = _func_ref('st::finish');

sub ora_do {
    # error => undef
    # 0     => "0E0"	(0 but true)
    # >0    => >0
    my($lda, $stmt, @params) = @_;	# @params are an extension to the original Oraperl.

    return $lda->do($stmt, undef, @params);	# SEE DEFAULT METHOD IN DBI.pm

    # OLD CODE:
    # $csr is local, cursor will be closed on exit
    my $csr = $lda->prepare($stmt) or return undef;
    # Oracle OCI will automatically execute DDL statements in prepare()!
    # We must be carefull not to execute them again! This needs careful
    # examination and thought.
    # Perhaps oracle is smart enough not to execute them again?
    my $ret = $csr->execute(@params);
    my $rows = $csr->rows;
    ($rows == 0) ? "0E0" : $rows;
}


# -----------------------------------------------------------------
#
#   &ora_titles($csr [, $truncate])
#   &ora_lengths($csr)
#   &ora_types($csr)

sub ora_titles{
    my($csr, $trunc) = @_;
    warn "ora_titles: truncate option not implemented" if $trunc;
    @{$csr->{'NAME'}};
}
sub ora_lengths{
    @{shift->{'ora_lengths'}}		# oracle specific
}
sub ora_types{
    @{shift->{'ora_types'}}		# oracle specific
}


# -----------------------------------------------------------------
#
#   &ora_commit($lda)
#   &ora_rollback($lda)
#   &ora_autocommit($lda, $on_off)
#   &ora_version

*ora_commit   = _func_ref('db::commit');
*ora_rollback = _func_ref('db::rollback');

sub ora_autocommit {
    my($lda, $mode) = @_;
    $lda->{AutoCommit} = $mode;
    "0E0";
}
sub ora_version {
    my($sw)  = DBI->internal;
    print "\n";
    print "Oraperl emulation interface version $Oraperl::VERSION\n";
    print "$Oraperl::drh->{Attribution}\n";
    print "$sw->{Attribution}\n\n";
}


# -----------------------------------------------------------------
#
#   $ora_errno
#   $ora_errstr
*Oraperl::ora_errno  = \$DBI::err;
*Oraperl::ora_errstr = \$DBI::errstr;


# -----------------------------------------------------------------
#
#   $ora_verno
#   $ora_debug    not supported, use $h->debug(2) where $h is $lda or $csr
#   $ora_cache    not supported
#   $ora_long     used at ora_open()
#   $ora_trunc    used at ora_open()

$Oraperl::ora_verno = '3.000';	# to distinguish it from oraperl 2.4

# ora_long is left unset so that the DBI $h->{LongReadLen} attrib will be used
# by default. If ora_long is set then LongReadLen will be ignored (sadly) but
# that behaviour may change later to only apply to oraperl mode handles.
#$Oraperl::ora_long  = 80;	# 80, oraperl default
$Oraperl::ora_trunc = 0; 	# long trunc is error, oraperl default


# -----------------------------------------------------------------
#
# Non-oraperl extensions added here to make it easy to still run
# script using oraperl (by avoiding $csr->blob_read(...))

*ora_readblob = _func_ref('st::blob_read');


1;
__END__

=head1 NAME

Oraperl - Perl access to Oracle databases for old oraperl scripts

=head1 SYNOPSIS

  eval 'use Oraperl; 1;' || die $@ if $] >= 5;  # ADD THIS LINE TO OLD SCRIPTS

  $lda = &ora_login($system_id, $name, $password)
  $csr = &ora_open($lda, $stmt [, $cache])
  &ora_bind($csr, $var, ...)
  &ora_fetch($csr [, $trunc])
  &ora_close($csr)
  &ora_logoff($lda)

  &ora_do($lda, $stmt)

  &ora_titles($csr)
  &ora_lengths($csr)
  &ora_types($csr)
  &ora_commit($lda)
  &ora_rollback($lda)
  &ora_autocommit($lda, $on_off)
  &ora_version()

  $ora_cache
  $ora_long
  $ora_trunc
  $ora_errno
  $ora_errstr
  $ora_verno

  $ora_debug

=head1 DESCRIPTION

Oraperl is an extension to Perl which allows access to Oracle databases.

The original oraperl was a Perl 4 binary with Oracle OCI compiled into it.
The Perl 5 Oraperl module described here is distributed with L<DBD::Oracle>
(a database driver what operates within L<DBI>) and adds an extra layer over
L<DBI> method calls.
The Oraperl module should only be used to allow existing Perl 4 oraperl scripts
to run with minimal changes; any new development should use L<DBI> directly.

The functions which make up this extension are described in the
following sections. All functions return a false or undefined (in the
Perl sense) value to indicate failure.  You do not need to understand
the references to OCI in these descriptions. They are here to help
those who wish to extend the routines or to port them to new machines.

The text in this document is largely unchanged from the original Perl4
oraperl manual written by Kevin Stock <[e-mail]>. Any comments
specific to the DBD::Oracle Oraperl emulation are prefixed by B<DBD:>.
See the DBD::Oracle and DBI manuals for more information.

B<DBD:> In order to make the oraperl function definitions available in
perl5 you need to arrange to 'use' the Oraperl.pm module in each file
or package which uses them. You can do this by simply adding S<C<use
Oraperl;>> in each file or package. If you need to make the scripts work
with both the perl4 oraperl and perl5 you should add add the following
text instead:

  eval 'use Oraperl; 1;' || die $@ if $] >= 5;

=head2 Principal Functions

The main functions for database access are &ora_login(), &ora_open(),
&ora_bind(), &ora_fetch(), &ora_close(), &ora_do() and &ora_logoff().

=over 2

=item * ora_login

  $lda = &ora_login($system_id, $username, $password)

In order to access information held within an Oracle database, a
program must first log in to it by calling the &ora_login() function.
This function is called with three parameters, the system ID (see
below) of the Oracle database to be used, and the Oracle username and
password. The value returned is a login identifier (actually an Oracle
Login Data Area) referred to below as $lda.

Multiple logins may be active simultaneously. This allows a simple
mechanism for correlating or transferring data between databases.

Most Oracle programs (for example, SQL*Plus or SQL*Forms) examine the
environment variable ORACLE_SID or TWO_TASK to determine which database
to connect to. In an environment which uses several different
databases, it is easy to make a mistake, and attempt to run a program
on the wrong one.  Also, it is cumbersome to create a program which
works with more than one database simultaneously. Therefore, Oraperl
requires the system ID to be passed as a parameter. However, if the
system ID parameter is an empty string then oracle will use the
existing value of ORACLE_SID or TWO_TASK in the usual manner.

Example:

  $lda = &ora_login('personnel', 'scott', 'tiger') || die $ora_errstr;

This function is equivalent to the OCI olon and orlon functions.

B<DBD:> note that a name is assumed to be a TNS alias if it does not
appear as the name of a SID in /etc/oratab or /var/opt/oracle/oratab.
See the code in Oracle.pm for the full logic of database name handling.

B<DBD:> Since the returned $lda is a Perl5 reference the database login
identifier is now automatically released if $lda is overwritten or goes
out of scope.

=item * ora_open

  $csr = &ora_open($lda, $statement [, $cache])

To specify an SQL statement to be executed, the program must call the
&ora_open() function. This function takes at least two parameters: a
login identifier (obtained from &ora_login()) and the SQL statement to
be executed. An optional third parameter specifies the size of the row
cache to be used for a SELECT statement. The value returned from
&ora_open() is a statement identifier (actually an ORACLE Cursor)
referred to below as $csr.

If the row cache size is not specified, a default size is
used. As distributed, the default is five rows, but this
may have been changed at your installation (see the
&ora_version() function and $ora_cache variable below).

Examples:

 $csr = &ora_open($lda, 'select ename, sal from emp order by ename', 10);

 $csr = &ora_open($lda, 'insert into dept values(:1, :2, :3)');

This function is equivalent to the OCI oopen and oparse functions. For
statements which do not contain substitution variables (see the section
Substitution Variables below), it also uses of the oexec function. For
SELECT statements, it also makes use of the odescr and odefin functions
to allocate memory for the values to be returned from the database.

=item * ora_bind

  &ora_bind($csr, $var, ...)

If an SQL statement contains substitution variables (see the section
Substitution Variables below), &ora_bind() is used to assign actual
values to them. This function takes a statement identifier (obtained
from &ora_open()) as its first parameter, followed by as many
parameters as are required by the statement.

Example:

 &ora_bind($csr, 50, 'management', 'Paris');

This function is equivalent to the OCI obndrn and oexec statements.

The OCI obndrn function does not allow empty strings to be bound. As
distributed, $ora_bind therefore replaces empty strings with a single
space. However, a compilation option allows this substitution to be
suppressed, causing &ora_bind() to fail. The output from the
&ora_version() function specifies which is the case at your installation.

=item * ora_fetch

 $nfields = &ora_fetch($csr)

 @data = &ora_fetch($csr [, $trunc])

The &ora_fetch() function is used in conjunction with a SQL SELECT
statement to retrieve information from a database.  This function takes
one mandatory parameter, a statement identifier (obtained from
&ora_open()).

Used in a scalar context, the function returns the number of fields
returned by the query but no data is actually fetched. This may be
useful in a program which allows a user to enter a statement interactively.

Example:

 $nfields = &ora_fetch($csr);

Used in an array context, the value returned is an array containing the
data, one element per field. Note that this will not work as expected:

 @data = &ora_fetch($csr) || die "...";    # WRONG

The || forces a scalar context so ora_fetch returns the number of fields.

An optional second parameter may be supplied to indicate whether the
truncation of a LONG or LONG RAW field is to be permitted (non-zero) or
considered an error (zero). If this parameter is not specified, the
value of the global variable $ora_trunc is used instead. Truncation of
other datatypes is always considered a error.

B<DBD:> The optional second parameter to ora_fetch is not supported.
A DBI usage error will be generated if a second parameter is supplied.
Use the global variable $ora_trunc instead. Also note that the
experimental DBI blob_read method can be used to retrieve a long:

  $csr->blob_read($field, $offset, $len [, \$dest, $destoffset]);

If truncation occurs, $ora_errno will be set to 1406.  &ora_fetch()
will complete successfully if truncation is permitted, otherwise it
will fail.

&ora_fetch() will fail at the end of the data or if an error occurs. It
is possible to distinguish between these cases by testing the value of
the variable $ora_errno. This will be zero for end of data, non-zero if
an error has occurred.