interbase.pm

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

#   $Id: InterBase.pm 399 2008-01-08 08:51:35Z edpratomo $
#
#   Copyright (c) 1999-2008 Edwin Pratomo
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file,
#   with the exception that it cannot be placed on a CD-ROM or similar media
#   for commercial distribution without the prior approval of the author.

require 5.004;

package DBD::InterBase;
use strict;
use Carp;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
use DBI 1.41 ();
require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);
$VERSION = '0.48';

bootstrap DBD::InterBase $VERSION;

use vars qw($VERSION $err $errstr $drh);

$err = 0;
$errstr = "";
$drh = undef;


sub CLONE
{
    $drh = undef;
}


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

    $class .= "::dr";

    $drh = DBI::_new_drh($class, {'Name' => 'InterBase',
                                  'Version' => $VERSION,
                                  'Err'    => \$DBD::InterBase::err,
                                  'Errstr' => \$DBD::InterBase::errstr,
                                  'Attribution' => 'DBD::InterBase by Edwin Pratomo and Daniel Ritz'});
    $drh;
}

# taken from JWIED's DBD::mysql, with slight modification
sub _OdbcParse($$$) 
{
    my($class, $dsn, $hash, $args) = @_;
    my($var, $val);

    if (!defined($dsn))
       { return; }

    while (length($dsn)) 
    {
        if ($dsn =~ /([^;]*)[;]\r?\n?(.*)/s) 
        {
            $val = $1;
            $dsn = $2;
        } 
        else 
        {
            $val = $dsn;
            $dsn = '';
        }
        if ($val =~ /([^=]*)=(.*)/) 
        {
            $var = $1;
            $val = $2;
            if ($var eq 'hostname') 
                { $hash->{'host'} = $val; } 
            elsif ($var eq 'db'  ||  $var eq 'dbname') 
                { $hash->{'database'} = $val; } 
            else 
                { $hash->{$var} = $val; }
        } 
        else 
        {
            foreach $var (@$args) 
            {
                if (!defined($hash->{$var})) 
                {
                    $hash->{$var} = $val;
                    last;
                }
            }
        }
    }
    $hash->{host} = "$hash->{host}/$hash->{port}" if ($hash->{host} && $hash->{port});
    $hash->{database} = "$hash->{host}:$hash->{database}" if $hash->{host};
}


package DBD::InterBase::dr;

sub connect 
{
    my($drh, $dsn, $dbuser, $dbpasswd, $attr) = @_;

    $dbuser   ||= $ENV{ISC_USER};       #"SYSDBA";
    $dbpasswd ||= $ENV{ISC_PASSWORD};   #"masterkey";

    my ($this, $private_attr_hash);

    $private_attr_hash = {
        'Name' => $dsn,
        'user' => $dbuser,
        'password' => $dbpasswd
    };

    DBD::InterBase->_OdbcParse($dsn, $private_attr_hash,
                               ['database', 'host', 'port', 'ib_role', 'ib_dbkey_scope',
                                'ib_charset', 'ib_dialect', 'ib_cache', 'ib_lc_time']);

    # second attr args will be retrieved using DBIc_IMP_DATA
    my $dbh = DBI::_new_dbh($drh, {}, $private_attr_hash);

    DBD::InterBase::db::_login($dbh, $dsn, $dbuser, $dbpasswd, $attr) 
        or return undef;

    $dbh;
}

package DBD::InterBase::db;
use strict;
use Carp;

sub do 
{
    my($dbh, $statement, $attr, @params) = @_;
    my $rows;
    if (@params) 
    {
        my $sth = $dbh->prepare($statement, $attr) or return undef;
        $sth->execute(@params) or return undef;
        $rows = $sth->rows;
    } 
    else 
    {
        $rows = DBD::InterBase::db::_do($dbh, $statement, $attr) or return undef;
    }       
    ($rows == 0) ? "0E0" : $rows;
}

