view release on metacpan or  search on metacpan

lib/Net/Z3950/DBIServer.pm  view on Meta::CPAN

			 noop => $noop,
			 rs => {}, # mapping of resultSetId to RS objects
		     }, $class;
    return $horribleTemporaryGlobalHandle;
}


sub dbi_driver {
    my $this = shift();
    my $dbname = $this->{config}->dataSource();
    if ($dbname =~ /^dbi:(.*?):/i) {
	return $1;
    } else {
	die "can't extract DBI driver from '$dbname'";
    }
}

sub init_handler {
    my $args = shift();

    warn("INIT: args = {\n" .
	 join("", map { "    $_ -> '" . $args->{$_} . "'\n" }
	      sort keys %$args) .
	 "}\n") if 0;

    $args->{IMP_ID} = "169"; # Mike Taylor's implementor ID
    $args->{IMP_NAME} = ref($horribleTemporaryGlobalHandle);
    $args->{IMP_VER} = "zSQLgate $VERSION";
    $args->{HANDLE} = $horribleTemporaryGlobalHandle;
    my $this = $args->{HANDLE};
    my $config = $this->{config};

    my $dbname = $config->dataSource();
    my $userName = $config->userName();
    my $passWord = $config->passWord();
    #warn "dbname='$dbname', userName='$userName', passWord='$passWord'";
    if ($this->{noop}) {
	warn "no-op mode: not connecting to database";
    } else {
	$this->{dbh} = DBI->connect($dbname, $userName, $passWord,
				    { RaiseError => 0, AutoCommit => 0 })
	or die "can't open dataSource '$dbname': " . $DBI::errstr;

	my $options = $config->options();
	if ($options) {
	    foreach my $key (sort keys %$options) {
		my $val = $options->{$key};
		my $old = $this->{dbh}->{$key};
		$this->{dbh}->{$key} = $val;
		warn "set option '$key' to '$val' (was '$old')";
	    }
	}
    }

    ### We'd prefer to report a connect() error politely to the
    #	client, but SimpleServer doesn't seem to have a way to do this
    #	yet.  You can pass an error code but no addInfo.


    # I can't imagine why this isn't the default
    #$this->{dbh}->{'mysql_enable_utf8'} = 1;
    warn "UTF8='" . $this->{dbh}->{'mysql_enable_utf8'} . "'";
}


sub search_handler {
    my $args = shift();

    warn "in search_handler()\n";
    eval {
	_real_search_handler($args, @_);
    }; if ($@ && ref $@ && $@->isa('Net::Z3950::DBIServer::Exception')) {
	$args->{ERR_CODE} = $@->code();
	$args->{ERR_STR} = $@->addinfo();
    } elsif ($@) {
	die $@;
    }
}


sub _real_search_handler {
    my $args = shift();
    my $this = $args->{HANDLE};

    $this->_maybe_reload_config();
    my $dbnames = $args->{DATABASES};
    ### Should SimpleServer (or something) provide constants for diagnostics?
    if (@$dbnames == 0) {
	# Specified combination of databases not supported ... not great!
	die new Net::Z3950::DBIServer::Exception(23);
    } elsif (@$dbnames > 1) {
	# Too many databases specified (addInfo = maximum)
	die new Net::Z3950::DBIServer::Exception(111, '1');
    }

    my $dbname = $dbnames->[0];
    my $config = $this->{config}->forDb($dbname);
    if (!defined $config) {
	# Database does not exist (addInfo = database name)
	# How is this different from 109 Database unavailable?
	die new Net::Z3950::DBIServer::Exception(235, $dbname);
    }

    my $rpn = $args->{RPN};
    if (defined $rpn) {
	#warn "*GFS-generated RPN = " . Dumper($rpn);
    } else {
	### Pathetic hack: improve this radically!  :-)
	#die new Net::Z3950::DBIServer::Exception(107, "CQL:" . $args->{CQL});
	$rpn = bless {
	    attributeSet => "1.2.840.10003.3.1",
	    query => bless {
		'attributes' => bless([], 'Net::Z3950::RPN::Attributes'),
		'term' => $args->{CQL},
	    }, "Net::Z3950::RPN::Term",
	}, "Net::Z3950::APDU::Query";
	#warn "*Hand-translated RPN = " . Dumper($rpn);
    }

    my $aux = $config->auxiliary();
    my $tablename = @$aux == 0 ? undef : $config->tablename();
    my $SQLcond = $rpn->{query}->SQLcond($this, $config->searchSpec(),