view release on metacpan or  search on metacpan

lib/DBI/Gofer/Execute.pm  view on Meta::CPAN

        push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
    }

    if (my $pai = $h->private_attribute_info) {
        push @attr_names, keys %$pai;
    }
    else {
        push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []};
    }
    if (my $fra = $self->{forced_response_attributes}) {
        push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []}
    }
    $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n");

    # cache into the dbh even for sth, as the dbh is usually longer lived
    return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names;
}


sub execute_sth_request {
    my ($self, $request) = @_;
    my $dbh;
    my $sth;
    my $last_insert_id;
    my $stats = $self->{stats};

    my $rv = eval {
        $dbh = $self->_connect($request);

        my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ]
        shift @$args; # discard wantarray
        my $meth = shift @$args;
        $stats->{method_calls_sth}->{$meth}++;
        $sth = $dbh->$meth(@$args);
        my $last = '(sth)'; # a true value (don't try to return actual sth)

        # execute methods on the sth, e.g., bind_param & execute
        if (my $calls = $request->sth_method_calls) {
            for my $meth_call (@$calls) {
                my $method = shift @$meth_call;
                $stats->{method_calls_sth}->{$method}++;
                $last = $sth->$method(@$meth_call);
            }
        }

        if (my $lid_args = $request->dbh_last_insert_id_args) {
            $stats->{method_calls_sth}->{last_insert_id}++;
            $last_insert_id = $dbh->last_insert_id( @$lid_args );
        }

        $last;
    };
    my $response = $self->new_response_with_err($rv, $@, $dbh);

    return $response if not $dbh;

    $response->last_insert_id( $last_insert_id )
        if defined $last_insert_id;

    # even if the eval failed we still want to try to gather attribute values
    # (XXX would be nice to be able to support streaming of results.
    # which would reduce memory usage and latency for large results)
    if ($sth) {
        $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) );
        $sth->finish;
    }

    # does this request also want any dbh attributes returned?
    my $dbh_attr_set;
    if (my $dbh_attributes = $request->dbh_attributes) {
        $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes);
    }
    # XXX needs to be integrated with private_attribute_info() etc
    if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) {
        @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr);
    }
    $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set;

    $self->reset_dbh($dbh);

    return $response;
}


sub gather_sth_resultsets {
    my ($self, $sth, $request, $response) = @_;
    my $resultsets = eval {

        my $attr_names = $self->_std_response_attribute_names($sth);
        my $sth_attr = {};
        $sth_attr->{$_} = 1 for @$attr_names;

        # let the client add/remove sth attributes
        if (my $sth_result_attr = $request->sth_result_attr) {
            $sth_attr->{$_} = $sth_result_attr->{$_}
                for keys %$sth_result_attr;
        }
        my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr;

        my $row_count = 0;
        my $rs_list = [];
        while (1) {
            my $rs = $self->fetch_result_set($sth, \@sth_attr);
            push @$rs_list, $rs;
            if (my $rows = $rs->{rowset}) {
                $row_count += @$rows;
            }
            last if $self->{forced_single_resultset};
            last if !($sth->more_results || $sth->{syb_more_results});
         }

        my $stats = $self->{stats};
        $stats->{rows_returned_total} += $row_count;
        $stats->{rows_returned_max} = $row_count
            if $row_count > ($stats->{rows_returned_max}||0);

        $rs_list;
    };
    $response->add_err(1, $@) if $@;
    return $resultsets;
}