X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSQLAHacks%2FOracle.pm;h=a55936d51e0b7e97d555e991184b2eb649ac2ecd;hb=4a233f3019d2baa4bf2abee0c873c74d5cdf3a11;hp=3e556224982c2f494bee5d27218e747749b715c9;hpb=63ca94e17632a42875a93d2c7333f9cdc2a7dfd7;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/SQLAHacks/Oracle.pm b/lib/DBIx/Class/SQLAHacks/Oracle.pm index 3e55622..a55936d 100644 --- a/lib/DBIx/Class/SQLAHacks/Oracle.pm +++ b/lib/DBIx/Class/SQLAHacks/Oracle.pm @@ -4,198 +4,6 @@ package # Hide from PAUSE use warnings; use strict; -use base qw( DBIx::Class::SQLAHacks ); -use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/; - -sub new { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; - push @{$opts{special_ops}}, { - regex => qr/^prior$/i, - handler => '_where_field_PRIOR', - }; - - $self->SUPER::new (\%opts); -} - -sub _assemble_binds { - my $self = shift; - return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/from where oracle_connect_by having order/); -} - - -sub _parse_rs_attrs { - my $self = shift; - my ($rs_attrs) = @_; - - my ($cb_sql, @cb_bind) = $self->_connect_by($rs_attrs); - push @{$self->{oracle_connect_by_bind}}, @cb_bind; - - my $sql = $self->SUPER::_parse_rs_attrs(@_); - - return "$cb_sql $sql"; -} - -sub _connect_by { - my ($self, $attrs) = @_; - - my $sql = ''; - my @bind; - - if ( ref($attrs) eq 'HASH' ) { - if ( $attrs->{'start_with'} ) { - my ($ws, @wb) = $self->_recurse_where( $attrs->{'start_with'} ); - $sql .= $self->_sqlcase(' start with ') . $ws; - push @bind, @wb; - } - if ( my $connect_by = $attrs->{'connect_by'} || $attrs->{'connect_by_nocycle'} ) { - my ($connect_by_sql, @connect_by_sql_bind) = $self->_recurse_where( $connect_by ); - $sql .= sprintf(" %s %s", - ( $attrs->{'connect_by_nocycle'} ) ? $self->_sqlcase('connect by nocycle') - : $self->_sqlcase('connect by'), - $connect_by_sql, - ); - push @bind, @connect_by_sql_bind; - } - if ( $attrs->{'order_siblings_by'} ) { - $sql .= $self->_order_siblings_by( $attrs->{'order_siblings_by'} ); - } - } - - return wantarray ? ($sql, @bind) : $sql; -} - -sub _order_siblings_by { - my ( $self, $arg ) = @_; - - my ( @sql, @bind ); - for my $c ( $self->_order_by_chunks($arg) ) { - $self->_SWITCH_refkind( - $c, - { - SCALAR => sub { push @sql, $c }, - ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c }, - } - ); - } - - my $sql = - @sql - ? sprintf( '%s %s', $self->_sqlcase(' order siblings by'), join( ', ', @sql ) ) - : ''; - - return wantarray ? ( $sql, @bind ) : $sql; -} - -# we need to add a '=' only when PRIOR is used against a column diretly -# i.e. when it is invoked by a special_op callback -sub _where_field_PRIOR { - my ($self, $lhs, $op, $rhs) = @_; - my ($sql, @bind) = $self->_recurse_where ($rhs); - - $sql = sprintf ('%s = %s %s ', - $self->_convert($self->_quote($lhs)), - $self->_sqlcase ($op), - $sql - ); - - return ($sql, @bind); -} - -# this takes an identifier and shortens it if necessary -# optionally keywords can be passed as an arrayref to generate useful -# identifiers -sub _shorten_identifier { - my ($self, $to_shorten, $keywords) = @_; - - # 30 characters is the identifier limit for Oracle - my $max_len = 30; - # we want at least 10 characters of the base36 md5 - my $min_entropy = 10; - - my $max_trunc = $max_len - $min_entropy - 1; - - return $to_shorten - if length($to_shorten) <= $max_len; - - croak 'keywords needs to be an arrayref' - if defined $keywords && ref $keywords ne 'ARRAY'; - - # if no keywords are passed use the identifier as one - my @keywords = @{$keywords || []}; - @keywords = $to_shorten unless @keywords; - - # get a base36 md5 of the identifier - require Digest::MD5; - require Math::BigInt; - require Math::Base36; - my $b36sum = Math::Base36::encode_base36( - Math::BigInt->from_hex ( - '0x' . Digest::MD5::md5_hex ($to_shorten) - ) - ); - - # switch from perl to java - # get run-length - my ($concat_len, @lengths); - for (@keywords) { - $_ = ucfirst (lc ($_)); - $_ =~ s/\_+(\w)/uc ($1)/eg; - - push @lengths, length ($_); - $concat_len += $lengths[-1]; - } - - # if we are still too long - try to disemvowel non-capitals (not keyword starts) - if ($concat_len > $max_trunc) { - $concat_len = 0; - @lengths = (); - - for (@keywords) { - $_ =~ s/[aeiou]//g; - - push @lengths, length ($_); - $concat_len += $lengths[-1]; - } - } - - # still too long - just start cuting proportionally - if ($concat_len > $max_trunc) { - my $trim_ratio = $max_trunc / $concat_len; - - for my $i (0 .. $#keywords) { - $keywords[$i] = substr ($keywords[$i], 0, int ($trim_ratio * $lengths[$i] ) ); - } - } - - my $fin = join ('', @keywords); - my $fin_len = length $fin; - - return sprintf ('%s_%s', - $fin, - substr ($b36sum, 0, $max_len - $fin_len - 1), - ); -} - -sub _unqualify_colname { - my ($self, $fqcn) = @_; - - return $self->_shorten_identifier($self->next::method($fqcn)); -} +use base qw( DBIx::Class::SQLMaker::Oracle ); 1; - -__END__ - -=pod - -=head1 NAME - -DBIx::Class::SQLAHacks::Oracle - adds hierarchical query support for Oracle to SQL::Abstract - -=head1 DESCRIPTION - -See L for more informations about -how to use hierarchical queries with DBIx::Class. - -=cut