sub prepare 
{
    my ($dbh, $statement, $attribs) = @_;
    
    my $sth = DBI::_new_sth($dbh, {'Statement' => $statement });
    DBD::InterBase::st::_prepare($sth, $statement, $attribs)
        or return undef;
    $sth;
}

# from Michael Arnett <[e-mail]> :
sub tables
{
    my $dbh = shift;
    my @tables;
    my @row;

    my $sth = $dbh->prepare(q{
      SELECT rdb$relation_name 
      FROM rdb$relations 
      WHERE (rdb$system_flag IS NULL OR rdb$system_flag = 0) 
        AND rdb$view_source IS NULL;  
    }) or return undef;

    $sth->{ChopBlanks} = 1;
    $sth->execute;
    while (@row = $sth->fetchrow_array) {
        push(@tables, @row);
    }
    return @tables;
}

sub table_info
{
    my $dbh = shift;

    my $sth = $dbh->prepare(q{
      SELECT
        NULL                      TABLE_CAT, 
        a.rdb$owner_name          TABLE_SCHEM,
        a.rdb$relation_name       TABLE_NAME,
        CAST('TABLE' AS CHAR(5))  TABLE_TYPE,
        a.rdb$description         REMARKS
      FROM rdb$relations a
      WHERE a.rdb$system_flag=0 AND a.rdb$view_blr IS NULL
        UNION ALL
      SELECT
        NULL                      TABLE_CAT, 
        b.rdb$owner_name          TABLE_SCHEM,
        b.rdb$relation_name       TABLE_NAME,
        CAST('VIEW' AS CHAR(5))   TABLE_TYPE,
        b.rdb$description         REMARKS
      FROM rdb$relations b
      WHERE b.rdb$system_flag=0 AND b.rdb$view_blr IS NOT NULL
    });
    $sth->execute() or return undef;

    return $sth;
}

sub ping 
{
    my($dbh) = @_;

    local $SIG{__WARN__} = sub { } if $dbh->{PrintError};
    local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
    my $ret = DBD::InterBase::db::_ping($dbh);

    return $ret;
}

# The get_info function was automatically generated by
# DBI::DBD::Metadata::write_getinfo_pm v1.05.

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

# The type_info_all function was automatically generated by
# DBI::DBD::Metadata::write_typeinfo_pm v1.05.

sub type_info_all
{
    my ($dbh) = @_;
    require DBD::InterBase::TypeInfo;
    return [ @$DBD::InterBase::TypeInfo::type_info_all ];
}

1;

__END__

=head1 NAME

DBD::InterBase - DBI driver for Firebird and InterBase RDBMS server

=head1 SYNOPSIS

  use DBI;

  $dbh = DBI->connect("dbi:InterBase:db=$dbname", "sysdba", "masterkey");

  # See the DBI module documentation for full details

=head1 DESCRIPTION

DBD::InterBase is a Perl module which works with the DBI module to provide
access to Firebird and InterBase databases.

=head1 MODULE DOCUMENTATION

This documentation describes driver specific behavior and restrictions. 
It is not supposed to be used as the only reference for the user. In any 
case consult the DBI documentation first !

=head1 THE DBI CLASS

=head2 DBI Class Methods

=over 4

=item B<connect>

To connect to a database with a minimum of parameters, use the 
following syntax: 

  $dbh = DBI->connect("dbi:InterBase:dbname=$dbname", "sysdba", "masterkey");

This connects to the database $dbname at localhost as SYSDBA user with the
default password. 

Multiline DSN is acceptable. Here is an example of connect statement which uses all 
possible parameters: 

   $dsn =<< "DSN";
 dbi:InterBase:dbname=$dbname;
 host=$host;
 port=$port;
 ib_dialect=$dialect;
 ib_role=$role;
 ib_charset=$charset;
 ib_cache=$cache
 DSN

 $dbh =  DBI->connect($dsn, $username, $password);

