install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm

   1 package DBIx::DBSchema::DBD::Sybase;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA %typemap);
   5 use DBIx::DBSchema::DBD;
   6
   7 $VERSION = '0.03';
   8 @ISA = qw(DBIx::DBSchema::DBD);
   9
  10 %typemap = (
  11 #  'empty' => 'empty'
  12 );
  13
  14 =head1 NAME
  15
  16 DBIx::DBSchema::DBD::Sybase - Sybase database driver for DBIx::DBSchema
  17
  18 =head1 SYNOPSIS
  19
  20 use DBI;
  21 use DBIx::DBSchema;
  22
  23 $dbh = DBI->connect('dbi:Sybase:dbname=database', 'user', 'pass');
  24 $schema = new_native DBIx::DBSchema $dbh;
  25
  26 =head1 DESCRIPTION
  27
  28 This module implements a Sybase driver for DBIx::DBSchema.
  29
  30 =cut
  31
  32 sub columns {
  33   my($proto, $dbh, $table) = @_;
  34
  35   my $sth = $dbh->prepare("sp_columns \@table_name=$table")
  36   or die $dbh->errstr;
  37
  38   $sth->execute or die $sth->errstr;
  39   my @cols = map {
  40     [
  41       $_->{'column_name'},
  42       $_->{'type_name'},
  43       ($_->{'nullable'} ? 1 : ''),
  44       $_->{'length'},
  45       '', #default
  46       ''  #local
  47     ]
  48   } @{ $sth->fetchall_arrayref({}) };
  49   $sth->finish;
  50
  51   @cols;
  52 }
  53
  54 sub primary_key {
  55     return("StubbedPrimaryKey");
  56 }
  57
  58
  59 sub unique {
  60   my($proto, $dbh, $table) = @_;
  61   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] }
  62       grep { $proto->_is_unique($dbh, $_ ) }
  63         $proto->_all_indices($dbh, $table)
  64   };
  65 }
  66
  67 sub index {
  68   my($proto, $dbh, $table) = @_;
  69   my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] }
  70       grep { ! $proto->_is_unique($dbh, $_ ) }
  71         $proto->_all_indices($dbh, $table)
  72   };
  73 }
  74
  75 sub _all_indices {
  76   my($proto, $dbh, $table) = @_;
  77
  78   my $sth = $dbh->prepare_cached(<<END) or die $dbh->errstr;
  79     SELECT name
  80     FROM sysindexes
  81     WHERE id = object_id('$table') and indid between 1 and 254
  82 END
  83   $sth->execute or die $sth->errstr;
  84   my @indices = map { $_->[0] } @{ $sth->fetchall_arrayref() };
  85   $sth->finish;
  86   $sth = undef;
  87   @indices;
  88 }
  89
  90 sub _index_fields {
  91   my($proto, $dbh, $table, $index) = @_;
  92
  93   my @keys;
  94
  95   my ($indid) = $dbh->selectrow_array("select indid from sysindexes where id = object_id('$table') and name = '$index'");
  96   for (1..30) {
  97     push @keys, $dbh->selectrow_array("select index_col('$table', $indid, $_)") || ();
  98   }
  99
 100   return @keys;
 101 }
 102
 103 sub _is_unique {
 104   my($proto, $dbh, $table, $index) = @_;
 105
 106   my ($isunique) = $dbh->selectrow_array("select status & 2 from sysindexes where id = object_id('$table') and name = '$index'");
 107
 108   return $isunique;
 109 }
 110
 111 =head1 AUTHOR
 112
 113 Charles Shapiro <charles.shapiro@numethods.com>
 114 (courtesy of Ivan Kohler <ivan-dbix-dbschema@420.am>)
 115
 116 Mitchell Friedman <mitchell.friedman@numethods.com>
 117
 118 Bernd Dulfer <bernd@widd.de>
 119
 120 =head1 COPYRIGHT
 121
 122 Copyright (c) 2001 Charles Shapiro, Mitchell J. Friedman
 123 Copyright (c) 2001 nuMethods LLC.
 124 All rights reserved.
 125 This program is free software; you can redistribute it and/or modify it under
 126 the same terms as Perl itself.
 127
 128 =head1 BUGS
 129
 130 Yes.
 131
 132 The B<primary_key> method does not yet work.
 133
 134 =head1 SEE ALSO
 135
 136 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 137
 138 =cut
 139
 140 1;
 141