[system] / trunk / webwork2 / lib / WeBWorK / DB.pm Repository:
ViewVC logotype

View of /trunk/webwork2/lib/WeBWorK/DB.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4821 - (download) (as text) (annotate)
Fri Mar 2 23:28:52 2007 UTC (12 years, 10 months ago) by sh002i
File size: 56400 byte(s)
explain seemingly nonsensical line of code

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System>
    3 # Copyright  2000-2006 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: webwork2/lib/WeBWorK/DB.pm,v 1.93 2007/03/02 23:25:35 sh002i Exp $
    5 #
    6 # This program is free software; you can redistribute it and/or modify it under
    7 # the terms of either: (a) the GNU General Public License as published by the
    8 # Free Software Foundation; either version 2, or (at your option) any later
    9 # version, or (b) the "Artistic License" which comes with this package.
   10 #
   11 # This program is distributed in the hope that it will be useful, but WITHOUT
   12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
   13 # FOR A PARTICULAR PURPOSE.  See either the GNU General Public License or the
   14 # Artistic License for more details.
   15 ################################################################################
   16 
   17 package WeBWorK::DB;
   18 
   19 =head1 NAME
   20 
   21 WeBWorK::DB - interface with the WeBWorK databases.
   22 
   23 =head1 SYNOPSIS
   24 
   25  my $db = WeBWorK::DB->new($dbLayout);
   26 
   27  my @userIDs = $db->listUsers();
   28  my $Sam = $db->{user}->{record}->new();
   29 
   30  $Sam->user_id("sammy");
   31  $Sam->first_name("Sam");
   32  $Sam->last_name("Hathaway");
   33  # etc.
   34 
   35  $db->addUser($User);
   36  my $Dennis = $db->getUser("dennis");
   37  $Dennis->status("C");
   38  $db->putUser->($Dennis);
   39 
   40  $db->deleteUser("sammy");
   41 
   42 =head1 DESCRIPTION
   43 
   44 WeBWorK::DB provides a consistent interface to a number of database backends.
   45 Access and modification functions are provided for each logical table used by
   46 the webwork system. The particular backend ("schema" and "driver"), record
   47 class, data source, and additional parameters are specified by the hash
   48 referenced by C<$dbLayout>, usually taken from the course environment.
   49 
   50 =head1 ARCHITECTURE
   51 
   52 The new database system uses a three-tier architecture to insulate each layer
   53 from the adjacent layers.
   54 
   55 =head2 Top Layer: DB
   56 
   57 The top layer of the architecture is the DB module. It provides the methods
   58 listed below, and uses schema modules (via tables) to implement those methods.
   59 
   60          / new* list* exists* add* get* get*s put* delete* \          <- api
   61  +------------------------------------------------------------------+
   62  |                                DB                                |
   63  +------------------------------------------------------------------+
   64   \ password permission key user set set_user problem problem_user /  <- tables
   65 
   66 =head2 Middle Layer: Schemas
   67 
   68 The middle layer of the architecture is provided by one or more schema modules.
   69 They are called "schema" modules because they control the structure of the data
   70 for a table.
   71 
   72 The schema modules provide an API that matches the requirements of the DB
   73 layer, on a per-table basis. Each schema module has a style that determines
   74 which drivers it can interface with. For example, SQL is an "dbi" style
   75 schema.
   76 
   77 =head2 Bottom Layer: Drivers
   78 
   79 Driver modules implement a style for a schema. They provide physical access to
   80 a data source containing the data for a table. The style of a driver determines
   81 what methods it provides. All drivers provide C<connect(MODE)> and
   82 C<disconnect()> methods. A dbi style driver provides a C<handle()> method which
   83 returns the DBI handle.
   84 
   85 =head2 Record Types
   86 
   87 In C<%dblayout>, each table is assigned a record class, used for passing
   88 complete records to and from the database. The default record classes are
   89 subclasses of the WeBWorK::DB::Record class, and are named as follows: User,
   90 Password, PermissionLevel, Key, Set, UserSet, Problem, UserProblem. In the
   91 following documentation, a reference the the record class for a table means the
   92 record class currently defined for that table in C<%dbLayout>.
   93 
   94 =cut
   95 
   96 use strict;
   97 use warnings;
   98 use Carp;
   99 use Data::Dumper;
  100 use WeBWorK::DB::Schema;
  101 use WeBWorK::DB::Utils qw/make_vsetID grok_vsetID grok_setID_from_vsetID_sql
  102   grok_versionID_from_vsetID_sql/;
  103 use WeBWorK::Debug;
  104 use WeBWorK::Utils qw(runtime_use);
  105 
  106 ################################################################################
  107 # constructor
  108 ################################################################################
  109 
  110 =head1 CONSTRUCTOR
  111 
  112 =over
  113 
  114 =item new($dbLayout)
  115 
  116 The C<new> method creates a DB object and brings up the underlying schema/driver
  117 structure according to the hash referenced by C<$dbLayout>.
  118 
  119 =back
  120 
  121 =head2 C<$dbLayout> Format
  122 
  123 C<$dbLayout> is a hash reference consisting of items keyed by table names. The
  124 value of each item is a reference to a hash containing the following items:
  125 
  126 =over
  127 
  128 =item record
  129 
  130 The name of a perl module to use for representing the data in a record.
  131 
  132 =item schema
  133 
  134 The name of a perl module to use for access to the table.
  135 
  136 =item driver
  137 
  138 The name of a perl module to use for access to the data source.
  139 
  140 =item source
  141 
  142 The location of the data source that should be used by the driver module.
  143 Depending on the driver, this may be a path, a url, or a DBI spec.
  144 
  145 =item params
  146 
  147 A reference to a hash containing extra information needed by the schema. Some
  148 schemas require parameters, some do not. Consult the documentation for the
  149 schema in question.
  150 
  151 =back
  152 
  153 For each table defined in C<$dbLayout>, C<new> loads the record, schema, and
  154 driver modules. It the schema module's C<tables> method lists the current table
  155 (or contains the string "*") and the output of the schema and driver modules'
  156 C<style> methods match, the table is installed. Otherwise, an exception is
  157 thrown.
  158 
  159 =cut
  160 
  161 sub new {
  162   my ($invocant, $dbLayout) = @_;
  163   my $class = ref($invocant) || $invocant;
  164   my $self = {};
  165   bless $self, $class; # bless this here so we can pass it to the schema
  166 
  167   # load the modules required to handle each table, and create driver
  168   foreach my $table (keys %$dbLayout) {
  169     $self->init_table($dbLayout, $table);
  170   }
  171 
  172   return $self;
  173 }
  174 
  175 sub init_table {
  176   my ($self, $dbLayout, $table) = @_;
  177 
  178   if (exists $self->{$table}) {
  179     if (defined $self->{$table}) {
  180       return;
  181     } else {
  182       die "loop in dbLayout table dependencies involving table '$table'\n";
  183     }
  184   }
  185 
  186   my $layout = $dbLayout->{$table};
  187   my $record = $layout->{record};
  188   my $schema = $layout->{schema};
  189   my $driver = $layout->{driver};
  190   my $source = $layout->{source};
  191   my $depend = $layout->{depend};
  192   my $params = $layout->{params};
  193 
  194   # add a key for this table to the self hash, but don't define it yet
  195   # this for loop detection
  196   $self->{$table} = undef;
  197 
  198   if ($depend) {
  199     foreach my $dep (@$depend) {
  200       $self->init_table($dbLayout, $dep);
  201     }
  202   }
  203 
  204   runtime_use($record);
  205 
  206   runtime_use($driver);
  207   my $driverObject = eval { $driver->new($source, $params) };
  208   croak "error instantiating DB driver $driver for table $table: $@"
  209     if $@;
  210 
  211   runtime_use($schema);
  212   my $schemaObject = eval { $schema->new(
  213     $self, $driverObject, $table, $record, $params) };
  214   croak "error instantiating DB schema $schema for table $table: $@"
  215     if $@;
  216 
  217   $self->{$table} = $schemaObject;
  218 }
  219 
  220 ################################################################################
  221 # methods that can be autogenerated
  222 ################################################################################
  223 
  224 sub gen_schema_accessor {
  225   my $schema = shift;
  226   return sub { shift->{$schema} };
  227 }
  228 
  229 sub gen_new {
  230   my $table = shift;
  231   return sub { shift->{$table}{record}->new(@_) };
  232 }
  233 
  234 sub gen_count_where {
  235   my $table = shift;
  236   return sub {
  237     my ($self, $where) = @_;
  238     return $self->{$table}->count_where($where);
  239   };
  240 }
  241 
  242 sub gen_exists_where {
  243   my $table = shift;
  244   return sub {
  245     my ($self, $where) = @_;
  246     return $self->{$table}->exists_where($where);
  247   };
  248 }
  249 
  250 sub gen_list_where {
  251   my $table = shift;
  252   return sub {
  253     my ($self, $where, $order) = @_;
  254     if (wantarray) {
  255       return $self->{$table}->list_where($where, $order);
  256     } else {
  257       return $self->{$table}->list_where_i($where, $order);
  258     }
  259   };
  260 }
  261 
  262 sub gen_get_records_where {
  263   my $table = shift;
  264   return sub {
  265     my ($self, $where, $order) = @_;
  266     if (wantarray) {
  267       return $self->{$table}->get_records_where($where, $order);
  268     } else {
  269       return $self->{$table}->get_records_where_i($where, $order);
  270     }
  271   };
  272 }
  273 
  274 ################################################################################
  275 # create/rename/delete tables
  276 ################################################################################
  277 
  278 sub create_tables {
  279   my ($self) = @_;
  280 
  281   foreach my $table (keys %$self) {
  282     next if $table =~ /^_/; # skip non-table self fields (none yet)
  283     next if $self->{$table}{params}{non_native}; # skip non-native tables
  284     my $schema_obj = $self->{$table};
  285     if ($schema_obj->can("create_table")) {
  286       $schema_obj->create_table;
  287     } else {
  288       warn "skipping creation of '$table' table: no create_table method\n";
  289     }
  290   }
  291 
  292   return 1;
  293 }
  294 
  295 sub rename_tables {
  296   my ($self, $new_dblayout) = @_;
  297 
  298   foreach my $table (keys %$self) {
  299     next if $table =~ /^_/; # skip non-table self fields (none yet)
  300     next if $self->{$table}{params}{non_native}; # skip non-native tables
  301     my $schema_obj = $self->{$table};
  302     if (exists $new_dblayout->{$table}) {
  303       if ($schema_obj->can("rename_table")) {
  304         # we look into the new dblayout to determine the new table names
  305         my $new_sql_table_name = defined $new_dblayout->{$table}{params}{tableOverride}
  306           ? $new_dblayout->{$table}{params}{tableOverride}
  307           : $table;
  308         $schema_obj->rename_table($new_sql_table_name);
  309       } else {
  310         warn "skipping renaming of '$table' table: no rename_table method\n";
  311       }
  312     } else {
  313       warn "skipping renaming of '$table' table: table doesn't exist in new dbLayout\n";
  314     }
  315   }
  316 
  317   return 1;
  318 }
  319 
  320 sub delete_tables {
  321   my ($self) = @_;
  322 
  323   foreach my $table (keys %$self) {
  324     next if $table =~ /^_/; # skip non-table self fields (none yet)
  325     next if $self->{$table}{params}{non_native}; # skip non-native tables
  326     my $schema_obj = $self->{$table};
  327     if ($schema_obj->can("delete_table")) {
  328       $schema_obj->delete_table;
  329     } else {
  330       warn "skipping deletion of '$table' table: no delete_table method\n";
  331     }
  332   }
  333 
  334   return 1;
  335 }
  336 
  337 ################################################################################
  338 # user functions
  339 ################################################################################
  340 
  341 BEGIN {
  342   *User = gen_schema_accessor("user");
  343   *newUser = gen_new("user");
  344   *countUsersWhere = gen_count_where("user");
  345   *existsUserWhere = gen_exists_where("user");
  346   *listUsersWhere = gen_list_where("user");
  347   *getUsersWhere = gen_get_records_where("user");
  348 }
  349 
  350 sub countUsers { return scalar shift->listUsers(@_) }
  351 
  352 sub listUsers {
  353   my ($self) = shift->checkArgs(\@_);
  354   if (wantarray) {
  355     return map { @$_ } $self->{user}->get_fields_where(["user_id"]);
  356   } else {
  357     return $self->{user}->count_where;
  358   }
  359 }
  360 
  361 sub existsUser {
  362   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  363   return $self->{user}->exists($userID);
  364 }
  365 
  366 sub getUser {
  367   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  368   return ( $self->getUsers($userID) )[0];
  369 }
  370 
  371 sub getUsers {
  372   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  373   return $self->{user}->gets(map { [$_] } @userIDs);
  374 }
  375 
  376 sub addUser {
  377   my ($self, $User) = shift->checkArgs(\@_, qw/REC:user/);
  378   eval {
  379     return $self->{user}->add($User);
  380   };
  381   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  382     croak "addUser: user exists (perhaps you meant to use putUser?)";
  383   }
  384   # FIXME about these exceptions: eventually the exceptions should be part of
  385   # WeBWorK::DB rather than WeBWorK::DB::Schema, and we should just let them
  386   # through to the calling code. however, right now we have code that checks
  387   # for the string "... exists" in the error message, so we need to convert
  388   # here.
  389   #
  390   # WeBWorK::DB::Ex::RecordExists
  391   # WeBWorK::DB::Ex::DependencyNotFound - i.e. inserting a password for a nonexistent user
  392   # ?
  393 }
  394 
  395 sub putUser {
  396   my ($self, $User) = shift->checkArgs(\@_, qw/REC:user/);
  397   my $rows = $self->{user}->put($User); # DBI returns 0E0 for 0.
  398   if ($rows == 0) {
  399     croak "putUser: user not found (perhaps you meant to use addUser?)";
  400   } else {
  401     return $rows;
  402   }
  403 }
  404 
  405 sub deleteUser {
  406   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  407   $self->deleteUserSet($userID, undef);
  408   $self->deletePassword($userID);
  409   $self->deletePermissionLevel($userID);
  410   $self->deleteKey($userID);
  411   return $self->{user}->delete($userID);
  412 }
  413 
  414 ################################################################################
  415 # password functions
  416 ################################################################################
  417 
  418 BEGIN {
  419   *Password = gen_schema_accessor("password");
  420   *newPassword = gen_new("password");
  421   *countPasswordsWhere = gen_count_where("password");
  422   *existsPasswordWhere = gen_exists_where("password");
  423   *listPasswordsWhere = gen_list_where("password");
  424   *getPasswordsWhere = gen_get_records_where("password");
  425 }
  426 
  427 sub countPasswords { return scalar shift->countPasswords(@_) }
  428 
  429 sub listPasswords {
  430   my ($self) = shift->checkArgs(\@_);
  431   if (wantarray) {
  432     return map { @$_ } $self->{password}->get_fields_where(["user_id"]);
  433   } else {
  434     return $self->{password}->count_where;
  435   }
  436 }
  437 
  438 sub existsPassword {
  439   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  440   # FIXME should we claim that a password exists if the user exists, since
  441   # password records are auto-created?
  442   return $self->{password}->exists($userID);
  443 }
  444 
  445 sub getPassword {
  446   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  447   return ( $self->getPasswords($userID) )[0];
  448 }
  449 
  450 sub getPasswords {
  451   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  452 
  453   my @Passwords = $self->{password}->gets(map { [$_] } @userIDs);
  454 
  455   # AUTO-CREATE missing password records
  456   # (this code is duplicated in getPermissionLevels, below)
  457   for (my $i = 0; $i < @Passwords; $i++) {
  458     my $Password = $Passwords[$i];
  459     my $userID = $userIDs[$i];
  460     if (not defined $Password) {
  461       if ($self->{user}->exists($userID)) {
  462         $Password = $self->newPassword(user_id => $userID);
  463         eval { $self->addPassword($Password) };
  464         if ($@ and $@ !~ m/password exists/) {
  465           die "error while auto-creating password record for user $userID: $@";
  466         }
  467         $Passwords[$i] = $Password;
  468       }
  469     }
  470   }
  471 
  472   return @Passwords;
  473 }
  474 
  475 sub addPassword {
  476   my ($self, $Password) = shift->checkArgs(\@_, qw/REC:password/);
  477 
  478   croak "addPassword: user ", $Password->user_id, " not found"
  479     unless $self->{user}->exists($Password->user_id);
  480 
  481   eval {
  482     return $self->{password}->add($Password);
  483   };
  484   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  485     croak "addPassword: password exists (perhaps you meant to use putPassword?)";
  486   }
  487 }
  488 
  489 sub putPassword {
  490   my ($self, $Password) = shift->checkArgs(\@_, qw/REC:password/);
  491   my $rows = $self->{password}->put($Password); # DBI returns 0E0 for 0.
  492   if ($rows == 0) {
  493     # AUTO-CREATE permission level records
  494     return $self->addPassword($Password);
  495   } else {
  496     return $rows;
  497   }
  498 }
  499 
  500 sub deletePassword {
  501   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  502   return $self->{password}->delete($userID);
  503 }
  504 
  505 ################################################################################
  506 # permission functions
  507 ################################################################################
  508 
  509 BEGIN {
  510   *PermissionLevel = gen_schema_accessor("permission");
  511   *newPermissionLevel = gen_new("permission");
  512   *countPermissionLevelsWhere = gen_count_where("permission");
  513   *existsPermissionLevelWhere = gen_exists_where("permission");
  514   *listPermissionLevelsWhere = gen_list_where("permission");
  515   *getPermissionLevelsWhere = gen_get_records_where("permission");
  516 }
  517 
  518 sub countPermissionLevels { return scalar shift->listPermissionLevels(@_) }
  519 
  520 sub listPermissionLevels {
  521   my ($self) = shift->checkArgs(\@_);
  522   if (wantarray) {
  523     return map { @$_ } $self->{permission}->get_fields_where(["user_id"]);
  524   } else {
  525     return $self->{permission}->count_where;
  526   }
  527 }
  528 
  529 sub existsPermissionLevel {
  530   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  531   # FIXME should we claim that a permission level exists if the user exists,
  532   # since password records are auto-created?
  533   return $self->{permission}->exists($userID);
  534 }
  535 
  536 sub getPermissionLevel {
  537   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  538   return ( $self->getPermissionLevels($userID) )[0];
  539 }
  540 
  541 sub getPermissionLevels {
  542   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  543 
  544   my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs);
  545 
  546   # AUTO-CREATE missing permission level records
  547   # (this code is duplicated in getPasswords, above)
  548   for (my $i = 0; $i < @PermissionLevels; $i++) {
  549     my $PermissionLevel = $PermissionLevels[$i];
  550     my $userID = $userIDs[$i];
  551     if (not defined $PermissionLevel) {
  552       if ($self->{user}->exists($userID)) {
  553         $PermissionLevel = $self->newPermissionLevel(user_id => $userID);
  554         eval { $self->addPermissionLevel($PermissionLevel) };
  555         if ($@ and $@ !~ m/permission level exists/) {
  556           die "error while auto-creating permission level record for user $userID: $@";
  557         }
  558         $PermissionLevels[$i] = $PermissionLevel;
  559       }
  560     }
  561   }
  562 
  563   return @PermissionLevels;
  564 }
  565 
  566 sub addPermissionLevel {
  567   my ($self, $PermissionLevel) = shift->checkArgs(\@_, qw/REC:permission/);
  568 
  569   croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found"
  570     unless $self->{user}->exists($PermissionLevel->user_id);
  571 
  572   eval {
  573     return $self->{permission}->add($PermissionLevel);
  574   };
  575   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  576     croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)";
  577   }
  578 }
  579 
  580 sub putPermissionLevel {
  581   my ($self, $PermissionLevel) = shift->checkArgs(\@_, qw/REC:permission/);
  582   my $rows = $self->{permission}->put($PermissionLevel); # DBI returns 0E0 for 0.
  583   if ($rows == 0) {
  584     # AUTO-CREATE permission level records
  585     return $self->addPermissionLevel($PermissionLevel);
  586   } else {
  587     return $rows;
  588   }
  589 }
  590 
  591 sub deletePermissionLevel {
  592   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  593   return $self->{permission}->delete($userID);
  594 }
  595 
  596 ################################################################################
  597 # key functions
  598 ################################################################################
  599 
  600 BEGIN {
  601   *Key = gen_schema_accessor("key");
  602   *newKey = gen_new("key");
  603   *countKeysWhere = gen_count_where("key");
  604   *existsKeyWhere = gen_exists_where("key");
  605   *listKeysWhere = gen_list_where("key");
  606   *getKeysWhere = gen_get_records_where("key");
  607 }
  608 
  609 sub countKeys { return scalar shift->listKeys(@_) }
  610 
  611 sub listKeys {
  612   my ($self) = shift->checkArgs(\@_);
  613   if (wantarray) {
  614     return map { @$_ } $self->{key}->get_fields_where(["user_id"]);
  615   } else {
  616     return $self->{key}->count_where;
  617   }
  618 }
  619 
  620 sub existsKey {
  621   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  622   return $self->{key}->exists($userID);
  623 }
  624 
  625 sub getKey {
  626   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  627   return ( $self->getKeys($userID) )[0];
  628 }
  629 
  630 sub getKeys {
  631   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  632   return $self->{key}->gets(map { [$_] } @userIDs);
  633 }
  634 
  635 sub addKey {
  636   # PROCTORING - allow comma in keyfields
  637   my ($self, $Key) = shift->checkArgs(\@_, qw/VREC:key/);
  638 
  639   # PROCTORING -  check for both user and proctor
  640   if ($Key->user_id =~ /([^,]+)(?:,(.*))?/) {
  641     my ($userID, $proctorID) = ($1, $2);
  642     croak "addKey: user $userID not found"
  643       unless $self->{user}->exists($userID);
  644     croak "addKey: proctor $proctorID not found"
  645       unless $self->{user}->exists($proctorID);
  646   } else {
  647     croak "addKey: user ", $Key->user_id, " not found"
  648       unless $self->{user}->exists($Key->user_id);
  649   }
  650 
  651   eval {
  652     return $self->{key}->add($Key);
  653   };
  654   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  655     croak "addKey: key exists (perhaps you meant to use putKey?)";
  656   }
  657 }
  658 
  659 sub putKey {
  660   # PROCTORING - allow comma in keyfields
  661   my ($self, $Key) = shift->checkArgs(\@_, qw/VREC:key/);
  662   my $rows = $self->{key}->put($Key); # DBI returns 0E0 for 0.
  663   if ($rows == 0) {
  664     croak "putKey: key not found (perhaps you meant to use addKey?)";
  665   } else {
  666     return $rows;
  667   }
  668 }
  669 
  670 sub deleteKey {
  671   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  672   return $self->{key}->delete($userID);
  673 }
  674 
  675 ################################################################################
  676 # set functions
  677 ################################################################################
  678 
  679 BEGIN {
  680   *GlobalSet = gen_schema_accessor("set");
  681   *newGlobalSet = gen_new("set");
  682   *countGlobalSetsWhere = gen_count_where("set");
  683   *existsGlobalSetWhere = gen_exists_where("set");
  684   *listGlobalSetsWhere = gen_list_where("set");
  685   *getGlobalSetsWhere = gen_get_records_where("set");
  686 }
  687 
  688 sub countGlobalSets { return scalar shift->listGlobalSets(@_) }
  689 
  690 sub listGlobalSets {
  691   my ($self) = shift->checkArgs(\@_);
  692   if (wantarray) {
  693     return map { @$_ } $self->{set}->get_fields_where(["set_id"]);
  694   } else {
  695     return $self->{set}->count_where;
  696   }
  697 }
  698 
  699 sub existsGlobalSet {
  700   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
  701   return $self->{set}->exists($setID);
  702 }
  703 
  704 sub getGlobalSet {
  705   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
  706   return ( $self->getGlobalSets($setID) )[0];
  707 }
  708 
  709 sub getGlobalSets {
  710   my ($self, @setIDs) = shift->checkArgs(\@_, qw/set_id*/);
  711   return $self->{set}->gets(map { [$_] } @setIDs);
  712 }
  713 
  714 sub addGlobalSet {
  715   my ($self, $GlobalSet) = shift->checkArgs(\@_, qw/REC:set/);
  716 
  717   eval {
  718     return $self->{set}->add($GlobalSet);
  719   };
  720   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  721     croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)";
  722   }
  723 }
  724 
  725 sub putGlobalSet {
  726   my ($self, $GlobalSet) = shift->checkArgs(\@_, qw/REC:set/);
  727   my $rows = $self->{set}->put($GlobalSet); # DBI returns 0E0 for 0.
  728   if ($rows == 0) {
  729     croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)";
  730   } else {
  731     return $rows;
  732   }
  733 }
  734 
  735 sub deleteGlobalSet {
  736   # setID can be undefined if being called from this package
  737   my $U = caller eq __PACKAGE__ ? "!" : "";
  738   my ($self, $setID) = shift->checkArgs(\@_, "set_id$U");
  739   $self->deleteUserSet(undef, $setID);
  740   $self->deleteGlobalProblem($setID, undef);
  741   return $self->{set}->delete($setID);
  742 }
  743 
  744 ################################################################################
  745 # set_user functions
  746 ################################################################################
  747 
  748 BEGIN {
  749   *UserSet = gen_schema_accessor("set_user");
  750   *newUserSet = gen_new("set_user");
  751   *countUserSetsWhere = gen_count_where("set_user");
  752   *existsUserSetWhere = gen_exists_where("set_user");
  753   *listUserSetsWhere = gen_list_where("set_user");
  754   *getUserSetsWhere = gen_get_records_where("set_user");
  755 }
  756 
  757 sub countSetUsers { return scalar shift->listSetUsers(@_) }
  758 
  759 sub listSetUsers {
  760   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
  761   my $where = [set_id_eq => $setID];
  762   if (wantarray) {
  763     return map { @$_ } $self->{set_user}->get_fields_where(["user_id"], $where);
  764   } else {
  765     return $self->{set_user}->count_where($where);
  766   }
  767 }
  768 
  769 sub countUserSets { return scalar shift->listUserSets(@_) }
  770 
  771 sub listUserSets {
  772   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  773   my $where = [user_id_eq => $userID];
  774   if (wantarray) {
  775     return map { @$_ } $self->{set_user}->get_fields_where(["set_id"], $where);
  776   } else {
  777     return $self->{set_user}->count_where($where);
  778   }
  779 }
  780 
  781 sub existsUserSet {
  782   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
  783   return $self->{set_user}->exists($userID, $setID);
  784 }
  785 
  786 sub getUserSet {
  787   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
  788   return ( $self->getUserSets([$userID, $setID]) )[0];
  789 }
  790 
  791 sub getUserSets {
  792   my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id/);
  793   return $self->{set_user}->gets(@userSetIDs);
  794 }
  795 
  796 # the code from addUserSet() is duplicated in large part following in
  797 # addVersionedUserSet; changes here should accordingly be propagated down there
  798 sub addUserSet {
  799   my ($self, $UserSet) = shift->checkArgs(\@_, qw/REC:set_user/);
  800 
  801   croak "addUserSet: user ", $UserSet->user_id, " not found"
  802     unless $self->{user}->exists($UserSet->user_id);
  803   croak "addUserSet: set ", $UserSet->set_id, " not found"
  804     unless $self->{set}->exists($UserSet->set_id);
  805 
  806   eval {
  807     return $self->{set_user}->add($UserSet);
  808   };
  809   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  810     croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)";
  811   }
  812 }
  813 
  814 # the code from putUserSet() is duplicated in large part in the following
  815 # putVersionedUserSet; c.f. that routine
  816 sub putUserSet {
  817   my ($self, $UserSet) = shift->checkArgs(\@_, qw/REC:set_user/);
  818   my $rows = $self->{set_user}->put($UserSet); # DBI returns 0E0 for 0.
  819   if ($rows == 0) {
  820     croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)";
  821   } else {
  822     return $rows;
  823   }
  824 }
  825 
  826 sub deleteUserSet {
  827   # userID and setID can be undefined if being called from this package
  828   my $U = caller eq __PACKAGE__ ? "!" : "";
  829   my ($self, $userID, $setID) = shift->checkArgs(\@_, "user_id$U", "set_id$U");
  830   $self->deleteSetVersion($userID, $setID, undef);
  831   $self->deleteUserProblem($userID, $setID, undef);
  832   return $self->{set_user}->delete($userID, $setID);
  833 }
  834 
  835 ################################################################################
  836 # set_merged functions
  837 ################################################################################
  838 
  839 BEGIN {
  840   *MergedSet = gen_schema_accessor("set_merged");
  841   #*newMergedSet = gen_new("set_merged");
  842   #*countMergedSetsWhere = gen_count_where("set_merged");
  843   *existsMergedSetWhere = gen_exists_where("set_merged");
  844   #*listMergedSetsWhere = gen_list_where("set_merged");
  845   *getMergedSetsWhere = gen_get_records_where("set_merged");
  846 }
  847 
  848 sub existsMergedSet {
  849   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
  850   return $self->{set_merged}->exists($userID, $setID);
  851 }
  852 
  853 sub getMergedSet {
  854   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
  855   return ( $self->getMergedSets([$userID, $setID]) )[0];
  856 }
  857 
  858 sub getMergedSets {
  859   my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id/);
  860   return $self->{set_merged}->gets(@userSetIDs);
  861 }
  862 
  863 ################################################################################
  864 # versioned set_user functions (OLD)
  865 ################################################################################
  866 
  867 # USED NOWHERE
  868 sub countUserSetVersions {
  869   croak "listUserSetVersions deprecated in favor of countSetVersionsWhere([user_id_eq=>\$userID])";
  870 }
  871 
  872 # USED IN Grades.pm, ProblemSets.pm
  873 sub listUserSetVersions {
  874   croak "listUserSetVersions deprecated in favor of listSetVersionsWhere([user_id_eq=>\$userID])";
  875 }
  876 
  877 # USED IN GatewayQuiz.pm
  878 sub getUserSetVersions {
  879   croak "getUserSetVersions deprecated in favor of getSetVersionsWhere([user_id_eq_set_id_eq_version_id_le => \$userID,\$setID,\$versionID])";
  880 }
  881 
  882 # USED IN Instructor.pm
  883 sub addVersionedUserSet {
  884   croak "addVersionedUserSet deprecated in favor of addSetVersion";
  885 }
  886 
  887 # USED IN GatewayQuiz.pm, LoginProctor.pm
  888 sub putVersionedUserSet {
  889   croak "putVersionedUserSet deprecated in favor of putSetVersion";
  890 }
  891 
  892 # USED IN GatewayQuiz.pm, Scoring.pm, StudentProgress.pm, Instructor.pm
  893 # in:  uid and sid are user and set ids.  the setID is the 'global' setID
  894 #    for the user, not a versioned value
  895 # out: the latest version number of the set that has been assigned to the
  896 #    user is returned.
  897 sub getUserSetVersionNumber {
  898   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
  899   # FIXME passing a literal SQL expression into SQL::Abstract prevents fieldoverride translation
  900   # from occuring!
  901   # FIXME the whole idea of constructing SQL here is evil and corrupt! fortunately, this will
  902   # go away once we move versioned sets into their own table, which is hopefully going to happen
  903   # before we want to support other RDBMSs.
  904   my $field = "IFNULL(MAX(" . grok_versionID_from_vsetID_sql("set_id") . "),0)";
  905   my $where = [user_id_eq_set_id_eq => $userID,$setID];
  906   return ( $self->{set_version}->get_fields_where($field, $where) )[0]->[0];
  907 }
  908 
  909 ################################################################################
  910 # set_version functions (NEW)
  911 ################################################################################
  912 
  913 BEGIN {
  914   *SetVersion = gen_schema_accessor("set_version");
  915   *newSetVersion = gen_new("set_version");
  916   *countSetVersionsWhere = gen_count_where("set_version");
  917   *existsSetVersionWhere = gen_exists_where("set_version");
  918   *listSetVersionsWhere = gen_list_where("set_version");
  919   *getSetVersionsWhere = gen_get_records_where("set_version");
  920 }
  921 
  922 # versioned analog of countUserSets
  923 sub countSetVersions { return scalar shift->listSetVersions(@_) }
  924 
  925 # versioned analog of listUserSets
  926 sub listSetVersions {
  927   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
  928   my $where = [user_id_eq_set_id_eq => $userID,$setID];
  929   my $order = [ 'version_id' ];
  930   if (wantarray) {
  931     return map { @$_ } $self->{set_version}->get_fields_where(["version_id"], $where);
  932   } else {
  933     return $self->{set_version}->count_where($where);
  934   }
  935 }
  936 
  937 # versioned analog of existsUserSet
  938 sub existsSetVersion {
  939   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
  940   return $self->{set_version}->exists($userID, $setID, $versionID);
  941 }
  942 
  943 # versioned analog of getUserSet
  944 sub getSetVersion {
  945   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
  946   return ( $self->getSetVersions([$userID, $setID, $versionID]) )[0];
  947 }
  948 
  949 # versioned analog of getUserSets
  950 sub getSetVersions {
  951   my ($self, @setVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id/);
  952   return $self->{set_version}->gets(@setVersionIDs);
  953 }
  954 
  955 # versioned analog of addUserSet
  956 sub addSetVersion {
  957   my ($self, $SetVersion) = shift->checkArgs(\@_, qw/REC:set_version/);
  958 
  959   croak "addSetVersion: set ", $SetVersion->set_id, " not found for user ", $SetVersion->user_id
  960     unless $self->{set_user}->exists($SetVersion->user_id, $SetVersion->set_id);
  961 
  962   eval {
  963     return $self->{set_version}->add($SetVersion);
  964   };
  965   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
  966     croak "addSetVersion: set version exists (perhaps you meant to use putSetVersion?)";
  967   }
  968 }
  969 
  970 # versioned analog of putUserSet
  971 sub putSetVersion {
  972   my ($self, $SetVersion) = shift->checkArgs(\@_, qw/REC:set_version/);
  973   my $rows = $self->{set_version}->put($SetVersion); # DBI returns 0E0 for 0.
  974   if ($rows == 0) {
  975     croak "putSetVersion: set version not found (perhaps you meant to use addSetVersion?)";
  976   } else {
  977     return $rows;
  978   }
  979 }
  980 
  981 # versioned analog of deleteUserSet
  982 sub deleteSetVersion {
  983   # userID, setID, and versionID can be undefined if being called from this package
  984   my $U = caller eq __PACKAGE__ ? "!" : "";
  985   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "version_id$U");
  986   $self->deleteProblemVersion($userID, $setID, $versionID, undef);
  987   return $self->{set_version}->delete($userID, $setID, $versionID);
  988 }
  989 
  990 ################################################################################
  991 # versioned set_merged functions (OLD)
  992 ################################################################################
  993 
  994 # getMergedVersionedSet( self, uid, sid [, versionNum] )
  995 #  in:  userID uid, setID sid, and optionally version number versionNum
  996 #  out: the merged set version for the user; if versionNum is specified,
  997 #     return that set version and otherwise the latest version.  if
  998 #     no versioned set exists for the user, return undef.
  999 #  note that sid can be setid,vN, thereby specifying the version number
 1000 #    explicitly.  if this is the case, any specified versionNum is ignored
 1001 # we'd like to use getMergedSet to do the dirty work here, but that runs
 1002 #  into problems because we want to merge with both the template set
 1003 #  (that is, the userSet setID) and the global set
 1004 sub getMergedVersionedSet {
 1005   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id!?/);
 1006 
 1007   # get version ID from $setID if $setID includes the version ID
 1008   # otherwise, use the explicit $versionID if given, or get the latest version
 1009   my ($using_setID, $using_versionID, $using_vsetID);
 1010   my ($grokked_setID, $grokked_versionID) = grok_vsetID($setID);
 1011   if ($grokked_versionID) {
 1012     # setID was versioned
 1013     $using_setID = $grokked_setID;
 1014     $using_versionID = $grokked_versionID;
 1015     $using_vsetID = $setID;
 1016   } else {
 1017     # setID was not versioned
 1018     $using_setID = $setID;
 1019     $using_versionID = $versionID || $self->getUserSetVersionNumber($userID, $setID);
 1020     $using_vsetID = make_vsetID($using_setID, $using_versionID);
 1021   }
 1022 
 1023   return ( $self->getMergedVersionedSets([$userID, $using_setID, $using_vsetID]) )[0];
 1024 }
 1025 
 1026 sub getMergedVersionedSets {
 1027   my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id vset_id/);
 1028 
 1029   # these are [user_id, set_id] pairs
 1030   my @nonversionedUserSetIDs = map { [$_->[0], $_->[1]] } @userSetIDs;
 1031 
 1032   # these are [user_id, versioned_set_id] pairs
 1033   my @versionedUserSetIDs = map { [$_->[0], $_->[2]] } @userSetIDs;
 1034 
 1035   # we merge the nonversioned ("template") user sets (user_id, set_id) and
 1036   #  the global data into the versioned user sets
 1037   debug("DB: getUserSets start (nonversioned)");
 1038   my @TemplateUserSets = $self->getUserSets(@nonversionedUserSetIDs);
 1039 
 1040   debug("DB: getUserSets start (versioned)");
 1041   # these are the actual user sets that we want to use
 1042   my @versionedUserSets = $self->getUserSets(@versionedUserSetIDs);
 1043 
 1044   debug("DB: pull out set IDs start");
 1045   my @globalSetIDs = map { $_->[1] } @userSetIDs;
 1046 
 1047   debug("DB: getGlobalSets start");
 1048   my @GlobalSets = $self->getGlobalSets(@globalSetIDs);
 1049 
 1050   debug("DB: calc common fields start");
 1051   my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
 1052   my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
 1053 
 1054   debug("DB: merge start");
 1055   for (my $i = 0; $i < @TemplateUserSets; $i++) {
 1056     next unless( defined $versionedUserSets[$i] and
 1057            (defined $TemplateUserSets[$i] or
 1058             defined $GlobalSets[$i]) );
 1059     foreach my $field (@commonFields) {
 1060       next if ( defined( $versionedUserSets[$i]->$field ) &&
 1061             $versionedUserSets[$i]->$field ne '' );
 1062       $versionedUserSets[$i]->$field($GlobalSets[$i]->$field) if
 1063         (defined($GlobalSets[$i]->$field) &&
 1064          $GlobalSets[$i]->$field ne '');
 1065       $versionedUserSets[$i]->$field($TemplateUserSets[$i]->$field)
 1066         if (defined($TemplateUserSets[$i]) &&
 1067           defined($TemplateUserSets[$i]->$field) &&
 1068           $TemplateUserSets[$i]->$field ne '');
 1069     }
 1070   }
 1071   debug("DB: merge done!");
 1072 
 1073   return @versionedUserSets;
 1074 }
 1075 
 1076 ################################################################################
 1077 # set_version_merged functions (NEW)
 1078 ################################################################################
 1079 
 1080 BEGIN {
 1081   *MergedSetVersion = gen_schema_accessor("set_version_merged");
 1082   #*newMergedSetVersion = gen_new("set_version_merged");
 1083   #*countMergedSetVersionsWhere = gen_count_where("set_version_merged");
 1084   *existsMergedSetVersionWhere = gen_exists_where("set_version_merged");
 1085   #*listMergedSetVersionsWhere = gen_list_where("set_version_merged");
 1086   *getMergedSetVersionsWhere = gen_get_records_where("set_version_merged");
 1087 }
 1088 
 1089 sub existsMergedSetVersion {
 1090   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1091   return $self->{set_version_merged}->exists($userID, $setID, $versionID);
 1092 }
 1093 
 1094 sub getMergedSetVersion {
 1095   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1096   return ( $self->getMergedSetVersions([$userID, $setID, $versionID]) )[0];
 1097 }
 1098 
 1099 sub getMergedSetVersions {
 1100   my ($self, @setVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id/);
 1101   return $self->{set_version_merged}->gets(@setVersionIDs);
 1102 }
 1103 
 1104 ################################################################################
 1105 # problem functions
 1106 ################################################################################
 1107 
 1108 BEGIN {
 1109   *GlobalProblem = gen_schema_accessor("problem");
 1110   *newGlobalProblem = gen_new("problem");
 1111   *countGlobalProblemsWhere = gen_count_where("problem");
 1112   *existsGlobalProblemWhere = gen_exists_where("problem");
 1113   *listGlobalProblemsWhere = gen_list_where("problem");
 1114   *getGlobalProblemsWhere = gen_get_records_where("problem");
 1115 }
 1116 
 1117 sub countGlobalProblems { return scalar shift->listGlobalProblems(@_) }
 1118 
 1119 sub listGlobalProblems {
 1120   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1121   my $where = [set_id_eq => $setID];
 1122   if (wantarray) {
 1123     return map { @$_ } $self->{problem}->get_fields_where(["problem_id"], $where);
 1124   } else {
 1125     return $self->{problem}->count_where($where);
 1126   }
 1127 }
 1128 
 1129 sub existsGlobalProblem {
 1130   my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/);
 1131   return $self->{problem}->exists($setID, $problemID);
 1132 }
 1133 
 1134 sub getGlobalProblem {
 1135   my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/);
 1136   return ( $self->getGlobalProblems([$setID, $problemID]) )[0];
 1137 }
 1138 
 1139 sub getGlobalProblems {
 1140   my ($self, @problemIDs) = shift->checkArgsRefList(\@_, qw/set_id problem_id/);
 1141   return $self->{problem}->gets(@problemIDs);
 1142 }
 1143 
 1144 sub getAllGlobalProblems {
 1145   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1146   my $where = [set_id_eq => $setID];
 1147   return $self->{problem}->get_records_where($where);
 1148 }
 1149 
 1150 sub addGlobalProblem {  my ($self, $GlobalProblem) = shift->checkArgs(\@_, qw/REC:problem/);
 1151 
 1152   croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1153     unless $self->{set}->exists($GlobalProblem->set_id);
 1154 
 1155   eval {
 1156     return $self->{problem}->add($GlobalProblem);
 1157   };
 1158   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
 1159     croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)";
 1160   }
 1161 }
 1162 
 1163 sub putGlobalProblem {
 1164   my ($self, $GlobalProblem) = shift->checkArgs(\@_, qw/REC:problem/);
 1165   my $rows = $self->{problem}->put($GlobalProblem); # DBI returns 0E0 for 0.
 1166   if ($rows == 0) {
 1167     croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)";
 1168   } else {
 1169     return $rows;
 1170   }
 1171 }
 1172 
 1173 sub deleteGlobalProblem {
 1174   # userID and setID can be undefined if being called from this package
 1175   my $U = caller eq __PACKAGE__ ? "!" : "";
 1176   my ($self, $setID, $problemID) = shift->checkArgs(\@_, "set_id$U", "problem_id$U");
 1177   $self->deleteUserProblem(undef, $setID, $problemID);
 1178   return $self->{problem}->delete($setID, $problemID);
 1179 }
 1180 
 1181 ################################################################################
 1182 # problem_user functions
 1183 ################################################################################
 1184 
 1185 BEGIN {
 1186   *UserProblem = gen_schema_accessor("problem_user");
 1187   *newUserProblem = gen_new("problem_user");
 1188   *countUserProblemsWhere = gen_count_where("problem_user");
 1189   *existsUserProblemWhere = gen_exists_where("problem_user");
 1190   *listUserProblemsWhere = gen_list_where("problem_user");
 1191   *getUserProblemsWhere = gen_get_records_where("problem_user");
 1192 }
 1193 
 1194 sub countProblemUsers { return scalar shift->listProblemUsers(@_) }
 1195 
 1196 sub listProblemUsers {
 1197   my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/);
 1198   my $where = [set_id_eq_problem_id_eq => $setID,$problemID];
 1199   if (wantarray) {
 1200     return map { @$_ } $self->{problem_user}->get_fields_where(["user_id"], $where);
 1201   } else {
 1202     return $self->{problem_user}->count_where($where);
 1203   }
 1204 }
 1205 
 1206 sub countUserProblems { return scalar shift->listUserProblems(@_) }
 1207 
 1208 sub listUserProblems {
 1209   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1210   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1211   if (wantarray) {
 1212     return map { @$_ } $self->{problem_user}->get_fields_where(["problem_id"], $where);
 1213   } else {
 1214     return $self->{problem_user}->count_where($where);
 1215   }
 1216 }
 1217 
 1218 sub existsUserProblem {
 1219   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1220   return $self->{problem_user}->exists($userID, $setID, $problemID);
 1221 }
 1222 
 1223 sub getUserProblem {
 1224   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1225   return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0];
 1226 }
 1227 
 1228 sub getUserProblems {
 1229   my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id problem_id/);
 1230   return $self->{problem_user}->gets(@userProblemIDs);
 1231 }
 1232 
 1233 sub getAllUserProblems {
 1234   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1235   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1236   return $self->{problem_user}->get_records_where($where);
 1237 }
 1238 
 1239 sub addUserProblem {
 1240   # VERSIONING - accept versioned ID fields
 1241   my ($self, $UserProblem) = shift->checkArgs(\@_, qw/VREC:problem_user/);
 1242 
 1243   croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1244     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1245 
 1246   # gateway: we need to check for the existence of the problem with
 1247   # the non-versioned set_id (this should probably do something with
 1248   # grok_vsetID, but I don't think that does both versioned and
 1249   # unversioned set IDs)
 1250   my $nv_set_id = ( $UserProblem->set_id =~ /(.+),v\d+$/ ) ? $1 :
 1251     $UserProblem->set_id;
 1252   croak "addUserProblem: problem ", $UserProblem->problem_id, " in set $nv_set_id not found"
 1253     unless $self->{problem}->exists($nv_set_id, $UserProblem->problem_id);
 1254 
 1255   eval {
 1256     return $self->{problem_user}->add($UserProblem);
 1257   };
 1258   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
 1259     croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)";
 1260   }
 1261 }
 1262 
 1263 # versioned_ok is an optional argument which lets us slip versioned setIDs through checkArgs.
 1264 sub putUserProblem {
 1265   my $V = $_[2] ? "V" : "";
 1266   my ($self, $UserProblem, undef) = shift->checkArgs(\@_, "${V}REC:problem_user", "versioned_ok!?");
 1267 
 1268   my $rows = $self->{problem_user}->put($UserProblem); # DBI returns 0E0 for 0.
 1269   if ($rows == 0) {
 1270     croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)";
 1271   } else {
 1272     return $rows;
 1273   }
 1274 }
 1275 
 1276 sub deleteUserProblem {
 1277   # userID, setID, and problemID can be undefined if being called from this package
 1278   my $U = caller eq __PACKAGE__ ? "!" : "";
 1279   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "problem_id$U");
 1280   return $self->{problem_user}->delete($userID, $setID, $problemID);
 1281 }
 1282 
 1283 ################################################################################
 1284 # problem_merged functions
 1285 ################################################################################
 1286 
 1287 BEGIN {
 1288   *MergedProblem = gen_schema_accessor("problem_merged");
 1289   #*newMergedProblem = gen_new("problem_merged");
 1290   #*countMergedProblemsWhere = gen_count_where("problem_merged");
 1291   *existsMergedProblemWhere = gen_exists_where("problem_merged");
 1292   #*listMergedProblemsWhere = gen_list_where("problem_merged");
 1293   *getMergedProblemsWhere = gen_get_records_where("problem_merged");
 1294 }
 1295 
 1296 sub existsMergedProblem {
 1297   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1298   return $self->{problem_merged}->exists($userID, $setID, $problemID);
 1299 }
 1300 
 1301 sub getMergedProblem {
 1302   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1303   return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0];
 1304 }
 1305 
 1306 sub getMergedProblems {
 1307   my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id problem_id/);
 1308   return $self->{problem_merged}->gets(@userProblemIDs);
 1309 }
 1310 
 1311 sub getAllMergedUserProblems {
 1312   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1313   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1314   return $self->{problem_merged}->get_records_where($where);
 1315 }
 1316 
 1317 ################################################################################
 1318 # problem_version functions (NEW)
 1319 ################################################################################
 1320 
 1321 BEGIN {
 1322   *ProblemVersion = gen_schema_accessor("problem_version");
 1323   *newProblemVersion = gen_new("problem_version");
 1324   *countProblemVersionsWhere = gen_count_where("problem_version");
 1325   *existsProblemVersionWhere = gen_exists_where("problem_version");
 1326   *listProblemVersionsWhere = gen_list_where("problem_version");
 1327   *getProblemVersionsWhere = gen_get_records_where("problem_version");
 1328 }
 1329 
 1330 # versioned analog of countUserProblems
 1331 sub countProblemVersions { return scalar shift->listProblemVersions(@_) }
 1332 
 1333 # versioned analog of listUserProblems
 1334 # for consistency, we should name this "listProblemVersions", but that is
 1335 # confusing, as that sounds as if we're listing the versions of a problem.
 1336 # however, that's nonsensical, so we appropriate it here and don't worry
 1337 # about the confusion.
 1338 sub listProblemVersions {
 1339   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1340   my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID];
 1341   if (wantarray) {
 1342     return map { @$_ } $self->{problem_version}->get_fields_where(["problem_id"], $where);
 1343   } else {
 1344     return $self->{problem_version}->count_where($where);
 1345   }
 1346 }
 1347 
 1348 # this code returns a list of all problem versions with the given userID,
 1349 # setID, and problemID, but that is (darn well ought to be) the same as
 1350 # listSetVersions, so it's not so useful as all that; c.f. above.
 1351 # sub listProblemVersions {
 1352 #   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1353 #   my $where = [user_id_eq_set_id_eq_problem_id_eq => $userID,$setID,$problemID];
 1354 #   if (wantarray) {
 1355 #     return grep { @$_ } $self->{problem_version}->get_fields_where(["version_id"], $where);
 1356 #   } else {
 1357 #     return $self->{problem_version}->count_where($where);
 1358 #   }
 1359 # }
 1360 
 1361 # versioned analog of existsUserProblem
 1362 sub existsProblemVersion {
 1363   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1364   return $self->{problem_version}->exists($userID, $setID, $versionID, $problemID);
 1365 }
 1366 
 1367 # versioned analog of getUserProblem
 1368 sub getProblemVersion {
 1369   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1370   return ( $self->getProblemVersions([$userID, $setID, $versionID, $problemID]) )[0];
 1371 }
 1372 
 1373 # versioned analog of getUserProblems
 1374 sub getProblemVersions {
 1375   my ($self, @problemVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id problem_id/);
 1376   return $self->{problem_version}->gets(@problemVersionIDs);
 1377 }
 1378 
 1379 # versioned analog of getAllUserProblems
 1380 sub getAllProblemVersions {
 1381   my ( $self, $userID, $setID, $versionID ) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1382   my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID];
 1383   return $self->{problem_version_merged}->get_records_where($where);
 1384 }
 1385 
 1386 
 1387 # versioned analog of addUserProblem
 1388 sub addProblemVersion {
 1389   my ($self, $ProblemVersion) = shift->checkArgs(\@_, qw/REC:problem_version/);
 1390 
 1391   croak "addProblemVersion: set version ", $ProblemVersion->version_id, " of set ", $ProblemVersion->set_id, " not found for user ", $ProblemVersion->user_id
 1392     unless $self->{set_version}->exists($ProblemVersion->user_id, $ProblemVersion->set_id, $ProblemVersion->version_id);
 1393   croak "addProblemVersion: problem ", $ProblemVersion->problem_id, " of set ", $ProblemVersion->set_id, " not found for user ", $ProblemVersion->user_id
 1394     unless $self->{problem_user}->exists($ProblemVersion->user_id, $ProblemVersion->set_id, $ProblemVersion->problem_id);
 1395 
 1396   eval {
 1397     return $self->{problem_version}->add($ProblemVersion);
 1398   };
 1399   if (my $ex = caught WeBWorK::DB::Schema::Exception::RecordExists) {
 1400     croak "addProblemVersion: problem version exists (perhaps you meant to use putProblemVersion?)";
 1401   }
 1402 }
 1403 
 1404 # versioned analog of putUserProblem
 1405 sub putProblemVersion {
 1406   my ($self, $ProblemVersion) = shift->checkArgs(\@_, qw/REC:problem_version/);
 1407   my $rows = $self->{problem_version}->put($ProblemVersion); # DBI returns 0E0 for 0.
 1408   if ($rows == 0) {
 1409     croak "putProblemVersion: problem version not found (perhaps you meant to use addProblemVersion?)";
 1410   } else {
 1411     return $rows;
 1412   }
 1413 }
 1414 
 1415 # versioned analog of deleteUserProblem
 1416 sub deleteProblemVersion {
 1417   # userID, setID, versionID, and problemID can be undefined if being called from this package
 1418   my $U = caller eq __PACKAGE__ ? "!" : "";
 1419   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "version_id$U", "problem_id$U");
 1420   return $self->{problem_version}->delete($userID, $setID, $versionID, $problemID);
 1421 }
 1422 
 1423 ################################################################################
 1424 # versioned problem_merged functions (OLD)
 1425 ################################################################################
 1426 
 1427 # this exists distinct from getMergedProblem only to be able to include the setVersionID
 1428 sub getMergedVersionedProblem {
 1429   my ($self, $userID, $setID, $setVersionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1430   return ( $self->getMergedVersionedProblems([$userID, $setID, $setVersionID, $problemID]) )[0];
 1431 }
 1432 
 1433 sub getMergedVersionedProblems {
 1434   my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id vset_id problem_id/);
 1435 
 1436   debug("DB: getUserProblems start");
 1437 
 1438   # these are triples [user_id, set_id, problem_id]
 1439   my @nonversionedProblemIDs = map {[$_->[0],$_->[1],$_->[3]]} @userProblemIDs;
 1440 
 1441   # these are triples [user_id, versioned_set_id, problem_id]
 1442   my @versionedProblemIDs = map {[$_->[0],$_->[2],$_->[3]]} @userProblemIDs;
 1443 
 1444   # these are the actual user problems for the version
 1445   my @versionUserProblems = $self->getUserProblems(@versionedProblemIDs);
 1446 
 1447   # get global problems (no user_id, set_id = nonversioned set_id) and template
 1448   # problems (user_id, set_id = nonversioned set_id); we merge with both of these,
 1449   # replacing global values with template values and not taking either in the event
 1450   # that the versioned problem already has a value for the field in question
 1451   debug("DB: pull out set/problem IDs start");
 1452   my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @nonversionedProblemIDs;
 1453 
 1454   debug("DB: getGlobalProblems start");
 1455   my @GlobalProblems = $self->getGlobalProblems( @globalProblemIDs );
 1456 
 1457   debug("DB: getTemplateProblems start");
 1458   my @TemplateProblems = $self->getUserProblems( @nonversionedProblemIDs );
 1459 
 1460   debug("DB: calc common fields start");
 1461   my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
 1462   my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
 1463 
 1464   debug("DB: merge start");
 1465   for (my $i = 0; $i < @versionUserProblems; $i++) {
 1466     my $UserProblem = $versionUserProblems[$i];
 1467     my $GlobalProblem = $GlobalProblems[$i];
 1468     my $TemplateProblem = $TemplateProblems[$i];
 1469     next unless defined $UserProblem and ( defined $GlobalProblem or
 1470                          defined $TemplateProblem );
 1471     foreach my $field (@commonFields) {
 1472       next if defined $UserProblem->$field && $UserProblem->$field ne '';
 1473       $UserProblem->$field($GlobalProblem->$field)
 1474         if ( defined($GlobalProblem) && defined($GlobalProblem->$field)
 1475            && $GlobalProblem->$field ne '' );
 1476       $UserProblem->$field($TemplateProblem->$field)
 1477         if ( defined($TemplateProblem) &&
 1478            defined($TemplateProblem->$field) &&
 1479            $TemplateProblem->$field ne '' );
 1480     }
 1481   }
 1482   debug("DB: merge done!");
 1483 
 1484   return @versionUserProblems;
 1485 }
 1486 
 1487 ################################################################################
 1488 # problem_version_merged functions (NEW)
 1489 ################################################################################
 1490 
 1491 BEGIN {
 1492   *MergedProblemVersion = gen_schema_accessor("problem_version_merged");
 1493   #*newMergedProblemVersion = gen_new("problem_version_merged");
 1494   #*countMergedProblemVersionsWhere = gen_count_where("problem_version_merged");
 1495   *existsMergedProblemVersionWhere = gen_exists_where("problem_version_merged");
 1496   #*listMergedProblemVersionsWhere = gen_list_where("problem_version_merged");
 1497   *getMergedProblemVersionsWhere = gen_get_records_where("problem_version_merged");
 1498 }
 1499 
 1500 sub existsMergedProblemVersion {
 1501   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1502   return $self->{problem_version_merged}->exists($userID, $setID, $versionID, $problemID);
 1503 }
 1504 
 1505 sub getMergedProblemVersion {
 1506   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1507   return ( $self->getMergedProblemVersions([$userID, $setID, $versionID, $problemID]) )[0];
 1508 }
 1509 
 1510 sub getMergedProblemVersions {
 1511   my ($self, @problemVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id problem_id/);
 1512   return $self->{problem_version_merged}->gets(@problemVersionIDs);
 1513 }
 1514 
 1515 sub getAllMergedProblemVersions {
 1516   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1517   my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID];
 1518   return $self->{problem_version_merged}->get_records_where($where);
 1519 }
 1520 
 1521 ################################################################################
 1522 # utilities
 1523 ################################################################################
 1524 
 1525 # the (optional) second argument to checkKeyfields is to support versioned
 1526 # (gateway) sets, which may include commas in certain fields (in particular,
 1527 # set names (e.g., setDerivativeGateway,v1) and user names (e.g.,
 1528 # username,proctorname)
 1529 
 1530 sub checkKeyfields($;$) {
 1531   my ($Record, $versioned) = @_;
 1532   foreach my $keyfield ($Record->KEYFIELDS) {
 1533     my $value = $Record->$keyfield;
 1534 
 1535     croak "undefined '$keyfield' field"
 1536       unless defined $value;
 1537     croak "empty '$keyfield' field"
 1538       unless $value ne "";
 1539 
 1540     if ($keyfield eq "problem_id") {
 1541       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [0-9])"
 1542         unless $value =~ m/^[0-9]*$/;
 1543     } elsif ($versioned and ($keyfield eq "set_id" or $keyfield eq "user_id")) {
 1544       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-zA-Z0-9_.,])"
 1545         unless $value =~ m/^[-a-zA-Z0-9_.,]*$/;
 1546     } else {
 1547       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-zA-Z0-9_.])"
 1548         unless $value =~ m/^[-a-zA-Z0-9_.]*$/;
 1549     }
 1550   }
 1551 }
 1552 
 1553 # checkArgs spec syntax:
 1554 #
 1555 # spec = list_item | item*
 1556 # list_item = item is_list
 1557 # is_list = "*"
 1558 # item = item_name undef_ok? optional?
 1559 # item_name = record_item | bare_item
 1560 # record_item = is_versioned? "REC:" table
 1561 # is_versioned = "V"
 1562 # table = \w+
 1563 # bare_item = \w+
 1564 # undef_ok = "!"
 1565 # optional = "?"
 1566 #
 1567 # [[V]REC:]foo[!][?][*]
 1568 
 1569 sub checkArgs {
 1570   my ($self, $args, @spec) = @_;
 1571 
 1572   my $is_list = @spec == 1 && $spec[0] =~ s/\*$//;
 1573   my ($min_args, $max_args);
 1574   if ($is_list) {
 1575     $min_args = 0;
 1576   } else {
 1577     foreach my $i (0..$#spec) {
 1578       #print "$i - $spec[$i]\n";
 1579       if ($spec[$i] =~ s/\?$//) {
 1580         #print "$i - matched\n";
 1581         $min_args = $i unless defined $min_args;
 1582       }
 1583     }
 1584     $min_args = @spec unless defined $min_args;
 1585     $max_args = @spec;
 1586   }
 1587 
 1588   if (@$args < $min_args or defined $max_args and @$args > $max_args) {
 1589     if ($min_args == $max_args) {
 1590       my $s = $min_args == 1 ? "" : "s";
 1591       croak "requires $min_args argument$s";
 1592     } elsif (defined $max_args) {
 1593       croak "requires between $min_args and $max_args arguments";
 1594     } else {
 1595       my $s = $min_args == 1 ? "" : "s";
 1596       croak "requires at least $min_args argument$s";
 1597     }
 1598   }
 1599 
 1600   my ($name, $versioned, $table);
 1601   if ($is_list) {
 1602     $name = $spec[0];
 1603     ($versioned, $table) = $name =~ /^(V?)REC:(.*)/;
 1604   }
 1605 
 1606   foreach my $i (0..@$args-1) {
 1607     my $arg = $args->[$i];
 1608     my $pos = $i+1;
 1609 
 1610     unless ($is_list) {
 1611       $name = $spec[$i];
 1612       ($versioned, $table) = $name =~ /^(V?)REC:(.*)/;
 1613     }
 1614 
 1615     if (defined $table) {
 1616       my $class = $self->{$table}{record};
 1617       #print "arg=$arg class=$class\n";
 1618       croak "argument $pos must be of type $class"
 1619         unless defined $arg and ref $arg and $arg->isa($class);
 1620       eval { checkKeyfields($arg, $versioned) };
 1621       croak "argument $pos contains $@" if $@;
 1622     } else {
 1623       if ($name !~ /!$/) {
 1624         croak "argument $pos must contain a $name"
 1625           unless defined $arg;
 1626       }
 1627     }
 1628   }
 1629 
 1630   return $self, @$args;
 1631 }
 1632 
 1633 sub checkArgsRefList {
 1634   my ($self, $items, @spec) = @_;
 1635   foreach my $i (0..@$items-1) {
 1636     my $item = $items->[$i];
 1637     my $pos = $i+1;
 1638     croak "item $pos must be a reference to an array"
 1639       unless UNIVERSAL::isa($item, "ARRAY");
 1640     eval { $self->checkArgs($item, @spec) };
 1641     croak "item $pos $@" if $@;
 1642   }
 1643 
 1644   return $self, @$items;
 1645 }
 1646 
 1647 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9