The $dsn is prefixed by 'dbi:InterBase:', and consists of key-value
parameters separated by B<semicolons>. New line may be added after the
semicolon. The following is the list of valid parameters and their
respective meanings:

    parameter       meaning                                 optional?
    -----------------------------------------------------------------
    database        path to the database                    required
    dbname          path to the database
    db              path to the database
    hostname        hostname / IP address                   optional
    host            hostname / IP address
    port            port number                             optional
    ib_dialect      the SQL dialect to be used              optional
    ib_role         the role of the user                    optional
    ib_charset      character set to be used                optional
    ib_cache        number of database cache buffers        optional
    ib_dbkey_scope  change default duration of RDB$DB_KEY   optional

B<database> could be used interchangebly with B<dbname> and B<db>. 
To connect to a remote host, use the B<host> parameter. 
Here is an example of DSN to connect to a remote Windows host:

 $dsn = "dbi:InterBase:db=C:/temp/test.gdb;host=rae.cumi.org;ib_dialect=3";

Database file alias introduced in Firebird 1.5 can be used too. In the following 
example, "billing" is defined in aliases.conf:

 $dsn = 'dbi:InterBase:hostname=192.168.88.5;db=billing;ib_dialect=3';
 
Firebird as of version 1.0 listens on port specified within the services
file. To connect to port other than the default 3050, add the port number at
the end of host name, separated by a slash. Example:

 $dsn = 'dbi:InterBase:db=/data/test.gdb;host=localhost/3060';

InterBase 6.0 introduces B<SQL dialect> to provide backward compatibility with
databases created by older versions of InterBase. In short, SQL dialect
controls how InterBase interprets:

 - double quotes
 - the DATE datatype
 - decimal and numeric datatypes
 - new 6.0 reserved keywords

Valid values for B<ib_dialect> are 1, 2, and 3. The driver's default value is
1. 

B<ib_role> specifies the role of the connecting user. B<SQL role> is
implemented by InterBase to make database administration easier when dealing
with lots of users. A detailed reading can be found at:

 http://www.ibphoenix.com/ibp_sqlroles.html

If B<ib_cache> is not specified, the default database's cache size value will be 
used. The InterBase Operation Guide discusses in full length the importance of 
this parameter to gain the best performance.

=item B<available_drivers>

  @driver_names = DBI->available_drivers;

Implemented by DBI, no driver-specific impact.

=item B<data_sources>

This method is not yet implemented.

=item B<trace>

  DBI->trace($trace_level, $trace_file)

Implemented by DBI, no driver-specific impact.

=back


=head2 DBI Dynamic Attributes

See Common Methods. 

=head1 METHODS COMMON TO ALL DBI HANDLES

=over 4

=item B<err>

  $rv = $h->err;

Supported by the driver as proposed by DBI. 

=item B<errstr>

  $str = $h->errstr;

Supported by the driver as proposed by DBI. 

=item B<state>

This method is not yet implemented.

=item B<trace>

  $h->trace($trace_level, $trace_filename);

Implemented by DBI, no driver-specific impact.

=item B<trace_msg>

  $h->trace_msg($message_text);

Implemented by DBI, no driver-specific impact.

=item B<func>

See B<Transactions> section for information about invoking C<ib_set_tx_param()>
from func() method.

=back

=head1 ATTRIBUTES COMMON TO ALL DBI HANDLES

=over 4

=item B<Warn> (boolean, inherited)

Implemented by DBI, no driver-specific impact.

=item B<Active> (boolean, read-only)

Supported by the driver as proposed by DBI. A database 
handle is active while it is connected and  statement 
handle is active until it is finished. 

=item B<Kids> (integer, read-only)

Implemented by DBI, no driver-specific impact.

=item B<ActiveKids> (integer, read-only)

Implemented by DBI, no driver-specific impact.

=item B<CachedKids> (hash ref)

Implemented by DBI, no driver-specific impact.

=item B<CompatMode> (boolean, inherited)

Not used by this driver. 

=item B<InactiveDestroy> (boolean)

Implemented by DBI, no driver-specific impact.

=item B<PrintError> (boolean, inherited)

Implemented by DBI, no driver-specific impact.