File Coverage

blib/lib/DBIx/DBSchema/DBD/Sybase.pm
Criterion Covered Total %
statement 9 48 18.7
branch 0 12 0.0
condition 0 3 0.0
subroutine 3 11 27.2
pod 4 5 80.0
total 16 79 20.2


line stmt bran cond sub pod time code
1             package DBIx::DBSchema::DBD::Sybase;
2              
3 1     1   478 use strict;
  1         6  
  1         35  
4 1     1   5 use vars qw($VERSION @ISA %typemap);
  1         2  
  1         64  
5 1     1   360 use DBIx::DBSchema::DBD;
  1         2  
  1         589  
6              
7             $VERSION = '0.04';
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             my @cols = map {
40             [
41             $_->{'column_name'},
42             $_->{'type_name'},
43             ($_->{'nullable'} ? 1 : ''),
44 0 0         $_->{'length'},
45             '', #default
46             '' #local
47             ]
48 0           } @{ $sth->fetchall_arrayref({}) };
  0            
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, $_ ) ] }
62 0           grep { $proto->_is_unique($dbh, $_ ) }
  0            
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, $_ ) ] }
70 0           grep { ! $proto->_is_unique($dbh, $_ ) }
  0            
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             sub tables {
112 0     0 0   my($proto, $dbh) = @_;
113              
114 0           my $sth = $dbh->prepare("sp_tables NULL, NULL, NULL, \"'TABLE'\"");
115 0 0         $sth->execute
116             or die $dbh->errstr;
117              
118 0           $proto->SUPER::tables($dbh, $sth);
119             }
120              
121             =head1 AUTHOR
122              
123             Charles Shapiro
124             (courtesy of Ivan Kohler )
125              
126             Mitchell Friedman
127              
128             Bernd Dulfer
129              
130             Nathan Anderson
131              
132             =head1 COPYRIGHT
133              
134             Copyright (c) 2001 Charles Shapiro, Mitchell J. Friedman
135             Copyright (c) 2001 nuMethods LLC.
136             All rights reserved.
137             This program is free software; you can redistribute it and/or modify it under
138             the same terms as Perl itself.
139              
140             =head1 BUGS
141              
142             Yes.
143              
144             The B method does not yet work.
145              
146             =head1 SEE ALSO
147              
148             L, L, L, L
149              
150             =cut
151              
152             1;
153