Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / DBD / Multiplex.pm

my $mplx_trace = 0;

# vim:ts=4
{
    package DBD::Multiplex;

    require DBI;
    require Carp;

    @EXPORT = ();
    $VERSION = substr(q$Revision: 1.2 $, 9,-1) -1;

#   $Id: Multiplex.pm,v 1.2 1999/07/29 00:11:57 timbo Exp $
#
#   Copyright (c) 1999, Tim Bunce & Thomas Kishel
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.

    $drh = undef;       # holds driver handle once initialised
    $err = 0;           # The $DBI::err value

    sub driver {
        return $drh if $drh;
        my($class, $attr) = @_;
        $class .= "::dr";
        ($drh) = DBI::_new_drh($class, {
            'Name' => 'Multiplex',
            'Version' => $VERSION,
            'Attribution' => 'DBD Multiplex by Tim Bunce & Thomas Kishel',
	});
        return $drh;
    }


    # functions for calling a method for each child handle

    sub mplx_do_calls {		# 'bottom-level' support function to do the calls
        my ($method, $handles, $wantarray, $opts) = (shift,shift,shift,shift);
	my $errh = $opts->{errh};	# handle to record error on
	my $stop = $opts->{stop_on}||'';# stop on first 'err' or 'ok' else do all
	my $trace= $opts->{trace};
        my @results;
	my @errors;	# sparse array paralleling $results[0..n]
	warn "mplx_do_calls $method for (@$handles)" if $trace;
	foreach my $h (@$handles) {        # child handle
	    push @results, ($wantarray) ? [        $h->$method(@_) ]
				        : [ scalar $h->$method(@_) ];
	    if (my $err = $h->err) {
		my $errstr = $h->errstr;
		$errors[ @results-1 ] = [ $err, $errstr ];
		DBI::set_err($errh, $err, $errstr) if $errh;
		warn "mplx_do_calls $h->$method ERROR: $err, $errstr" if $trace;
		last if $stop eq 'err';
	    }
	    else {
		warn "mplx_do_calls $h->$method OK: @{ $results[-1] }" if $trace;
		last if $stop eq 'ok';
	    }
	}
	return (\@results, \@errors);
    }

    #	XXX need variants/flags for
    #	- call-each-till-first-success-then-stop
    #	- call-all-return-first-success-else-error
    #	- call-all-return-most-common-result (eg three-way-voting etc)
    #	In some cases the default behaviour may depend on the method being called.
    #	In others the application may want to override that for specific cases
    #	(using \%attrib)
    sub mplx_method_all {
	my $method  = shift;
	my $ph      = shift;
	my $handles = $ph->{mplx_h} || die;

	my %opts = ( errh => $ph, stop_on => 'err', trace => $mplx_trace );

        my ($results, $errors)
	    = mplx_do_calls($method, $handles, wantarray, \%opts, @_);

	my $result = $results->[0];	# pick results to return
	return $result->[0] unless wantarray;
	return @$result;
    }

}



{   package DBD::Multiplex::dr; # ====== DRIVER ======
    $imp_data_size = 0;

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

	# XXX parse $dsn and make multiple connects
	# need to define good syntax
	my $dbh1 = DBI->connect($dsn, $user, $auth, $attr);
	return DBI::set_err($drh, $DBI::err, $DBI::errstr) unless $dbh1;

	my ($this) = DBI::_new_dbh($drh, {
	    Name => $dsn,
	    User => $user,
	    mplx_h => [ $dbh1 ],
	});

	return $this;
    }

    sub disconnect_all { }
    sub DESTROY { }
}



{   package DBD::Multiplex::db; # ====== DATABASE ======
    $imp_data_size = 0;

    use strict;

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

	my $handles = $dbh->{mplx_h} || die;
	my %opts = ( errh => $dbh );
        my ($results, $errors)
	    = DBD::Multiplex::mplx_do_calls('prepare', $handles, wantarray, \%opts, @_);
	return if @$errors;

	my ($outer, $sth) = DBI::_new_sth($dbh, {
	    'Statement'   => $statement,
	    mplx_h => [ map { $_->[0] } @$results ],
	});
	$outer;
    }

    # XXX replace this with dynamic info from updated DBI
    # XXX needs expanding manually in the short term
    use subs qw(FETCH STORE DESTROY);

    sub AUTOLOAD {
	my $method = $DBD::Multiplex::db::AUTOLOAD;
	$method =~ s/^DBD::Multiplex::db:://;
	warn "db AUTOLOAD $method(@_)" if $mplx_trace;

	my @results = (wantarray)
		? (       DBD::Multiplex::mplx_method_all($method, @_))
		: (scalar DBD::Multiplex::mplx_method_all($method, @_));

	return $results[0] unless wantarray;
	return @results;
    }

}


{   package DBD::Multiplex::st; # ====== STATEMENT ======
    $imp_data_size = 0;
    use strict;

    # XXX replace this with dynamic info from updated DBI
    # XXX needs expanding manually in the short term
    use subs qw(execute fetch fetchrow_arrayref finish STORE FETCH DESTROY);

    sub AUTOLOAD {
	my $method = $DBD::Multiplex::st::AUTOLOAD;
	$method =~ s/^DBD::Multiplex::st:://;
	warn "st AUTOLOAD $method(@_)" if $mplx_trace;

	my @results = (wantarray)
		? (       DBD::Multiplex::mplx_method_all($method, @_))
		: (scalar DBD::Multiplex::mplx_method_all($method, @_));

	return $results[0] unless wantarray;
	return @results;
    }

}

1;
__END__

=head1 NAME

DBD::Multiplex - A DBI driver multiplexer

=head1 SYNOPSIS

  use DBI;

  $dbh = DBI->connect("dbi:Multiplex:dsn", $user, $passwd);

  # See the DBI module documentation for full details

=head1 DESCRIPTION

To be written

=cut