lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm

   1 package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/
   7   DBIx::Class::Storage::DBI::ADO
   8   DBIx::Class::Storage::DBI::MSSQL
   9 /;
  10 use mro 'c3';
  11 use DBIx::Class::Carp;
  12 use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/;
  13 use namespace::clean;
  14
  15 __PACKAGE__->cursor_class(
  16   'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor'
  17 );
  18
  19 __PACKAGE__->datetime_parser_type (
  20   'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format'
  21 );
  22
  23 __PACKAGE__->new_guid(sub {
  24     my $self = shift;
  25     my $guid = $self->_get_dbh->selectrow_array('SELECT NEWID()');
  26     $guid =~ s/\A \{ (.+) \} \z/$1/xs;
  27     return $guid;
  28 });
  29
  30 =head1 NAME
  31
  32 DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft
  33 SQL Server via DBD::ADO
  34
  35 =head1 SYNOPSIS
  36
  37 This subclass supports MSSQL server connections via L<DBD::ADO>.
  38
  39 =head1 DESCRIPTION
  40
  41 The MSSQL specific functionality is provided by
  42 L<DBIx::Class::Storage::DBI::MSSQL>.
  43
  44 =head1 EXAMPLE DSN
  45
  46   dbi:ADO:provider=sqlncli10;server=EEEBOX\SQLEXPRESS
  47
  48 =head1 CAVEATS
  49
  50 =head2 identities
  51
  52 C<_identity_method> is set to C<@@identity>, as C<SCOPE_IDENTITY()> doesn't work
  53 with L<DBD::ADO>. See L<DBIx::Class::Storage::DBI::MSSQL/IMPLEMENTATION NOTES>
  54 for caveats regarding this.
  55
  56 =head2 truncation bug
  57
  58 There is a bug with MSSQL ADO providers where data gets truncated based on the
  59 size of the bind sizes in the first prepare call:
  60
  61 L<https://rt.cpan.org/Ticket/Display.html?id=52048>
  62
  63 The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
  64 approximate maximum size of the data_type of the bound column, or 8000 (maximum
  65 VARCHAR size) if the data_type is not available.
  66
  67 Please report problems with this driver and send patches.
  68
  69 =head2 LongReadLen
  70
  71 C<LongReadLen> is set to C<LongReadLen * 2 + 1> on connection as it is necessary
  72 for some LOB types. Be aware of this if you localize this value on the C<$dbh>
  73 directly.
  74
  75 =head2 binary data
  76
  77 Due perhaps to the ado_size workaround we use, and/or other reasons, binary data
  78 such as C<varbinary> column data comes back padded with trailing C<NULL> chars.
  79 The Cursor class for this driver
  80 (L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor>) removes them,
  81 of course if your binary data is actually C<NULL> padded that may be an issue to
  82 keep in mind when using this driver.
  83
  84 =head2 uniqueidentifier columns
  85
  86 uniqueidentifier columns come back from ADO wrapped in braces and must be
  87 submitted to the MSSQL ADO driver wrapped in braces. We take care of this
  88 transparently in this driver and the associated Cursor class
  89 (L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor>) so that you
  90 don't have to use braces in most cases (except in literal SQL, in those cases
  91 you will have to add the braces yourself.)
  92
  93 =head2 fractional seconds
  94
  95 Fractional seconds with L<DBIx::Class::InflateColumn::DateTime> are not
  96 currently supported, datetimes are truncated at the second.
  97
  98 =cut
  99
 100 sub _init {
 101   my $self = shift;
 102
 103 # SCOPE_IDENTITY() doesn't work
 104   $self->_identity_method('@@identity');
 105   $self->_no_scope_identity_query(1);
 106
 107   return $self->next::method(@_);
 108 }
 109
 110 sub _run_connection_actions {
 111   my $self = shift;
 112
 113 # make transactions work
 114   require DBD::ADO::Const;
 115   $self->_dbh->{ado_conn}{CursorLocation} =
 116     DBD::ADO::Const->Enums->{CursorLocationEnum}{adUseClient};
 117
 118 # set LongReadLen = LongReadLen * 2 + 1
 119 # this may need to be in ADO.pm, being conservative for now...
 120   my $long_read_len = $self->_dbh->{LongReadLen};
 121
 122 # This is the DBD::ADO default.
 123   if ($long_read_len != 2147483647) {
 124     $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1;
 125   }
 126
 127   return $self->next::method(@_);
 128 }
 129
 130
 131 # Fix up binary data and GUIDs for ->find, for cursors see the cursor_class
 132 # above.
 133 sub select_single {
 134   my $self = shift;
 135   my ($ident, $select) = @_;
 136
 137   my @row = $self->next::method(@_);
 138
 139   return @row unless $self->cursor_class->isa(
 140     'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor'
 141   );
 142
 143   my $col_infos = $self->_resolve_column_info($ident);
 144
 145   _normalize_guids($select, $col_infos, \@row, $self);
 146
 147   _strip_trailing_binary_nulls($select, $col_infos, \@row, $self);
 148
 149   return @row;
 150 }
 151
 152 # We need to catch VARCHAR(max) before bind_attribute_by_data_type because it
 153 # could be specified by size, also if bind_attribute_by_data_type fails we want
 154 # to specify the default ado_size of 8000.
 155 # Also make sure GUID binds have braces on them or else ADO throws an "Invalid
 156 # character value for cast specification"
 157
 158 sub _dbi_attrs_for_bind {
 159   my $self = shift;
 160   my ($ident, $bind) = @_;
 161
 162   my $lob_max = $self->_get_dbh->{LongReadLen} || 32768;
 163
 164   foreach my $bind (@$bind) {
 165     my $attrs     = $bind->[0];
 166     my $data_type = $attrs->{sqlt_datatype};
 167     my $size      = $attrs->{sqlt_size};
 168
 169     if ($size && lc($size) eq 'max') {
 170       if ($data_type =~ /^(?:varchar|character varying|nvarchar|national char varying|national character varying|varbinary)\z/i) {
 171         $attrs->{dbd_attrs} = { ado_size => $lob_max };
 172       }
 173       else {
 174         carp_unique "bizarre data_type '$data_type' with size => 'max'";
 175       }
 176     }
 177
 178     if ($self->_is_guid_type($data_type) && substr($bind->[1], 0, 1) ne '{') {
 179       $bind->[1] = '{' . $bind->[1] . '}';
 180     }
 181   }
 182
 183   my $attrs = $self->next::method(@_);
 184
 185   foreach my $attr (@$attrs) {
 186     $attr->{ado_size} ||= 8000 if $attr;
 187   }
 188
 189   return $attrs;
 190 }
 191
 192 # Can't edit all the binds in _dbi_attrs_for_bind for insert_bulk, so we take
 193 # care of those GUIDs here.
 194 sub insert_bulk {
 195   my $self = shift;
 196   my ($source, $cols, $data) = @_;
 197
 198   my $columns_info = $source->columns_info($cols);
 199
 200   my $col_idx = 0;
 201   foreach my $col (@$cols) {
 202     if ($self->_is_guid_type($columns_info->{$col}{data_type})) {
 203       foreach my $data_row (@$data) {
 204         if (substr($data_row->[$col_idx], 0, 1) ne '{') {
 205           $data_row->[$col_idx] = '{' . $data_row->[$col_idx] . '}';
 206         }
 207       }
 208     }
 209     $col_idx++;
 210   }
 211
 212   return $self->next::method(@_);
 213 }
 214
 215 sub bind_attribute_by_data_type {
 216   my ($self, $data_type) = @_;
 217
 218   $data_type = lc $data_type;
 219
 220   my $max_size =
 221     $self->_mssql_max_data_type_representation_size_in_bytes->{$data_type};
 222
 223   my $res = {};
 224
 225   if ($max_size) {
 226     $res->{ado_size} = $max_size;
 227   }
 228   else {
 229     carp_unique "could not map data_type '$data_type' to a max size for ado_size: defaulting to 8000";
 230   }
 231
 232   return $res;
 233 }
 234
 235 # FIXME This list is an abomination. We need a way to do this outside
 236 # of the scope of DBIC, as it is right now nobody will ever think to
 237 # even look here to diagnose some sort of misbehavior.
 238 sub _mssql_max_data_type_representation_size_in_bytes {
 239   my $self = shift;
 240
 241   my $lob_max = $self->_get_dbh->{LongReadLen} || 32768;
 242
 243   return +{
 244 # MSSQL types
 245     char => 8000,
 246     character => 8000,
 247     varchar => 8000,
 248     'varchar(max)' => $lob_max,
 249     'character varying' => 8000,
 250     binary => 8000,
 251     varbinary => 8000,
 252     'varbinary(max)' => $lob_max,
 253     nchar => 16000,
 254     'national character' => 16000,
 255     'national char' => 16000,
 256     nvarchar => 16000,
 257     'nvarchar(max)' => ($lob_max*2),
 258     'national character varying' => 16000,
 259     'national char varying' => 16000,
 260     numeric => 100,
 261     smallint => 100,
 262     tinyint => 100,
 263     smallmoney => 100,
 264     bigint => 100,
 265     bit => 100,
 266     decimal => 100,
 267     dec => 100,
 268     integer => 100,
 269     int => 100,
 270     'int identity' => 100,
 271     'integer identity' => 100,
 272     money => 100,
 273     float => 100,
 274     double => 100,
 275     'double precision' => 100,
 276     real => 100,
 277     uniqueidentifier => 100,
 278     ntext => $lob_max,
 279     text => $lob_max,
 280     image => $lob_max,
 281     date => 100,
 282     datetime => 100,
 283     datetime2 => 100,
 284     datetimeoffset => 100,
 285     smalldatetime => 100,
 286     time => 100,
 287     timestamp => 100,
 288     cursor => 100,
 289     hierarchyid => 100,
 290     rowversion => 100,
 291     sql_variant => 100,
 292     table => $lob_max,
 293     xml => $lob_max,
 294
 295 # mysql types
 296     bool => 100,
 297     boolean => 100,
 298     'tinyint unsigned' => 100,
 299     'smallint unsigned' => 100,
 300     'mediumint unsigned' => 100,
 301     'int unsigned' => 100,
 302     'integer unsigned' => 100,
 303     'bigint unsigned' => 100,
 304     'float unsigned' => 100,
 305     'double unsigned' => 100,
 306     'double precision unsigned' => 100,
 307     'decimal unsigned' => 100,
 308     'fixed' => 100,
 309     'year' => 100,
 310     tinyblob => $lob_max,
 311     tinytext => $lob_max,
 312     blob => $lob_max,
 313     text => $lob_max,
 314     mediumblob => $lob_max,
 315     mediumtext => $lob_max,
 316     longblob => $lob_max,
 317     longtext => $lob_max,
 318     enum => 100,
 319     set => 8000,
 320
 321 # Pg types
 322     serial => 100,
 323     bigserial => 100,
 324     int8 => 100,
 325     integer8 => 100,
 326     serial8 => 100,
 327     int4 => 100,
 328     integer4 => 100,
 329     serial4 => 100,
 330     int2 => 100,
 331     integer2 => 100,
 332     float8 => 100,
 333     float4 => 100,
 334     'bit varying' => 8000,
 335     'varbit' => 8000,
 336     inet => 100,
 337     cidr => 100,
 338     macaddr => 100,
 339     'time without time zone' => 100,
 340     'time with time zone' => 100,
 341     'timestamp without time zone' => 100,
 342     'timestamp with time zone' => 100,
 343     bytea => $lob_max,
 344
 345 # DB2 types
 346     graphic => 8000,
 347     vargraphic => 8000,
 348     'long vargraphic' => $lob_max,
 349     dbclob => $lob_max,
 350     clob => $lob_max,
 351     'char for bit data' => 8000,
 352     'varchar for bit data' => 8000,
 353     'long varchar for bit data' => $lob_max,
 354
 355 # oracle types
 356     varchar2 => 8000,
 357     binary_float => 100,
 358     binary_double => 100,
 359     raw => 8000,
 360     nclob => $lob_max,
 361     long => $lob_max,
 362     'long raw' => $lob_max,
 363     'timestamp with local time zone' => 100,
 364
 365 # Sybase ASE types
 366     unitext => $lob_max,
 367     unichar => 16000,
 368     univarchar => 16000,
 369
 370 # SQL Anywhere types
 371     'long varbit' => $lob_max,
 372     'long bit varying' => $lob_max,
 373     uniqueidentifierstr => 100,
 374     'long binary' => $lob_max,
 375     'long varchar' => $lob_max,
 376     'long nvarchar' => $lob_max,
 377
 378 # Firebird types
 379     'char(x) character set unicode_fss' => 16000,
 380     'varchar(x) character set unicode_fss' => 16000,
 381     'blob sub_type text' => $lob_max,
 382     'blob sub_type text character set unicode_fss' => $lob_max,
 383
 384 # Informix types
 385     smallfloat => 100,
 386     byte => $lob_max,
 387     lvarchar => 8000,
 388     'datetime year to fraction(5)' => 100,
 389     # FIXME add other datetime types
 390
 391 # MS Access types
 392     autoincrement => 100,
 393     long => 100,
 394     integer4 => 100,
 395     integer2 => 100,
 396     integer1 => 100,
 397     logical => 100,
 398     logical1 => 100,
 399     yesno => 100,
 400     currency => 100,
 401     single => 100,
 402     ieeesingle => 100,
 403     ieeedouble => 100,
 404     number => 100,
 405     string => 8000,
 406     guid => 100,
 407     longchar => $lob_max,
 408     memo => $lob_max,
 409     longbinary => $lob_max,
 410   }
 411 }
 412
 413 package # hide from PAUSE
 414   DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format;
 415
 416 my $datetime_format = '%m/%d/%Y %I:%M:%S %p';
 417 my $datetime_parser;
 418
 419 sub parse_datetime {
 420   shift;
 421   require DateTime::Format::Strptime;
 422   $datetime_parser ||= DateTime::Format::Strptime->new(
 423     pattern  => $datetime_format,
 424     on_error => 'croak',
 425   );
 426   return $datetime_parser->parse_datetime(shift);
 427 }
 428
 429 sub format_datetime {
 430   shift;
 431   require DateTime::Format::Strptime;
 432   $datetime_parser ||= DateTime::Format::Strptime->new(
 433     pattern  => $datetime_format,
 434     on_error => 'croak',
 435   );
 436   return $datetime_parser->format_datetime(shift);
 437 }
 438
 439 1;
 440
 441 =head1 AUTHOR
 442
 443 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 444
 445 =head1 LICENSE
 446
 447 You may distribute this code under the same terms as Perl itself.
 448
 449 =cut
 450 # vim:sts=2 sw=2: