view release on metacpan or  search on metacpan

lib/DBIO/MySQL/SQLMaker.pm  view on Meta::CPAN

  my $target = $on_conflict->{target};
  return $target->[0] if ref $target eq 'ARRAY' and @$target;

  return (sort keys %$data)[0] if ref $data eq 'HASH' and keys %$data;

  return undef;
}

# Allow STRAIGHT_JOIN's
sub _generate_join_clause {
    my ($self, $join_type) = @_;

    if( $join_type && $join_type =~ /^STRAIGHT\z/i ) {
        return ' STRAIGHT_JOIN '
    }

    return $self->next::method($join_type);
}

sub _wrap_self_referencing_subquery {
  my ($self, $sql, $target_name) = @_;

  return $sql unless $target_name;

  my $re = qr/ (?<!DELETE) [\s\)] (?: FROM | JOIN ) \s (?: \` \Q$target_name\E \` | \Q$target_name\E ) [\s\(] /xi;

  return $sql unless $sql =~ $re;

  my $new_sql;
  while (1) {

    my ($prefix, $parenthesized);

    ($parenthesized, $sql, $prefix) = do {
      # idiotic design - writes to $@ but *DOES NOT* throw exceptions
      local $@;
      Text::Balanced::extract_bracketed( $sql, '()', qr/[^\(]*/ );
    };

    # this is how an error is indicated, in addition to crapping in $@
    last unless $parenthesized;

    if ($parenthesized =~ $re) {
      # is this a select subquery?
      if ( $parenthesized =~ /^ \( \s* SELECT \s+ /xi ) {
        $parenthesized = "( SELECT * FROM $parenthesized `_forced_double_subquery` )";
      }
      # then drill down until we find it (if at all)
      else {
        $parenthesized =~ s/^ \( (.+) \) $/$1/x;
        $parenthesized = join ' ', '(', $self->_wrap_self_referencing_subquery( $parenthesized, $target_name ), ')';
      }
    }

    $new_sql .= $prefix . $parenthesized;
  }

  return $new_sql . $sql;
}

sub update {
  my $self = shift;
  my ($target, $source, $attributes) = @_;

  my ($sql, @bind) = $self->next::method(@_);

  # Extract target table name for self-referencing detection
  my $target_name = $self->_extract_target_name($target);

  $sql = $self->_wrap_self_referencing_subquery($sql, $target_name) if $target_name;

  return ($sql, @bind);
}

sub delete {
  my $self = shift;
  my ($target, $source, $attributes) = @_;

  my ($sql, @bind) = $self->next::method(@_);

  # Extract target table name for self-referencing detection
  my $target_name = $self->_extract_target_name($target);

  $sql = $self->_wrap_self_referencing_subquery($sql, $target_name) if $target_name;

  return ($sql, @bind);
}

sub _extract_target_name {
  my ($self, $target) = @_;

  return unless defined $target;

  if (ref $target eq 'SCALAR') {
    if ($$target =~ /^ (?:
        \` ( [^`]+ ) \` #`
      | ( [\w\-]+ )
    ) $/x
    ) {
      return (defined $1) ? $1 : $2;
    }
    return; # complex scalar ref, can't deal
  }

  # For HASH refs (simple result source) or plain strings, return as-is
  return ref $target ? undef : $target;
}


#
# Support for MySQL lock clause syntax according to specification
# including updates introduced in MySQL 8.0.1)
# FOR UPDATE | FOR SHARE [OF tbl_name [, tbl_name] ...] [NOWAIT | SKIP LOCKED]
#
# Which of those three parts the server at the other end actually has is a
# SERVER question, not a DBD one, so the storage answers it and stashes the
# answer here (karr #30, same shape as _insert_row_alias above). See
# DBIO::MySQL::Storage/_lock_dialect for the version table.

my $lock_modifiers = {
  nowait => 'NOWAIT',