view release on metacpan or  search on metacpan

lib/DBIx/PgLink/Adapter/SybaseASE.pm  view on Meta::CPAN

  $next->($self, $catalog, $schema, $table, $column);
};


sub _uppercase_hashref_keys {
  my $href = shift;
  my @keys = keys %{$href};
  for my $key (@keys) {
    $href->{uc $key} = delete $href->{$key};
  }
}


around 'expand_table_info' => sub {
  my ($next, $self, $table) = @_;

  _uppercase_hashref_keys($table);

  # bug: DBD::Sybase v0.95 return non-standard field name
  $table->{TABLE_CAT}   ||= $table->{TABLE_QUALIFIER};
  $table->{TABLE_SCHEM} ||= $table->{TABLE_OWNER};

  $next->($self, $table);
};


around 'expand_column_info', 'expand_primary_key_info' => sub {
  my ($next, $self, $info) = @_;

  _uppercase_hashref_keys($info);

  $next->($self, $info);
};


# DBD::Sybase has problem with placeholders in prepared SP call
for my $func (qw/
  prepare prepare_cached
/) {
  around $func => sub {
    my $next = shift;
    my $self = shift;
    my $statement = shift;
    my $attr = shift;

    if ($statement =~ /^EXEC.*\?/i && $self->dbh->{Driver}->{Name} eq 'Sybase') {
      return $self->new_statement(
        class     => 'DBIx::PgLink::Adapter::SybaseASE::PreparedProcedure',
        statement => $statement,
        parent    => $self,
        method    => $func,
        defined $attr ? %{$attr} : (),
      );
    } else {
      return $next->($self, $statement, $attr);
    }
  };
}

has 'quote_literal_types' => ( # initialize once for connection
  is=>'ro', isa=>'HashRef', lazy=>1, 
  default=>sub { 
    return {
      SQL_BINARY()    => undef,
      SQL_BLOB()      => undef,
      SQL_CHAR()      => undef,
      SQL_DATE()      => undef,
      SQL_VARBINARY() => undef,
      SQL_VARCHAR()   => undef,
  } },
);




around 'routine_info_arrayref' => sub { 
  my ($next, $self, $catalog, $schema, $routine, $type) = @_;

  # TODO: parse $type and add Java function support (very low priority)
  return $next->($self, $catalog, $schema, $routine, $type) unless $type =~ /PROCEDURE/;

  my @result = ();

  my $full_proc_name = $self->quote_identifier(
    $catalog,
    'dbo',
    'sp_stored_procedures'
  );
  my $sth = $self->prepare("exec $full_proc_name ?, ?, ?");
  $sth->execute( # name in reverse order
    $routine,
    $schema,
    $catalog,
  );

  while (my $sp = $sth->fetchrow_hashref) {
    my $proc_name = $sp->{procedure_name};
    $proc_name =~ s/;\d+$//; # obsolete procedure group number
    my $i = {
      SPECIFIC_CATALOG => $sp->{procedure_qualifier},
      SPECIFIC_SCHEMA  => $sp->{procedure_owner},
      SPECIFIC_NAME    => $proc_name,
      ROUTINE_CATALOG  => $sp->{procedure_qualifier},
      ROUTINE_SCHEMA   => $sp->{procedure_owner},
      ROUTINE_NAME     => $proc_name,
      ROUTINE_TYPE     => 'PROCEDURE',
      DATA_TYPE        => undef,
    };
    $self->expand_routine_info($i)
    and push @result, $i;
  }
  $sth->finish;

  return \@result;

};


around 'expand_routine_argument_info' => sub {
  my ($next, $self, $arg) = @_;