Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Make SQL::Abstract work.
Browse files Browse the repository at this point in the history
This removes the optional dependence on SQL::Abstract::Classic or a
version of SQL::Abstract prior to 2.000000, and only uses version
2.000000 or newer of SQL::Abstract.

For this to work the capability of a field override needs to be removed.
There doesn't seem to be a reliable way to do that with the newer
versions of SQL::Abstract, although I didn't try very hard.  I also
don't see the need for having a field override.  The only field that has
an override is the `key_not_a_keyfield` or `key` field.  Why was that
ever done?  Did someone think that MySQL would make a field a database
key field if it had the name "key"?  Did someone think it would be
confusing to have a field named "key" that was not a database key field?
It was probably the latter, but in my opinion the field override was
even more confusing.

The `key` field in the `key` table does not contain any permanent data,
so upgrading courses does not require any special handling.  The data
from the old `key_not_a_keyfield` field can be safely dropped, and the
new `key` field used in its place.  You can leave the
`key_not_a_keyfield` field in the database if you want to switch back
and forth between other pull requests that use the `key_not_a_keyfield`
field.
drgrice1 committed Dec 17, 2023
1 parent 2b193de commit b73ea3b
Showing 6 changed files with 236 additions and 358 deletions.
27 changes: 3 additions & 24 deletions bin/check_modules.pl
Original file line number Diff line number Diff line change
@@ -141,6 +141,7 @@ =head1 DESCRIPTION
Scalar::Util
SOAP::Lite
Socket
SQL::Abstract
Statistics::R::IO
String::ShellQuote
SVG
@@ -166,7 +167,8 @@ =head1 DESCRIPTION
'LWP::Protocol::https' => 6.06,
'Mojolicious' => 9.22,
'Net::SSLeay' => 1.46,
'Perl::Tidy' => 20220613
'Perl::Tidy' => 20220613,
'SQL::Abstract' => 2.000000
);

my ($test_programs, $test_modules, $show_help);
@@ -249,29 +251,6 @@ sub check_modules {
print " $module found and loaded\n";
}
}
checkSQLabstract();
}

## this is specialized code to check for either SQL::Abstract or SQL::Abstract::Classic

sub checkSQLabstract {
print "\n checking for SQL::Abstract\n\n";
eval "use SQL::Abstract";
my $sql_abstract = not($@);
my $sql_abstract_version = $SQL::Abstract::VERSION if $sql_abstract;

eval "use SQL::Abstract::Classic";
my $sql_abstract_classic = not($@);

if ($sql_abstract_classic) {
print qq/ You have SQL::Abstract::Classic installed. This package will be used if either
the installed version of SQL::Abstract is version > 1.87 or if that package is not installed.\n/;
} elsif ($sql_abstract && $sql_abstract_version <= 1.87) {
print "You have version $sql_abstract_version of SQL::Abstract installed. This will be used\n";
} else {
print qq/You need either SQL::Abstract version <= 1.87 or need to install SQL::Abstract::Classic.
If you are using cpan or cpanm, it is recommended to install SQL::Abstract::Classic.\n/;
}
}

1;
434 changes: 192 additions & 242 deletions conf/database.conf.dist

Large diffs are not rendered by default.

