File Coverage

blib/lib/DBIx/DBSchema/DBD/Sybase.pm
Criterion Covered Total %
statement 9 44 20.4
branch 0 10 0.0
condition 0 3 0.0
subroutine 3 10 30.0
pod 4 4 100.0
total 16 71 22.5


line stmt bran cond sub pod time code
1             package DBIx::DBSchema::DBD::Sybase;
2              
3 1     1   674 use strict;
  1         2  
  1         53  
4 1     1   4 use vars qw($VERSION @ISA %typemap);
  1         1  
  1         55  
5 1     1   325 use DBIx::DBSchema::DBD;
  1         1  
  1         348  
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 0     0 1   my($proto, $dbh, $table) = @_;
34              
35 0 0         my $sth = $dbh->prepare("sp_columns \@table_name=$table")
36             or die $dbh->errstr;
37              
38 0 0         $sth->execute or die $sth->errstr;
39 0 0         my @cols = map {
40 0           [
41             $_->{'column_name'},
42             $_->{'type_name'},
43             ($_->{'nullable'} ? 1 : ''),
44             $_->{'length'},
45             '', #default
46             '' #local
47             ]
48 0           } @{ $sth->fetchall_arrayref({}) };
49 0           $sth->finish;
50              
51 0           @cols;
52             }
53              
54             sub primary_key {
55 0     0 1   return("StubbedPrimaryKey");
56             }
57              
58              
59             sub unique {
60 0     0 1   my($proto, $dbh, $table) = @_;
61 0           my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] }
  0            
62 0           grep { $proto->_is_unique($dbh, $_ ) }
63             $proto->_all_indices($dbh, $table)
64             };
65             }
66              
67             sub index {
68 0     0 1   my($proto, $dbh, $table) = @_;
69 0           my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] }
  0            
70 0           grep { ! $proto->_is_unique($dbh, $_ ) }
71             $proto->_all_indices($dbh, $table)
72             };
73             }
74              
75             sub _all_indices {
76 0     0     my($proto, $dbh, $table) = @_;
77              
78 0 0         my $sth = $dbh->prepare_cached(<errstr;
79             SELECT name
80             FROM sysindexes
81             WHERE id = object_id('$table') and indid between 1 and 254
82             END
83 0 0         $sth->execute or die $sth->errstr;
84 0           my @indices = map { $_->[0] } @{ $sth->fetchall_arrayref() };
  0            
  0            
85 0           $sth->finish;
86 0           $sth = undef;
87 0           @indices;
88             }
89              
90             sub _index_fields {
91 0     0     my($proto, $dbh, $table, $index) = @_;
92              
93 0           my @keys;
94              
95 0           my ($indid) = $dbh->selectrow_array("select indid from sysindexes where id = object_id('$table') and name = '$index'");
96 0           for (1..30) {
97 0   0       push @keys, $dbh->selectrow_array("select index_col('$table', $indid, $_)") || ();
98             }
99              
100 0           return @keys;
101             }
102              
103             sub _is_unique {
104 0     0     my($proto, $dbh, $table, $index) = @_;
105              
106 0           my ($isunique) = $dbh->selectrow_array("select status & 2 from sysindexes where id = object_id('$table') and name = '$index'");
107              
108 0           return $isunique;
109             }
110              
111             =head1 AUTHOR
112              
113             Charles Shapiro
114             (courtesy of Ivan Kohler )
115              
116             Mitchell Friedman
117              
118             Bernd Dulfer
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 method does not yet work.
133              
134             =head1 SEE ALSO
135              
136             L, L, L, L
137              
138             =cut
139              
140             1;
141