8 changes: 2 additions & 6 deletions lib/WeBWorK/DB/Schema/NewSQL/Merge.pm
Original file line number Diff line number Diff line change
@@ -122,11 +122,8 @@ sub merge_init {
sub sql_init {
my $self = shift;

# transformation functions for table and field names: these allow us to pass
# the WeBWorK table/field names to SQL::Abstract::Classic, and have it translate them
# to the SQL table/field names from tableOverride and fieldOverride.
# (Without this, it would be hard to translate field names in WHERE
# structures, since they're so convoluted.)
# Transformation function for table names. This allows us to pass the WeBWorK table names to
# SQL::Abstract, and have it translate them to the SQL table names from tableOverride.
my $transform_table = sub {
my $label = shift;
if (exists $self->{sql_table_aliases}{$label}) {
@@ -152,7 +149,6 @@ sub sql_init {
return "`$table`.`$field`";
};

# add SQL statement generation object
$self->{sql} = new WeBWorK::DB::Utils::SQLAbstractIdentTrans(
quote_char => "`",
name_sep => ".",
28 changes: 6 additions & 22 deletions lib/WeBWorK/DB/Schema/NewSQL/Std.pm
Original file line number Diff line number Diff line change
@@ -42,11 +42,6 @@ This schema pays attention to the following items in the C<params> entry.
Alternate name for this table, to satisfy SQL naming requirements.
=item fieldOverride
A reference to a hash mapping field names to alternate names, to satisfy SQL
naming requirements.
=back
=cut
@@ -70,36 +65,24 @@ sub new {
sub sql_init {
my $self = shift;

# transformation functions for table and field names: these allow us to pass
# the WeBWorK table/field names to SQL::Abstract::Classic, and have it translate them
# to the SQL table/field names from tableOverride and fieldOverride.
# (Without this, it would be hard to translate field names in WHERE
# structures, since they're so convoluted.)
my ($transform_table, $transform_field);
# Transformation function for table names. This allows us to pass the WeBWorK table names to
# SQL::Abstract, and have it translate them to the SQL table names from tableOverride.
my $transform_table;
if (defined $self->{params}{tableOverride}) {
$transform_table = sub {
my $label = shift;
if ($label eq $self->{table}) {
return $self->{params}{tableOverride};
} else {
#warn "can't transform unrecognized table name '$label'";
return $label;
}
};
}
if (defined $self->{params}{fieldOverride}) {
$transform_field = sub {
my $label = shift;
return defined $self->{params}{fieldOverride}{$label} ? $self->{params}{fieldOverride}{$label} : $label;
};
}

# add SQL statement generation object
$self->{sql} = new WeBWorK::DB::Utils::SQLAbstractIdentTrans(
quote_char => "`",
name_sep => ".",
transform_table => $transform_table,
transform_field => $transform_field,
transform_table => $transform_table
);
}

@@ -902,10 +885,11 @@ sub character_set {
my $self = shift;
return (defined $self->{character_set} and $self->{character_set}) ? $self->{character_set} : 'latin1';
}

# returns non-quoted SQL name of given field
sub sql_field_name {
my ($self, $field) = @_;
return defined $self->{params}{fieldOverride}{$field} ? $self->{params}{fieldOverride}{$field} : $field;
return $field;
}

# returns fully quoted expression refering to the specified field
87 changes: 28 additions & 59 deletions lib/WeBWorK/DB/Utils/SQLAbstractIdentTrans.pm
Original file line number Diff line number Diff line change
@@ -14,95 +14,64 @@
################################################################################

package WeBWorK::DB::Utils::SQLAbstractIdentTrans;
my $BASE;

BEGIN {
my $sql_abstract = eval {
require SQL::Abstract;
if ($SQL::Abstract::VERSION > 1.87) {
0;
} else {
1;
}
};
$BASE = qw(SQL::Abstract) if $sql_abstract;
$BASE = qw(SQL::Abstract::Classic) unless $sql_abstract;
}
use base $BASE;
use parent qw(SQL::Abstract);

=head1 NAME
WeBWorK::DB::Utils::SQLAbstractIdentTrans - subclass of SQL::Abstract::Classic that
allows custom hooks to transform identifiers.
allows custom hooks to transform table names.
=cut

use strict;
use warnings;

sub _table {
my $self = shift;
my $tab = shift;
if (ref $tab eq 'ARRAY') {
return join ', ', map { $self->_quote_table($_) } @$tab;
} else {
return $self->_quote_table($tab);
my ($self, $from) = @_;
if (ref($from) eq 'ARRAY') {
return $self->SUPER::_table([ map { $self->_transform_table($_) } @$from ]);
} elsif (!ref($from)) {
return $self->SUPER::_table($self->_transform_table($from));
}
return $self->SUPER::_table($from);
}

sub _quote {
my $self = shift;
my $label = shift;
my ($self, $label) = @_;

return $label if $label eq '*';

return $self->_quote_field($label)
if !defined $self->{name_sep};
return join($self->{name_sep} || '', map { $self->_quote($_) } @$label) if ref($label) eq 'ARRAY';

return $self->SUPER::_quote($label) unless defined $self->{name_sep};

if (defined $self->{transform_all}) {
if (ref($self->{transform_all}) eq 'CODE') {
return $self->{transform_all}->($label);
} elsif ($label =~ /(.+)\.(.+)/) {
return $self->_quote_table($1) . $self->{name_sep} . $self->_quote_field($2);
return $self->SUPER::_quote($self->_transform_table($1)) . $self->{name_sep} . $self->SUPER::_quote($2);
} else {
return $self->_quote_field($label);
return $self->SUPER::_quote($label);
}
}

sub _quote_table {
my $self = shift;
my $label = shift;

# if the table name is a scalar reference, leave it alone (but dereference it)
return $$label if ref $label eq "SCALAR";

# call custom transform function
$label = $self->{transform_table}->($label)
if defined $self->{transform_table};

return $self->{quote_char} . $label . $self->{quote_char};
sub _transform_table {
my ($self, $table) = @_;
return ref($self->{transform_table}) eq 'CODE' ? $self->{transform_table}->($table) : $table;
}

sub _quote_field {
my $self = shift;
my $label = shift;

# call custom transform function
$label = $self->{transform_field}->($label)
if defined $self->{transform_field};

return $self->{quote_char} . $label . $self->{quote_char};
sub insert {
my ($self, $table, $data, $options) = @_;
return $self->SUPER::insert($self->_transform_table($table), $data, $options);
}

sub _order_by {
my $self = shift;
my $ref = ref $_[0];

my @vals = $ref eq 'ARRAY' ? @{ $_[0] } : $ref eq 'SCALAR' ? $_[0] : # modification: don't dereference scalar refs
$ref eq '' ? $_[0] : $self->SUPER::puke("Unsupported data struct $ref for ORDER BY");
sub update {
my ($self, $table, $set, $where, $options) = @_;
return $self->SUPER::update($self->_transform_table($table), $set, $where, $options);
}

# modification: if an item is a scalar ref, don't quote it, only dereference it
my $val = join ', ', map { ref $_ eq "SCALAR" ? $$_ : $self->_quote($_) } @vals;
return $val ? $self->_sqlcase(' order by') . " $val" : '';
sub delete {
my ($self, $table, $where, $options) = @_;
return $self->SUPER::delete($self->_transform_table($table), $where, $options);
}

1;
10 changes: 5 additions & 5 deletions lib/WebworkSOAP/Classes/Key.pm
Original file line number Diff line number Diff line change
@@ -4,7 +4,7 @@ package WebworkSOAP::Classes::Key;
=begin WSDL
_ATTR user_id $string user_id
_ATTR key_not_a_keyboard $string key_not_a_keyboard
_ATTR key $string key
_ATTR timestamp $string timestamp
=end WSDL
@@ -13,10 +13,10 @@ package WebworkSOAP::Classes::Key;
sub new {
my $self = shift;
my $data = shift;
$self = {};
$self->{user_id} = SOAP::Data->type('string', $data->user_id);
$self->{key_not_a_keyboard} = SOAP::Data->type('string', $data->key_not_a_keyboard);
$self->{timestamp} = SOAP::Data->type('string', $data->timestamp);
$self = {};
$self->{user_id} = SOAP::Data->type('string', $data->user_id);
$self->{key} = SOAP::Data->type('string', $data->key);
$self->{timestamp} = SOAP::Data->type('string', $data->timestamp);
bless $self;
return $self;
}

0 comments on commit b73ea3b

Please sign in to comment.