[system] / trunk / webwork-modperl / lib / WeBWorK / DB.pm Repository:
ViewVC logotype

View of /trunk/webwork-modperl/lib/WeBWorK/DB.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6288 - (download) (as text) (annotate)
Mon May 31 15:47:52 2010 UTC (9 years, 7 months ago) by glarose
File size: 69288 byte(s)
Relax error checking on user_id.  This allows user_id values to
look like set-level proctor ids (that is, to prepend set_id:
and append ,g), which isn't what we want for the user_id check
in most cases, but shouldn't be a significant difficulty.  The
ideal is to know something about the set for which we're checking
the id, but that requires sending more information into DB than
we're sending now.

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System>
    3 # Copyright  2000-2007 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: webwork2/lib/WeBWorK/DB.pm,v 1.111 2010/05/19 01:44:05 gage 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 Scalar::Util qw/blessed/;
  101 use WeBWorK::DB::Schema;
  102 use WeBWorK::DB::Utils qw/make_vsetID grok_vsetID grok_setID_from_vsetID_sql
  103   grok_versionID_from_vsetID_sql/;
  104 use WeBWorK::Debug;
  105 use WeBWorK::Utils qw(runtime_use);
  106 
  107 =for comment
  108 
  109 These exceptions will replace the ones in WeBWorK::DB::Schema and will be
  110 allowed to propagate out to calling code. The following callers will have to be
  111 changed to catch these exceptions instead of doing string matching:
  112 
  113 lib/WebworkSOAP.pm:     if ($@ =~ m/user set exists/) {
  114 lib/WeBWorK/ContentGenerator/Instructor.pm:             if ($@ =~ m/user set exists/) {
  115 lib/WeBWorK/ContentGenerator/Instructor.pm:     if ( $@ =~ m/user set exists/ ) {
  116 lib/WeBWorK/ContentGenerator/Instructor.pm:             if ($@ =~ m/user problem exists/) {
  117 lib/WeBWorK/ContentGenerator/Instructor.pm:             if ($@ =~ m/user problem exists/) {
  118 lib/WeBWorK/ContentGenerator/Instructor.pm:                     next if $@ =~ m/user set exists/;
  119 lib/WeBWorK/Utils/DBImportExport.pm:                            if ($@ =~ m/exists/) {
  120 lib/WeBWorK/DB.pm:                              if ($@ and $@ !~ m/password exists/) {
  121 lib/WeBWorK/DB.pm:                              if ($@ and $@ !~ m/permission level exists/) {
  122 
  123 How these exceptions should be used:
  124 
  125 * RecordExists is thrown by the DBI error handler (handle_error in
  126 Schema::NewSQL::Std) when in INSERT fails because a record exists. Thus it can
  127 be thrown via addUser, addPassword, etc.
  128 
  129 * RecordNotFound should be thrown when we try to UPDATE and zero rows were
  130 affected. Problem: Frank Wolfs (UofR PAS) may have a MySQL server that returns 0
  131 when updating even when a record was modified. What's up with that? There's some
  132 question as to where we should throw this: in this file's put* methods? In
  133 Std.pm's put method? Or in update_fields and update_fields_i?
  134 
  135 * DependencyNotFound should be throws when we check for a record that is needed
  136 to insert another record (e.g. password depends on user). These checks are done
  137 in this file, so we'll throw this exception from there.
  138 
  139 =cut
  140 
  141 use Exception::Class (
  142   'WeBWorK::DB::Ex' => {},
  143   'WeBWorK::DB::Ex::RecordExists' => {
  144     isa => 'WeBWorK::DB::Ex',
  145     fields => ['type', 'key'],
  146   },
  147   'WeBWorK::DB::Ex::RecordNotFound' => {
  148     isa => 'WeBWorK::DB::Ex',
  149     fields => ['type', 'key'],
  150   },
  151   'WeBWorK::DB::Ex::DependencyNotFound' => {
  152     isa => 'WeBWorK::DB::Ex::RecordNotFound',
  153   },
  154   'WeBWorK::DB::Ex::TableMissing' => {
  155       isa => 'WeBWorK::DB::Ex',
  156       description =>"missing table",
  157   },
  158 );
  159 
  160 ################################################################################
  161 # constructor
  162 ################################################################################
  163 
  164 =head1 CONSTRUCTOR
  165 
  166 =over
  167 
  168 =item new($dbLayout)
  169 
  170 The C<new> method creates a DB object and brings up the underlying schema/driver
  171 structure according to the hash referenced by C<$dbLayout>.
  172 
  173 =back
  174 
  175 =head2 C<$dbLayout> Format
  176 
  177 C<$dbLayout> is a hash reference consisting of items keyed by table names. The
  178 value of each item is a reference to a hash containing the following items:
  179 
  180 =over
  181 
  182 =item record
  183 
  184 The name of a perl module to use for representing the data in a record.
  185 
  186 =item schema
  187 
  188 The name of a perl module to use for access to the table.
  189 
  190 =item driver
  191 
  192 The name of a perl module to use for access to the data source.
  193 
  194 =item source
  195 
  196 The location of the data source that should be used by the driver module.
  197 Depending on the driver, this may be a path, a url, or a DBI spec.
  198 
  199 =item params
  200 
  201 A reference to a hash containing extra information needed by the schema. Some
  202 schemas require parameters, some do not. Consult the documentation for the
  203 schema in question.
  204 
  205 =back
  206 
  207 For each table defined in C<$dbLayout>, C<new> loads the record, schema, and
  208 driver modules. It the schema module's C<tables> method lists the current table
  209 (or contains the string "*") and the output of the schema and driver modules'
  210 C<style> methods match, the table is installed. Otherwise, an exception is
  211 thrown.
  212 
  213 =cut
  214 
  215 sub new {
  216   my ($invocant, $dbLayout) = @_;
  217   my $class = ref($invocant) || $invocant;
  218   my $self = {};
  219   bless $self, $class; # bless this here so we can pass it to the schema
  220 
  221   # load the modules required to handle each table, and create driver
  222   foreach my $table (keys %$dbLayout) {
  223     $self->init_table($dbLayout, $table);
  224   }
  225 
  226   return $self;
  227 }
  228 
  229 sub init_table {
  230   my ($self, $dbLayout, $table) = @_;
  231 
  232   if (exists $self->{$table}) {
  233     if (defined $self->{$table}) {
  234       return;
  235     } else {
  236       die "loop in dbLayout table dependencies involving table '$table'\n";
  237     }
  238   }
  239 
  240   my $layout = $dbLayout->{$table};
  241   my $record = $layout->{record};
  242   my $schema = $layout->{schema};
  243   my $driver = $layout->{driver};
  244   my $source = $layout->{source};
  245   my $depend = $layout->{depend};
  246   my $params = $layout->{params};
  247 
  248   # add a key for this table to the self hash, but don't define it yet
  249   # this for loop detection
  250   $self->{$table} = undef;
  251 
  252   if ($depend) {
  253     foreach my $dep (@$depend) {
  254       $self->init_table($dbLayout, $dep);
  255     }
  256   }
  257 
  258   runtime_use($record);
  259 
  260   runtime_use($driver);
  261   my $driverObject = eval { $driver->new($source, $params) };
  262   croak "error instantiating DB driver $driver for table $table: $@"
  263     if $@;
  264 
  265   runtime_use($schema);
  266   my $schemaObject = eval { $schema->new(
  267     $self, $driverObject, $table, $record, $params) };
  268   croak "error instantiating DB schema $schema for table $table: $@"
  269     if $@;
  270 
  271   $self->{$table} = $schemaObject;
  272 }
  273 
  274 ################################################################################
  275 # methods that can be autogenerated
  276 ################################################################################
  277 
  278 sub gen_schema_accessor {
  279   my $schema = shift;
  280   return sub { shift->{$schema} };
  281 }
  282 
  283 sub gen_new {
  284   my $table = shift;
  285   return sub { shift->{$table}{record}->new(@_) };
  286 }
  287 
  288 sub gen_count_where {
  289   my $table = shift;
  290   return sub {
  291     my ($self, $where) = @_;
  292     return $self->{$table}->count_where($where);
  293   };
  294 }
  295 
  296 sub gen_exists_where {
  297   my $table = shift;
  298   return sub {
  299     my ($self, $where) = @_;
  300     return $self->{$table}->exists_where($where);
  301   };
  302 }
  303 
  304 sub gen_list_where {
  305   my $table = shift;
  306   return sub {
  307     my ($self, $where, $order) = @_;
  308     if (wantarray) {
  309       return $self->{$table}->list_where($where, $order);
  310     } else {
  311       return $self->{$table}->list_where_i($where, $order);
  312     }
  313   };
  314 }
  315 
  316 sub gen_get_records_where {
  317   my $table = shift;
  318   return sub {
  319     my ($self, $where, $order) = @_;
  320     if (wantarray) {
  321       return $self->{$table}->get_records_where($where, $order);
  322     } else {
  323       return $self->{$table}->get_records_where_i($where, $order);
  324     }
  325   };
  326 }
  327 
  328 sub gen_insert_records {
  329   my $table = shift;
  330   return sub {
  331     my ($self, @records) = @_;
  332     if (@records == 1 and blessed $records[0] and $records[0]->isa("Iterator")) {
  333       return $self->{$table}->insert_records_i($records[0]);
  334     } else {
  335       return $self->{$table}->insert_records(@records);
  336     }
  337   };
  338 }
  339 
  340 sub gen_update_records {
  341   my $table = shift;
  342   return sub {
  343     my ($self, @records) = @_;
  344     if (@records == 1 and blessed $records[0] and $records[0]->isa("Iterator")) {
  345       return $self->{$table}->update_records_i($records[0]);
  346     } else {
  347       return $self->{$table}->update_records(@records);
  348     }
  349   };
  350 }
  351 
  352 sub gen_delete_where {
  353   my $table = shift;
  354   return sub {
  355     my ($self, $where) = @_;
  356     return $self->{$table}->delete_where($where);
  357   };
  358 }
  359 
  360 ################################################################################
  361 # create/rename/delete/dump/restore tables
  362 ################################################################################
  363 
  364 sub create_tables {
  365   my ($self) = @_;
  366 
  367   foreach my $table (keys %$self) {
  368     next if $table =~ /^_/; # skip non-table self fields (none yet)
  369     next if $self->{$table}{params}{non_native}; # skip non-native tables
  370     my $schema_obj = $self->{$table};
  371     if ($schema_obj->can("create_table")) {
  372       $schema_obj->create_table;
  373     } else {
  374       warn "skipping creation of '$table' table: no create_table method\n";
  375     }
  376   }
  377 
  378   return 1;
  379 }
  380 
  381 sub rename_tables {
  382   my ($self, $new_dblayout) = @_;
  383 
  384   foreach my $table (keys %$self) {
  385     next if $table =~ /^_/; # skip non-table self fields (none yet)
  386     next if $self->{$table}{params}{non_native}; # skip non-native tables
  387     my $schema_obj = $self->{$table};
  388     if (exists $new_dblayout->{$table}) {
  389       if ($schema_obj->can("rename_table")) {
  390         # we look into the new dblayout to determine the new table names
  391         my $new_sql_table_name = defined $new_dblayout->{$table}{params}{tableOverride}
  392           ? $new_dblayout->{$table}{params}{tableOverride}
  393           : $table;
  394         $schema_obj->rename_table($new_sql_table_name);
  395       } else {
  396         warn "skipping renaming of '$table' table: no rename_table method\n";
  397       }
  398     } else {
  399       warn "skipping renaming of '$table' table: table doesn't exist in new dbLayout\n";
  400     }
  401   }
  402 
  403   return 1;
  404 }
  405 
  406 sub delete_tables {
  407   my ($self) = @_;
  408 
  409   foreach my $table (keys %$self) {
  410     next if $table =~ /^_/; # skip non-table self fields (none yet)
  411     next if $self->{$table}{params}{non_native}; # skip non-native tables
  412     my $schema_obj = $self->{$table};
  413     if ($schema_obj->can("delete_table")) {
  414       $schema_obj->delete_table;
  415     } else {
  416       warn "skipping deletion of '$table' table: no delete_table method\n";
  417     }
  418   }
  419 
  420   return 1;
  421 }
  422 
  423 sub dump_tables {
  424   my ($self, $dump_dir) = @_;
  425 
  426   foreach my $table (keys %$self) {
  427     next if $table =~ /^_/; # skip non-table self fields (none yet)
  428     next if $self->{$table}{params}{non_native}; # skip non-native tables
  429     my $schema_obj = $self->{$table};
  430     if ($schema_obj->can("dump_table")) {
  431       my $dump_file = "$dump_dir/$table.sql";
  432       $schema_obj->dump_table($dump_file);
  433     } else {
  434       warn "skipping dump of '$table' table: no dump_table method\n";
  435     }
  436   }
  437 
  438   return 1;
  439 }
  440 
  441 sub restore_tables {
  442   my ($self, $dump_dir) = @_;
  443 
  444   foreach my $table (keys %$self) {
  445     next if $table =~ /^_/; # skip non-table self fields (none yet)
  446     next if $self->{$table}{params}{non_native}; # skip non-native tables
  447     my $schema_obj = $self->{$table};
  448     if ($schema_obj->can("restore_table")) {
  449       my $dump_file = "$dump_dir/$table.sql";
  450       $schema_obj->restore_table($dump_file);
  451     } else {
  452       warn "skipping restore of '$table' table: no restore_table method\n";
  453     }
  454   }
  455 
  456   return 1;
  457 }
  458 
  459 ################################################################################
  460 # user functions
  461 ################################################################################
  462 
  463 BEGIN {
  464   *User = gen_schema_accessor("user");
  465   *newUser = gen_new("user");
  466   *countUsersWhere = gen_count_where("user");
  467   *existsUserWhere = gen_exists_where("user");
  468   *listUsersWhere = gen_list_where("user");
  469   *getUsersWhere = gen_get_records_where("user");
  470 }
  471 
  472 sub countUsers { return scalar shift->listUsers(@_) }
  473 
  474 sub listUsers {
  475   my ($self) = shift->checkArgs(\@_);
  476   if (wantarray) {
  477     return map { @$_ } $self->{user}->get_fields_where(["user_id"]);
  478   } else {
  479     return $self->{user}->count_where;
  480   }
  481 }
  482 
  483 sub existsUser {
  484   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  485   return $self->{user}->exists($userID);
  486 }
  487 
  488 sub getUser {
  489   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  490   return ( $self->getUsers($userID) )[0];
  491 }
  492 
  493 sub getUsers {
  494   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  495   return $self->{user}->gets(map { [$_] } @userIDs);
  496 }
  497 
  498 sub addUser {
  499   my ($self, $User) = shift->checkArgs(\@_, qw/REC:user/);
  500   eval {
  501     return $self->{user}->add($User);
  502   };
  503   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
  504     croak "addUser: user exists (perhaps you meant to use putUser?)";
  505   } elsif ($@) {
  506     die $@;
  507   }
  508   # FIXME about these exceptions: eventually the exceptions should be part of
  509   # WeBWorK::DB rather than WeBWorK::DB::Schema, and we should just let them
  510   # through to the calling code. however, right now we have code that checks
  511   # for the string "... exists" in the error message, so we need to convert
  512   # here.
  513   #
  514   # WeBWorK::DB::Ex::RecordExists
  515   # WeBWorK::DB::Ex::DependencyNotFound - i.e. inserting a password for a nonexistent user
  516   # ?
  517 }
  518 
  519 sub putUser {
  520   my ($self, $User) = shift->checkArgs(\@_, qw/REC:user/);
  521   my $rows = $self->{user}->put($User); # DBI returns 0E0 for 0.
  522   if ($rows == 0) {
  523     croak "putUser: user not found (perhaps you meant to use addUser?)";
  524   } else {
  525     return $rows;
  526   }
  527 }
  528 
  529 sub deleteUser {
  530   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  531   $self->deleteUserSet($userID, undef);
  532   $self->deletePassword($userID);
  533   $self->deletePermissionLevel($userID);
  534   $self->deleteKey($userID);
  535   return $self->{user}->delete($userID);
  536 }
  537 
  538 ################################################################################
  539 # password functions
  540 ################################################################################
  541 
  542 BEGIN {
  543   *Password = gen_schema_accessor("password");
  544   *newPassword = gen_new("password");
  545   *countPasswordsWhere = gen_count_where("password");
  546   *existsPasswordWhere = gen_exists_where("password");
  547   *listPasswordsWhere = gen_list_where("password");
  548   *getPasswordsWhere = gen_get_records_where("password");
  549 }
  550 
  551 sub countPasswords { return scalar shift->countPasswords(@_) }
  552 
  553 sub listPasswords {
  554   my ($self) = shift->checkArgs(\@_);
  555   if (wantarray) {
  556     return map { @$_ } $self->{password}->get_fields_where(["user_id"]);
  557   } else {
  558     return $self->{password}->count_where;
  559   }
  560 }
  561 
  562 sub existsPassword {
  563   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  564   # FIXME should we claim that a password exists if the user exists, since
  565   # password records are auto-created?
  566   return $self->{password}->exists($userID);
  567 }
  568 
  569 sub getPassword {
  570   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  571   return ( $self->getPasswords($userID) )[0];
  572 }
  573 
  574 sub getPasswords {
  575   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  576 
  577   my @Passwords = $self->{password}->gets(map { [$_] } @userIDs);
  578 
  579   # AUTO-CREATE missing password records
  580   # (this code is duplicated in getPermissionLevels, below)
  581   for (my $i = 0; $i < @Passwords; $i++) {
  582     my $Password = $Passwords[$i];
  583     my $userID = $userIDs[$i];
  584     if (not defined $Password) {
  585       if ($self->{user}->exists($userID)) {
  586         $Password = $self->newPassword(user_id => $userID);
  587         eval { $self->addPassword($Password) };
  588         if ($@ and $@ !~ m/password exists/) {
  589           die "error while auto-creating password record for user $userID: $@";
  590         }
  591         $Passwords[$i] = $Password;
  592       }
  593     }
  594   }
  595 
  596   return @Passwords;
  597 }
  598 
  599 sub addPassword {
  600   my ($self, $Password) = shift->checkArgs(\@_, qw/REC:password/);
  601 
  602   croak "addPassword: user ", $Password->user_id, " not found"
  603     unless $self->{user}->exists($Password->user_id);
  604 
  605   eval {
  606     return $self->{password}->add($Password);
  607   };
  608   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
  609     croak "addPassword: password exists (perhaps you meant to use putPassword?)";
  610   } elsif ($@) {
  611     die $@;
  612   }
  613 }
  614 
  615 sub putPassword {
  616   my ($self, $Password) = shift->checkArgs(\@_, qw/REC:password/);
  617   my $rows = $self->{password}->put($Password); # DBI returns 0E0 for 0.
  618   if ($rows == 0) {
  619     # AUTO-CREATE permission level records
  620     return $self->addPassword($Password);
  621   } else {
  622     return $rows;
  623   }
  624 }
  625 
  626 sub deletePassword {
  627   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  628   return $self->{password}->delete($userID);
  629 }
  630 
  631 ################################################################################
  632 # permission functions
  633 ################################################################################
  634 
  635 BEGIN {
  636   *PermissionLevel = gen_schema_accessor("permission");
  637   *newPermissionLevel = gen_new("permission");
  638   *countPermissionLevelsWhere = gen_count_where("permission");
  639   *existsPermissionLevelWhere = gen_exists_where("permission");
  640   *listPermissionLevelsWhere = gen_list_where("permission");
  641   *getPermissionLevelsWhere = gen_get_records_where("permission");
  642 }
  643 
  644 sub countPermissionLevels { return scalar shift->listPermissionLevels(@_) }
  645 
  646 sub listPermissionLevels {
  647   my ($self) = shift->checkArgs(\@_);
  648   if (wantarray) {
  649     return map { @$_ } $self->{permission}->get_fields_where(["user_id"]);
  650   } else {
  651     return $self->{permission}->count_where;
  652   }
  653 }
  654 
  655 sub existsPermissionLevel {
  656   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  657   # FIXME should we claim that a permission level exists if the user exists,
  658   # since password records are auto-created?
  659   return $self->{permission}->exists($userID);
  660 }
  661 
  662 sub getPermissionLevel {
  663   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  664   return ( $self->getPermissionLevels($userID) )[0];
  665 }
  666 
  667 sub getPermissionLevels {
  668   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  669 
  670   my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs);
  671 
  672   # AUTO-CREATE missing permission level records
  673   # (this code is duplicated in getPasswords, above)
  674   for (my $i = 0; $i < @PermissionLevels; $i++) {
  675     my $PermissionLevel = $PermissionLevels[$i];
  676     my $userID = $userIDs[$i];
  677     if (not defined $PermissionLevel) {
  678       if ($self->{user}->exists($userID)) {
  679         $PermissionLevel = $self->newPermissionLevel(user_id => $userID);
  680         eval { $self->addPermissionLevel($PermissionLevel) };
  681         if ($@ and $@ !~ m/permission level exists/) {
  682           die "error while auto-creating permission level record for user $userID: $@";
  683         }
  684         $PermissionLevels[$i] = $PermissionLevel;
  685       }
  686     }
  687   }
  688 
  689   return @PermissionLevels;
  690 }
  691 
  692 sub addPermissionLevel {
  693   my ($self, $PermissionLevel) = shift->checkArgs(\@_, qw/REC:permission/);
  694 
  695   croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found"
  696     unless $self->{user}->exists($PermissionLevel->user_id);
  697 
  698   eval {
  699     return $self->{permission}->add($PermissionLevel);
  700   };
  701   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
  702     croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)";
  703   } elsif ($@) {
  704     die $@;
  705   }
  706 }
  707 
  708 sub putPermissionLevel {
  709   my ($self, $PermissionLevel) = shift->checkArgs(\@_, qw/REC:permission/);
  710   my $rows = $self->{permission}->put($PermissionLevel); # DBI returns 0E0 for 0.
  711   if ($rows == 0) {
  712     # AUTO-CREATE permission level records
  713     return $self->addPermissionLevel($PermissionLevel);
  714   } else {
  715     return $rows;
  716   }
  717 }
  718 
  719 sub deletePermissionLevel {
  720   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  721   return $self->{permission}->delete($userID);
  722 }
  723 
  724 ################################################################################
  725 # key functions
  726 ################################################################################
  727 
  728 BEGIN {
  729   *Key = gen_schema_accessor("key");
  730   *newKey = gen_new("key");
  731   *countKeysWhere = gen_count_where("key");
  732   *existsKeyWhere = gen_exists_where("key");
  733   *listKeysWhere = gen_list_where("key");
  734   *getKeysWhere = gen_get_records_where("key");
  735 }
  736 
  737 sub countKeys { return scalar shift->listKeys(@_) }
  738 
  739 sub listKeys {
  740   my ($self) = shift->checkArgs(\@_);
  741   if (wantarray) {
  742     return map { @$_ } $self->{key}->get_fields_where(["user_id"]);
  743   } else {
  744     return $self->{key}->count_where;
  745   }
  746 }
  747 
  748 sub existsKey {
  749   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  750   return $self->{key}->exists($userID);
  751 }
  752 
  753 sub getKey {
  754   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  755   return ( $self->getKeys($userID) )[0];
  756 }
  757 
  758 sub getKeys {
  759   my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/);
  760   return $self->{key}->gets(map { [$_] } @userIDs);
  761 }
  762 
  763 sub addKey {
  764   # PROCTORING - allow comma in keyfields
  765   my ($self, $Key) = shift->checkArgs(\@_, qw/VREC:key/);
  766 
  767   # PROCTORING -  check for both user and proctor
  768   # we allow for two entries for proctor keys, one of the form
  769   #    userid,proctorid (which authorizes login), and the other
  770   #    of the form userid,proctorid,g (which authorizes grading)
  771   # (having two of these means that a proctored test will require
  772   #    authorization for both login and grading).
  773   if ($Key->user_id =~ /([^,]+)(?:,([^,]*))?(,g)?/) {
  774     my ($userID, $proctorID) = ($1, $2);
  775     croak "addKey: user $userID not found"
  776       unless $self->{user}->exists($userID);
  777     croak "addKey: proctor $proctorID not found"
  778       unless $self->{user}->exists($proctorID);
  779   } else {
  780     croak "addKey: user ", $Key->user_id, " not found"
  781       unless $self->{user}->exists($Key->user_id);
  782   }
  783 
  784   eval {
  785     return $self->{key}->add($Key);
  786   };
  787   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
  788     croak "addKey: key exists (perhaps you meant to use putKey?)";
  789   } elsif ($@) {
  790     die $@;
  791   }
  792 }
  793 
  794 sub putKey {
  795   # PROCTORING - allow comma in keyfields
  796   my ($self, $Key) = shift->checkArgs(\@_, qw/VREC:key/);
  797   my $rows = $self->{key}->put($Key); # DBI returns 0E0 for 0.
  798   if ($rows == 0) {
  799     croak "putKey: key not found (perhaps you meant to use addKey?)";
  800   } else {
  801     return $rows;
  802   }
  803 }
  804 
  805 sub deleteKey {
  806   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  807   return $self->{key}->delete($userID);
  808 }
  809 
  810 sub deleteAllProctorKeys {
  811   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
  812   my $where = [user_id_like => "$userID,%"];
  813 
  814   return $self->{key}->delete_where($where);
  815 }
  816 
  817 ################################################################################
  818 # setting functions
  819 ################################################################################
  820 
  821 BEGIN {
  822   *Setting = gen_schema_accessor("setting");
  823   *newSetting = gen_new("setting");
  824   *countSettingsWhere = gen_count_where("setting");
  825   *existsSettingWhere = gen_exists_where("setting");
  826   *listSettingsWhere = gen_list_where("setting");
  827   *getSettingsWhere = gen_get_records_where("setting");
  828   *addSettings = gen_insert_records("setting");
  829   *putSettings = gen_update_records("setting");
  830   *deleteSettingsWhere = gen_delete_where("setting");
  831 }
  832 
  833 # minimal set of routines for basic setting operation
  834 # we don't need a full set, since the usage of settings is somewhat limited
  835 # we also don't want to bother with records, since a setting is just a pair
  836 
  837 sub settingExists {
  838   my ($self, $name) = @_;
  839   return $self->{setting}->exists_where([name_eq=>$name]);
  840 }
  841 
  842 sub getSettingValue {
  843   my ($self, $name) = @_;
  844   return map { @$_ } $self->{setting}->get_fields_where(['value'], [name_eq=>$name]);
  845 }
  846 
  847 # we totally don't care if a setting already exists (and in fact i find that
  848 # whole distinction somewhat annoying lately) so we hide the fact that we're
  849 # either calling insert or update. at some point we could stand to add a
  850 # method to Std.pm that used REPLACE INTO and then we'd be able to not care
  851 # at all whether a setting was already there
  852 sub setSettingValue {
  853   my ($self, $name, $value) = @_;
  854   if ($self->settingExists($name)) {
  855     return $self->{setting}->update_where({value=>$value}, [name_eq=>$name]);
  856   } else {
  857     return $self->{setting}->insert_fields(['name','value'], [[$name,$value]]);
  858   }
  859 }
  860 
  861 sub deleteSetting {
  862   my ($self, $name) = shift->checkArgs(\@_, qw/name/);
  863   return $self->{setting}->delete_where([name_eq=>$name]);
  864 }
  865 
  866 ################################################################################
  867 # locations functions
  868 ################################################################################
  869 # this database table is for ip restrictions by assignment
  870 # the locations table defines names of locations consisting of
  871 #    lists of ip masks (found in the location_addresses table)
  872 #    to which assignments can be restricted to or denied from.
  873 
  874 BEGIN {
  875   *Location = gen_schema_accessor("locations");
  876   *newLocation = gen_new("locations");
  877   *countLocationsWhere = gen_count_where("locations");
  878   *existsLocationWhere = gen_exists_where("locations");
  879   *listLocationsWhere = gen_list_where("locations");
  880   *getLocationsWhere = gen_get_records_where("locations");
  881 }
  882 
  883 sub countLocations { return scalar shift->listLocations(@_) }
  884 
  885 sub listLocations {
  886   my ( $self ) = shift->checkArgs(\@_);
  887   if ( wantarray ) {
  888       return map {@$_} $self->{locations}->get_fields_where(["location_id"]);
  889   } else {
  890     return $self->{locations}->count_where;
  891   }
  892 }
  893 
  894 sub existsLocation {
  895   my ( $self, $locationID ) = shift->checkArgs(\@_, qw/location_id/);
  896   return $self->{locations}->exists($locationID);
  897 }
  898 
  899 sub getLocation {
  900   my ( $self, $locationID ) = shift->checkArgs(\@_, qw/location_id/);
  901   return ( $self->getLocations($locationID) )[0];
  902 }
  903 
  904 sub getLocations {
  905   my ( $self, @locationIDs ) = shift->checkArgs(\@_, qw/location_id*/);
  906   return $self->{locations}->gets(map {[$_]} @locationIDs);
  907 }
  908 
  909 sub getAllLocations {
  910   my ( $self ) = shift->checkArgs(\@_);
  911   return $self->{locations}->get_records_where();
  912 }
  913 
  914 sub addLocation {
  915   my ( $self, $Location ) = shift->checkArgs(\@_, qw/REC:locations/);
  916 
  917   eval {
  918     return $self->{locations}->add($Location);
  919   };
  920   if ( my $ex = caught WeBWorK::DB::Ex::RecordExists ) {
  921     croak "addLocation: location exists (perhaps you meant to use putLocation?)";
  922   } elsif ($@) {
  923     die $@;
  924   }
  925 }
  926 
  927 sub putLocation {
  928   my ($self, $Location) = shift->checkArgs(\@_, qw/REC:locations/);
  929   my $rows = $self->{locations}->put($Location);
  930   if ( $rows == 0 ) {
  931     croak "putLocation: location not found (perhaps you meant to use addLocation?)";
  932   } else {
  933     return $rows;
  934   }
  935 }
  936 
  937 sub deleteLocation {
  938   # do we need to allow calls from this package?  I can't think of
  939   #    any case where that would happen, but we include it for other
  940   #    deletions, so I'll keep it here.
  941   my $U = caller eq __PACKAGE__ ? "!" : "";
  942   my ( $self, $locationID ) = shift->checkArgs(\@_, "location_id$U");
  943   $self->deleteGlobalSetLocation(undef, $locationID);
  944   $self->deleteUserSetLocation(undef, undef, $locationID);
  945 
  946   # NOTE: the one piece of this that we don't address is if this
  947   #    results in all of the locations in a set's restriction being
  948   #    cleared; in this case, we should probably also reset the
  949   #    set->restrict_ip setting as well.  but that requires going
  950   #    out and doing a bunch of manipulations that well exceed what
  951   #    we want to do in this routine, so we'll assume that the user
  952   #    is smart enough to deal with that on her own.
  953 
  954   # addresses in the location_addresses table also need to be cleared
  955   $self->deleteLocationAddress($locationID, undef);
  956 
  957   return $self->{locations}->delete($locationID);
  958 }
  959 
  960 ################################################################################
  961 # location_addresses functions
  962 ################################################################################
  963 # this database table is for ip restrictions by assignment
  964 # the location_addresses table defines the ipmasks associate
  965 #    with the locations that are used for restrictions.
  966 
  967 BEGIN {
  968   *LocationAddress = gen_schema_accessor("location_addresses");
  969   *newLocationAddress = gen_new("location_addresses");
  970   *countLocationAddressesWhere = gen_count_where("location_addresses");
  971   *existsLocationAddressWhere = gen_exists_where("location_addresses");
  972   *listLocationAddressesWhere = gen_list_where("location_addresses");
  973   *getLocationAddressesWhere = gen_get_records_where("location_addresses");
  974 }
  975 
  976 sub countAddressLocations { return scalar shift->listAddressLocations(@_) }
  977 
  978 sub listAddressLocations {
  979   my ($self, $ipmask) = shift->checkArgs(\@_, qw/ip_mask/);
  980   my $where = [ip_mask_eq => $ipmask];
  981   if ( wantarray ) {
  982     return map {@$_} $self->{location_addresses}->get_fields_where(["location_id"],$where);
  983   } else {
  984     return $self->{location_addresses}->count_where($where);
  985   }
  986 }
  987 
  988 sub countLocationAddresses { return scalar shift->listLocationAddresses(@_) }
  989 
  990 sub listLocationAddresses {
  991   my ($self, $locationID) = shift->checkArgs(\@_, qw/location_id/);
  992   my $where = [location_id_eq => $locationID];
  993   if ( wantarray ) {
  994     return map {@$_} $self->{location_addresses}->get_fields_where(["ip_mask"],$where);
  995   } else {
  996     return $self->{location_addresses}->count_where($where);
  997   }
  998 }
  999 
 1000 sub existsLocationAddress {
 1001   my ($self, $locationID, $ipmask) = shift->checkArgs(\@_, qw/location_id ip_mask/);
 1002   return $self->{location_addresses}->exists($locationID, $ipmask);
 1003 }
 1004 
 1005 # we wouldn't ever getLocationAddress or getLocationAddresses; to use those
 1006 #   we would have to know all of the information that we're getting
 1007 
 1008 sub getAllLocationAddresses {
 1009   my ($self, $locationID) = shift->checkArgs(\@_, qw/location_id/);
 1010   my $where = [location_id_eq => $locationID];
 1011   return $self->{location_addresses}->get_records_where($where);
 1012 }
 1013 
 1014 sub addLocationAddress {
 1015   my ($self, $LocationAddress) = shift->checkArgs(\@_, qw/REC:location_addresses/);
 1016   croak "addLocationAddress: location ", $LocationAddress->location_id, " not found"
 1017     unless $self->{locations}->exists($LocationAddress->location_id);
 1018   eval {
 1019     return $self->{location_addresses}->add($LocationAddress);
 1020   };
 1021   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1022     croak "addLocationAddress: location address exists (perhaps you meant to use putLocationAddress?)";
 1023   } elsif ($@) {
 1024     die $@;
 1025   }
 1026 }
 1027 
 1028 sub putLocationAddress {
 1029   my ($self, $LocationAddress) = shift->checkArgs(\@_, qw/REC:location_addresses/);
 1030   my $rows = $self->{location_addresses}->put($LocationAddress);
 1031   if ( $rows == 0 ) {
 1032     croak "putLocationAddress: location address not found (perhaps you meant to use addLocationAddress?)";
 1033   } else {
 1034     return $rows;
 1035   }
 1036 }
 1037 
 1038 sub deleteLocationAddress {
 1039   # allow for undef values
 1040   my $U = caller eq __PACKAGE__ ? "!" : "";
 1041   my ($self, $locationID, $ipmask) = shift->checkArgs(\@_, "location_id$U", "ip_mask$U");
 1042   return $self->{location_addresses}->delete($locationID, $ipmask);
 1043 }
 1044 
 1045 
 1046 ################################################################################
 1047 # set functions
 1048 ################################################################################
 1049 
 1050 BEGIN {
 1051   *GlobalSet = gen_schema_accessor("set");
 1052   *newGlobalSet = gen_new("set");
 1053   *countGlobalSetsWhere = gen_count_where("set");
 1054   *existsGlobalSetWhere = gen_exists_where("set");
 1055   *listGlobalSetsWhere = gen_list_where("set");
 1056   *getGlobalSetsWhere = gen_get_records_where("set");
 1057 }
 1058 
 1059 sub countGlobalSets { return scalar shift->listGlobalSets(@_) }
 1060 
 1061 sub listGlobalSets {
 1062   my ($self) = shift->checkArgs(\@_);
 1063   if (wantarray) {
 1064     return map { @$_ } $self->{set}->get_fields_where(["set_id"]);
 1065   } else {
 1066     return $self->{set}->count_where;
 1067   }
 1068 }
 1069 
 1070 sub existsGlobalSet {
 1071   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1072   return $self->{set}->exists($setID);
 1073 }
 1074 
 1075 sub getGlobalSet {
 1076   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1077   return ( $self->getGlobalSets($setID) )[0];
 1078 }
 1079 
 1080 sub getGlobalSets {
 1081   my ($self, @setIDs) = shift->checkArgs(\@_, qw/set_id*/);
 1082   return $self->{set}->gets(map { [$_] } @setIDs);
 1083 }
 1084 
 1085 sub addGlobalSet {
 1086   my ($self, $GlobalSet) = shift->checkArgs(\@_, qw/REC:set/);
 1087 
 1088   eval {
 1089 
 1090     return $self->{set}->add($GlobalSet);
 1091   };
 1092   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1093     croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)";
 1094   } elsif ($@) {
 1095     die $@;
 1096   }
 1097 }
 1098 
 1099 sub putGlobalSet {
 1100   my ($self, $GlobalSet) = shift->checkArgs(\@_, qw/REC:set/);
 1101   my $rows = $self->{set}->put($GlobalSet); # DBI returns 0E0 for 0.
 1102   if ($rows == 0) {
 1103     croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)";
 1104   } else {
 1105     return $rows;
 1106   }
 1107 }
 1108 
 1109 sub deleteGlobalSet {
 1110   # setID can be undefined if being called from this package
 1111   my $U = caller eq __PACKAGE__ ? "!" : "";
 1112   my ($self, $setID) = shift->checkArgs(\@_, "set_id$U");
 1113   $self->deleteUserSet(undef, $setID);
 1114   $self->deleteGlobalProblem($setID, undef);
 1115   $self->deleteGlobalSetLocation($setID, undef);
 1116   return $self->{set}->delete($setID);
 1117 }
 1118 
 1119 ################################################################################
 1120 # set_user functions
 1121 ################################################################################
 1122 
 1123 BEGIN {
 1124   *UserSet = gen_schema_accessor("set_user");
 1125   *newUserSet = gen_new("set_user");
 1126   *countUserSetsWhere = gen_count_where("set_user");
 1127   *existsUserSetWhere = gen_exists_where("set_user");
 1128   *listUserSetsWhere = gen_list_where("set_user");
 1129   *getUserSetsWhere = gen_get_records_where("set_user");
 1130 }
 1131 
 1132 sub countSetUsers { return scalar shift->listSetUsers(@_) }
 1133 
 1134 sub listSetUsers {
 1135   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1136   my $where = [set_id_eq => $setID];
 1137   if (wantarray) {
 1138     return map { @$_ } $self->{set_user}->get_fields_where(["user_id"], $where);
 1139   } else {
 1140     return $self->{set_user}->count_where($where);
 1141   }
 1142 }
 1143 
 1144 sub countUserSets { return scalar shift->listUserSets(@_) }
 1145 
 1146 sub listUserSets {
 1147   my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/);
 1148   my $where = [user_id_eq => $userID];
 1149   if (wantarray) {
 1150     return map { @$_ } $self->{set_user}->get_fields_where(["set_id"], $where);
 1151   } else {
 1152     return $self->{set_user}->count_where($where);
 1153   }
 1154 }
 1155 
 1156 sub existsUserSet {
 1157   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1158   return $self->{set_user}->exists($userID, $setID);
 1159 }
 1160 
 1161 sub getUserSet {
 1162   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1163   return ( $self->getUserSets([$userID, $setID]) )[0];
 1164 }
 1165 
 1166 sub getUserSets {
 1167   my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id/);
 1168   return $self->{set_user}->gets(@userSetIDs);
 1169 }
 1170 
 1171 # the code from addUserSet() is duplicated in large part following in
 1172 # addVersionedUserSet; changes here should accordingly be propagated down there
 1173 sub addUserSet {
 1174   my ($self, $UserSet) = shift->checkArgs(\@_, qw/REC:set_user/);
 1175 
 1176   croak "addUserSet: user ", $UserSet->user_id, " not found"
 1177     unless $self->{user}->exists($UserSet->user_id);
 1178   croak "addUserSet: set ", $UserSet->set_id, " not found"
 1179     unless $self->{set}->exists($UserSet->set_id);
 1180 
 1181   eval {
 1182     return $self->{set_user}->add($UserSet);
 1183   };
 1184   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1185     croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)";
 1186   } elsif ($@) {
 1187     die $@;
 1188   }
 1189 }
 1190 
 1191 # the code from putUserSet() is duplicated in large part in the following
 1192 # putVersionedUserSet; c.f. that routine
 1193 sub putUserSet {
 1194   my ($self, $UserSet) = shift->checkArgs(\@_, qw/REC:set_user/);
 1195   my $rows = $self->{set_user}->put($UserSet); # DBI returns 0E0 for 0.
 1196   if ($rows == 0) {
 1197     croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)";
 1198   } else {
 1199     return $rows;
 1200   }
 1201 }
 1202 
 1203 sub deleteUserSet {
 1204   # userID and setID can be undefined if being called from this package
 1205   my $U = caller eq __PACKAGE__ ? "!" : "";
 1206   my ($self, $userID, $setID) = shift->checkArgs(\@_, "user_id$U", "set_id$U");
 1207   $self->deleteSetVersion($userID, $setID, undef);
 1208   $self->deleteUserProblem($userID, $setID, undef);
 1209   return $self->{set_user}->delete($userID, $setID);
 1210 }
 1211 
 1212 ################################################################################
 1213 # set_merged functions
 1214 ################################################################################
 1215 
 1216 BEGIN {
 1217   *MergedSet = gen_schema_accessor("set_merged");
 1218   #*newMergedSet = gen_new("set_merged");
 1219   #*countMergedSetsWhere = gen_count_where("set_merged");
 1220   *existsMergedSetWhere = gen_exists_where("set_merged");
 1221   #*listMergedSetsWhere = gen_list_where("set_merged");
 1222   *getMergedSetsWhere = gen_get_records_where("set_merged");
 1223 }
 1224 
 1225 sub existsMergedSet {
 1226   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1227   return $self->{set_merged}->exists($userID, $setID);
 1228 }
 1229 
 1230 sub getMergedSet {
 1231   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1232   return ( $self->getMergedSets([$userID, $setID]) )[0];
 1233 }
 1234 
 1235 sub getMergedSets {
 1236   my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id/);
 1237   return $self->{set_merged}->gets(@userSetIDs);
 1238 }
 1239 
 1240 ################################################################################
 1241 # set_version functions (NEW)
 1242 ################################################################################
 1243 
 1244 BEGIN {
 1245   *SetVersion = gen_schema_accessor("set_version");
 1246   *newSetVersion = gen_new("set_version");
 1247   *countSetVersionsWhere = gen_count_where("set_version");
 1248   *existsSetVersionWhere = gen_exists_where("set_version");
 1249   *listSetVersionsWhere = gen_list_where("set_version");
 1250   *getSetVersionsWhere = gen_get_records_where("set_version");
 1251 }
 1252 
 1253 # versioned analog of countUserSets
 1254 sub countSetVersions { return scalar shift->listSetVersions(@_) }
 1255 
 1256 # versioned analog of listUserSets
 1257 sub listSetVersions {
 1258   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1259   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1260   my $order = [ 'version_id' ];
 1261   if (wantarray) {
 1262     return map { @$_ } $self->{set_version}->get_fields_where(["version_id"], $where, $order);
 1263   } else {
 1264     return $self->{set_version}->count_where($where);
 1265   }
 1266 }
 1267 
 1268 # versioned analog of existsUserSet
 1269 sub existsSetVersion {
 1270   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1271   return $self->{set_version}->exists($userID, $setID, $versionID);
 1272 }
 1273 
 1274 # versioned analog of getUserSet
 1275 sub getSetVersion {
 1276   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1277   return ( $self->getSetVersions([$userID, $setID, $versionID]) )[0];
 1278 }
 1279 
 1280 # versioned analog of getUserSets
 1281 sub getSetVersions {
 1282   my ($self, @setVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id/);
 1283   return $self->{set_version}->gets(@setVersionIDs);
 1284 }
 1285 
 1286 # versioned analog of addUserSet
 1287 sub addSetVersion {
 1288   my ($self, $SetVersion) = shift->checkArgs(\@_, qw/REC:set_version/);
 1289 
 1290   croak "addSetVersion: set ", $SetVersion->set_id, " not found for user ", $SetVersion->user_id
 1291     unless $self->{set_user}->exists($SetVersion->user_id, $SetVersion->set_id);
 1292 
 1293   eval {
 1294     return $self->{set_version}->add($SetVersion);
 1295   };
 1296   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1297     croak "addSetVersion: set version exists (perhaps you meant to use putSetVersion?)";
 1298   } elsif ($@) {
 1299     die $@;
 1300   }
 1301 }
 1302 
 1303 # versioned analog of putUserSet
 1304 sub putSetVersion {
 1305   my ($self, $SetVersion) = shift->checkArgs(\@_, qw/REC:set_version/);
 1306   my $rows = $self->{set_version}->put($SetVersion); # DBI returns 0E0 for 0.
 1307   if ($rows == 0) {
 1308     croak "putSetVersion: set version not found (perhaps you meant to use addSetVersion?)";
 1309   } else {
 1310     return $rows;
 1311   }
 1312 }
 1313 
 1314 # versioned analog of deleteUserSet
 1315 sub deleteSetVersion {
 1316   # userID, setID, and versionID can be undefined if being called from this package
 1317   my $U = caller eq __PACKAGE__ ? "!" : "";
 1318   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "version_id$U");
 1319   $self->deleteProblemVersion($userID, $setID, $versionID, undef);
 1320   return $self->{set_version}->delete($userID, $setID, $versionID);
 1321 }
 1322 
 1323 ################################################################################
 1324 # set_version_merged functions (NEW)
 1325 ################################################################################
 1326 
 1327 BEGIN {
 1328   *MergedSetVersion = gen_schema_accessor("set_version_merged");
 1329   #*newMergedSetVersion = gen_new("set_version_merged");
 1330   #*countMergedSetVersionsWhere = gen_count_where("set_version_merged");
 1331   *existsMergedSetVersionWhere = gen_exists_where("set_version_merged");
 1332   #*listMergedSetVersionsWhere = gen_list_where("set_version_merged");
 1333   *getMergedSetVersionsWhere = gen_get_records_where("set_version_merged");
 1334 }
 1335 
 1336 sub existsMergedSetVersion {
 1337   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1338   return $self->{set_version_merged}->exists($userID, $setID, $versionID);
 1339 }
 1340 
 1341 sub getMergedSetVersion {
 1342   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1343   return ( $self->getMergedSetVersions([$userID, $setID, $versionID]) )[0];
 1344 }
 1345 
 1346 sub getMergedSetVersions {
 1347   my ($self, @setVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id/);
 1348   return $self->{set_version_merged}->gets(@setVersionIDs);
 1349 }
 1350 
 1351 ################################################################################
 1352 # set_locations functions
 1353 ################################################################################
 1354 # this database table is for ip restrictions by assignment
 1355 # the set_locations table defines the association between a
 1356 #    global set and the locations to which the set may be
 1357 #    restricted or denied.
 1358 
 1359 BEGIN {
 1360   *GlobalSetLocation = gen_schema_accessor("set_locations");
 1361   *newGlobalSetLocation = gen_new("set_locations");
 1362   *countGlobalSetLocationsWhere = gen_count_where("set_locations");
 1363   *existsGlobalSetLocationWhere = gen_exists_where("set_locations");
 1364   *listGlobalSetLocationsWhere = gen_list_where("set_locations");
 1365   *getGlobalSetLocationsWhere = gen_get_records_where("set_locations");
 1366 }
 1367 
 1368 sub countGlobalSetLocations { return scalar shift->listGlobalSetLocations(@_) }
 1369 
 1370 sub listGlobalSetLocations {
 1371   my ( $self, $setID ) = shift->checkArgs(\@_, qw/set_id/);
 1372   my $where = [set_id_eq => $setID];
 1373   if ( wantarray ) {
 1374     my $order = ['location_id'];
 1375     return map { @$_ } $self->{set_locations}->get_fields_where(["location_id"], $where, $order);
 1376   } else {
 1377     return $self->{set_user}->count_where( $where );
 1378   }
 1379 }
 1380 
 1381 sub existsGlobalSetLocation {
 1382   my ( $self, $setID, $locationID ) = shift->checkArgs(\@_, qw/set_id location_id/);
 1383   return $self->{set_locations}->exists( $setID, $locationID );
 1384 }
 1385 
 1386 sub getGlobalSetLocation {
 1387   my ( $self, $setID, $locationID ) = shift->checkArgs(\@_, qw/set_id location_id/);
 1388   return ( $self->getGlobalSetLocations([$setID, $locationID]) )[0];
 1389 }
 1390 
 1391 sub getGlobalSetLocations {
 1392   my ( $self, @locationIDs ) = shift->checkArgsRefList(\@_, qw/set_id location_id/);
 1393   return $self->{set_locations}->gets(@locationIDs);
 1394 }
 1395 
 1396 sub getAllGlobalSetLocations {
 1397   my ( $self, $setID ) = shift->checkArgs(\@_, qw/set_id/);
 1398   my $where = [set_id_eq => $setID];
 1399   return $self->{set_locations}->get_records_where( $where );
 1400 }
 1401 
 1402 sub addGlobalSetLocation {
 1403   my ( $self, $GlobalSetLocation ) = shift->checkArgs(\@_, qw/REC:set_locations/);
 1404   croak "addGlobalSetLocation: set ", $GlobalSetLocation->set_id, " not found"
 1405     unless $self->{set}->exists($GlobalSetLocation->set_id);
 1406 
 1407   eval {
 1408     return $self->{set_locations}->add($GlobalSetLocation);
 1409   };
 1410   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1411     croak "addGlobalSetLocation: global set_location exists (perhaps you meant to use putGlobalSetLocation?)";
 1412   } elsif ($@) {
 1413     die $@;
 1414   }
 1415 }
 1416 
 1417 sub putGlobalSetLocation {
 1418   my ($self, $GlobalSetLocation) = shift->checkArgs(\@_, qw/REC:set_locations/);
 1419   my $rows = $self->{set_locations}->put($GlobalSetLocation); # DBI returns 0E0 for 0.
 1420   if ($rows == 0) {
 1421     croak "putGlobalSetLocation: global problem not found (perhaps you meant to use addGlobalSetLocation?)";
 1422   } else {
 1423     return $rows;
 1424   }
 1425 }
 1426 
 1427 sub deleteGlobalSetLocation {
 1428   # setID and locationID can be undefined if being called from this package
 1429   my $U = caller eq __PACKAGE__ ? "!" : "";
 1430   my ($self, $setID, $locationID) = shift->checkArgs(\@_, "set_id$U", "location_id$U");
 1431   $self->deleteUserSetLocation(undef, $setID, $locationID);
 1432   return $self->{set_locations}->delete($setID, $locationID);
 1433 }
 1434 
 1435 ################################################################################
 1436 # set_locations_user functions
 1437 ################################################################################
 1438 # this database table is for ip restrictions by assignment
 1439 # the set_locations_user table defines the set_user level
 1440 #    modifications to the set_locations defined for the
 1441 #    global set
 1442 
 1443 BEGIN {
 1444   *UserSetLocation = gen_schema_accessor("set_locations_user");
 1445   *newUserSetLocation = gen_new("set_locations_user");
 1446   *countUserSetLocationWhere = gen_count_where("set_locations_user");
 1447   *existsUserSetLocationWhere = gen_exists_where("set_locations_user");
 1448   *listUserSetLocationsWhere = gen_list_where("set_locations_user");
 1449   *getUserSetLocationsWhere = gen_get_records_where("set_locations_user");
 1450 }
 1451 
 1452 sub countSetLocationUsers { return scalar shift->listSetLocationUsers(@_) }
 1453 
 1454 sub listSetLocationUsers {
 1455   my ($self, $setID, $locationID) = shift->checkArgs(\@_, qw/set_id location_id/);
 1456   my $where = [set_id_eq_location_id_eq => $setID,$locationID];
 1457   if (wantarray) {
 1458     return map { @$_ } $self->{set_locations_user}->get_fields_where(["user_id"], $where);
 1459   } else {
 1460     return $self->{set_locations_user}->count_where($where);
 1461   }
 1462 }
 1463 
 1464 sub countUserSetLocations { return scalar shift->listUserSetLocations(@_) }
 1465 
 1466 sub listUserSetLocations {
 1467   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1468   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1469   if (wantarray) {
 1470     return map { @$_ } $self->{set_locations_user}->get_fields_where(["location_id"], $where);
 1471   } else {
 1472     return $self->{set_locations_user}->count_where($where);
 1473   }
 1474 }
 1475 
 1476 sub existsUserSetLocation {
 1477   my ($self, $userID, $setID, $locationID) = shift->checkArgs(\@_, qw/user_id set_id location_id/);
 1478   return $self->{set_locations_user}->exists($userID,$setID,$locationID);
 1479 }
 1480 
 1481 # FIXME: we won't ever use this because all fields are key fields
 1482 sub getUserSetLocation {
 1483   my ($self, $userID, $setID, $locationID) = shift->checkArgs(\@_, qw/user_id set_id location_id/);
 1484   return( $self->getUserSetLocations([$userID, $setID, $locationID]) )[0];
 1485 }
 1486 
 1487 # FIXME: we won't ever use this because all fields are key fields
 1488 sub getUserSetLocations {
 1489   my ($self, @userSetLocationIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id location_id/);
 1490   return $self->{set_locations_user}->gets(@userSetLocationIDs);
 1491 }
 1492 
 1493 sub getAllUserSetLocations {
 1494   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1495   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1496   return $self->{set_locations_user}->get_records_where($where);
 1497 }
 1498 
 1499 sub addUserSetLocation {
 1500   # VERSIONING - accept versioned ID fields
 1501   my ($self, $UserSetLocation) = shift->checkArgs(\@_, qw/VREC:set_locations_user/);
 1502 
 1503   croak "addUserSetLocation: user set ", $UserSetLocation->set_id, " for user ", $UserSetLocation->user_id, " not found"
 1504     unless $self->{set_user}->exists($UserSetLocation->user_id, $UserSetLocation->set_id);
 1505 
 1506   eval {
 1507     return $self->{set_locations_user}->add($UserSetLocation);
 1508   };
 1509   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1510     croak "addUserSetLocation: user set_location exists (perhaps you meant to use putUserSetLocation?)";
 1511   } elsif ($@) {
 1512     die $@;
 1513   }
 1514 }
 1515 
 1516 # FIXME: we won't ever use this because all fields are key fields
 1517 # versioned_ok is an optional argument which lets us slip versioned setIDs through checkArgs.
 1518 sub putUserSetLocation {
 1519   my $V = $_[2] ? "V" : "";
 1520   my ($self, $UserSetLocation, undef) = shift->checkArgs(\@_, "${V}REC:set_locations_user", "versioned_ok!?");
 1521 
 1522   my $rows = $self->{set_locations_user}->put($UserSetLocation); # DBI returns 0E0 for 0.
 1523   if ($rows == 0) {
 1524     croak "putUserSetLocation: user set location not found (perhaps you meant to use addUserSetLocation?)";
 1525   } else {
 1526     return $rows;
 1527   }
 1528 }
 1529 
 1530 sub deleteUserSetLocation {
 1531   # userID, setID, and locationID can be undefined if being called from this package
 1532   my $U = caller eq __PACKAGE__ ? "!" : "";
 1533   my ($self, $userID, $setID, $locationID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "set_locations_id$U");
 1534   return $self->{set_locations_user}->delete($userID,$setID,$locationID);
 1535 }
 1536 
 1537 ################################################################################
 1538 # set_locations_merged functions
 1539 ################################################################################
 1540 # this is different from other set_merged functions, because
 1541 #    in this case the only data that we have are the set_id,
 1542 #    location_id, and user_id, and we want to replace all
 1543 #    locations from GlobalSetLocations with those from
 1544 #    UserSetLocations if the latter exist.
 1545 
 1546 sub getAllMergedSetLocations {
 1547   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1548 
 1549   if ( $self->countUserSetLocations($userID, $setID) ) {
 1550     return $self->getAllUserSetLocations( $userID, $setID );
 1551   } else {
 1552     return $self->getAllGlobalSetLocations( $setID );
 1553   }
 1554 }
 1555 
 1556 
 1557 ################################################################################
 1558 # problem functions
 1559 ################################################################################
 1560 
 1561 BEGIN {
 1562   *GlobalProblem = gen_schema_accessor("problem");
 1563   *newGlobalProblem = gen_new("problem");
 1564   *countGlobalProblemsWhere = gen_count_where("problem");
 1565   *existsGlobalProblemWhere = gen_exists_where("problem");
 1566   *listGlobalProblemsWhere = gen_list_where("problem");
 1567   *getGlobalProblemsWhere = gen_get_records_where("problem");
 1568 }
 1569 
 1570 sub countGlobalProblems { return scalar shift->listGlobalProblems(@_) }
 1571 
 1572 sub listGlobalProblems {
 1573   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1574   my $where = [set_id_eq => $setID];
 1575   if (wantarray) {
 1576     return map { @$_ } $self->{problem}->get_fields_where(["problem_id"], $where);
 1577   } else {
 1578     return $self->{problem}->count_where($where);
 1579   }
 1580 }
 1581 
 1582 sub existsGlobalProblem {
 1583   my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/);
 1584   return $self->{problem}->exists($setID, $problemID);
 1585 }
 1586 
 1587 sub getGlobalProblem {
 1588   my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/);
 1589   return ( $self->getGlobalProblems([$setID, $problemID]) )[0];
 1590 }
 1591 
 1592 sub getGlobalProblems {
 1593   my ($self, @problemIDs) = shift->checkArgsRefList(\@_, qw/set_id problem_id/);
 1594   return $self->{problem}->gets(@problemIDs);
 1595 }
 1596 
 1597 sub getAllGlobalProblems {
 1598   my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/);
 1599   my $where = [set_id_eq => $setID];
 1600   return $self->{problem}->get_records_where($where);
 1601 }
 1602 
 1603 sub addGlobalProblem {  my ($self, $GlobalProblem) = shift->checkArgs(\@_, qw/REC:problem/);
 1604 
 1605   croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1606     unless $self->{set}->exists($GlobalProblem->set_id);
 1607 
 1608   eval {
 1609     return $self->{problem}->add($GlobalProblem);
 1610   };
 1611   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1612     croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)";
 1613   } elsif ($@) {
 1614     die $@;
 1615   }
 1616 }
 1617 
 1618 sub putGlobalProblem {
 1619   my ($self, $GlobalProblem) = shift->checkArgs(\@_, qw/REC:problem/);
 1620   my $rows = $self->{problem}->put($GlobalProblem); # DBI returns 0E0 for 0.
 1621   if ($rows == 0) {
 1622     croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)";
 1623   } else {
 1624     return $rows;
 1625   }
 1626 }
 1627 
 1628 sub deleteGlobalProblem {
 1629   # userID and setID can be undefined if being called from this package
 1630   my $U = caller eq __PACKAGE__ ? "!" : "";
 1631   my ($self, $setID, $problemID) = shift->checkArgs(\@_, "set_id$U", "problem_id$U");
 1632   $self->deleteUserProblem(undef, $setID, $problemID);
 1633   return $self->{problem}->delete($setID, $problemID);
 1634 }
 1635 
 1636 ################################################################################
 1637 # problem_user functions
 1638 ################################################################################
 1639 
 1640 BEGIN {
 1641   *UserProblem = gen_schema_accessor("problem_user");
 1642   *newUserProblem = gen_new("problem_user");
 1643   *countUserProblemsWhere = gen_count_where("problem_user");
 1644   *existsUserProblemWhere = gen_exists_where("problem_user");
 1645   *listUserProblemsWhere = gen_list_where("problem_user");
 1646   *getUserProblemsWhere = gen_get_records_where("problem_user");
 1647 }
 1648 
 1649 sub countProblemUsers { return scalar shift->listProblemUsers(@_) }
 1650 
 1651 sub listProblemUsers {
 1652   my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/);
 1653   my $where = [set_id_eq_problem_id_eq => $setID,$problemID];
 1654   if (wantarray) {
 1655     return map { @$_ } $self->{problem_user}->get_fields_where(["user_id"], $where);
 1656   } else {
 1657     return $self->{problem_user}->count_where($where);
 1658   }
 1659 }
 1660 
 1661 sub countUserProblems { return scalar shift->listUserProblems(@_) }
 1662 
 1663 sub listUserProblems {
 1664   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1665   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1666   if (wantarray) {
 1667     return map { @$_ } $self->{problem_user}->get_fields_where(["problem_id"], $where);
 1668   } else {
 1669     return $self->{problem_user}->count_where($where);
 1670   }
 1671 }
 1672 
 1673 sub existsUserProblem {
 1674   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1675   return $self->{problem_user}->exists($userID, $setID, $problemID);
 1676 }
 1677 
 1678 sub getUserProblem {
 1679   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1680   return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0];
 1681 }
 1682 
 1683 sub getUserProblems {
 1684   my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id problem_id/);
 1685   return $self->{problem_user}->gets(@userProblemIDs);
 1686 }
 1687 
 1688 sub getAllUserProblems {
 1689   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1690   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1691   return $self->{problem_user}->get_records_where($where);
 1692 }
 1693 
 1694 sub addUserProblem {
 1695   # VERSIONING - accept versioned ID fields
 1696   my ($self, $UserProblem) = shift->checkArgs(\@_, qw/VREC:problem_user/);
 1697 
 1698   croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1699     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1700 
 1701   my ( $nv_set_id, $versionNum ) = grok_vsetID( $UserProblem->set_id );
 1702 
 1703   croak "addUserProblem: problem ", $UserProblem->problem_id, " in set $nv_set_id not found"
 1704     unless $self->{problem}->exists($nv_set_id, $UserProblem->problem_id);
 1705 
 1706   eval {
 1707     return $self->{problem_user}->add($UserProblem);
 1708   };
 1709   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1710     croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)";
 1711   } elsif ($@) {
 1712     die $@;
 1713   }
 1714 }
 1715 
 1716 # versioned_ok is an optional argument which lets us slip versioned setIDs through checkArgs.
 1717 sub putUserProblem {
 1718   my $V = $_[2] ? "V" : "";
 1719   my ($self, $UserProblem, undef) = shift->checkArgs(\@_, "${V}REC:problem_user", "versioned_ok!?");
 1720 
 1721   my $rows = $self->{problem_user}->put($UserProblem); # DBI returns 0E0 for 0.
 1722   if ($rows == 0) {
 1723     croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)";
 1724   } else {
 1725     return $rows;
 1726   }
 1727 }
 1728 
 1729 sub deleteUserProblem {
 1730   # userID, setID, and problemID can be undefined if being called from this package
 1731   my $U = caller eq __PACKAGE__ ? "!" : "";
 1732   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "problem_id$U");
 1733   return $self->{problem_user}->delete($userID, $setID, $problemID);
 1734 }
 1735 
 1736 ################################################################################
 1737 # problem_merged functions
 1738 ################################################################################
 1739 
 1740 BEGIN {
 1741   *MergedProblem = gen_schema_accessor("problem_merged");
 1742   #*newMergedProblem = gen_new("problem_merged");
 1743   #*countMergedProblemsWhere = gen_count_where("problem_merged");
 1744   *existsMergedProblemWhere = gen_exists_where("problem_merged");
 1745   #*listMergedProblemsWhere = gen_list_where("problem_merged");
 1746   *getMergedProblemsWhere = gen_get_records_where("problem_merged");
 1747 }
 1748 
 1749 sub existsMergedProblem {
 1750   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1751   return $self->{problem_merged}->exists($userID, $setID, $problemID);
 1752 }
 1753 
 1754 sub getMergedProblem {
 1755   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1756   return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0];
 1757 }
 1758 
 1759 sub getMergedProblems {
 1760   my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id problem_id/);
 1761   return $self->{problem_merged}->gets(@userProblemIDs);
 1762 }
 1763 
 1764 sub getAllMergedUserProblems {
 1765   my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/);
 1766   my $where = [user_id_eq_set_id_eq => $userID,$setID];
 1767   return $self->{problem_merged}->get_records_where($where);
 1768 }
 1769 
 1770 ################################################################################
 1771 # problem_version functions (NEW)
 1772 ################################################################################
 1773 
 1774 BEGIN {
 1775   *ProblemVersion = gen_schema_accessor("problem_version");
 1776   *newProblemVersion = gen_new("problem_version");
 1777   *countProblemVersionsWhere = gen_count_where("problem_version");
 1778   *existsProblemVersionWhere = gen_exists_where("problem_version");
 1779   *listProblemVersionsWhere = gen_list_where("problem_version");
 1780   *getProblemVersionsWhere = gen_get_records_where("problem_version");
 1781 }
 1782 
 1783 # versioned analog of countUserProblems
 1784 sub countProblemVersions { return scalar shift->listProblemVersions(@_) }
 1785 
 1786 # versioned analog of listUserProblems
 1787 sub listProblemVersions {
 1788   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1789   my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID];
 1790   if (wantarray) {
 1791     return map { @$_ } $self->{problem_version}->get_fields_where(["problem_id"], $where);
 1792   } else {
 1793     return $self->{problem_version}->count_where($where);
 1794   }
 1795 }
 1796 
 1797 # this code returns a list of all problem versions with the given userID,
 1798 # setID, and problemID, but that is (darn well ought to be) the same as
 1799 # listSetVersions, so it's not so useful as all that; c.f. above.
 1800 # sub listProblemVersions {
 1801 #   my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/);
 1802 #   my $where = [user_id_eq_set_id_eq_problem_id_eq => $userID,$setID,$problemID];
 1803 #   if (wantarray) {
 1804 #     return grep { @$_ } $self->{problem_version}->get_fields_where(["version_id"], $where);
 1805 #   } else {
 1806 #     return $self->{problem_version}->count_where($where);
 1807 #   }
 1808 # }
 1809 
 1810 # versioned analog of existsUserProblem
 1811 sub existsProblemVersion {
 1812   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1813   return $self->{problem_version}->exists($userID, $setID, $versionID, $problemID);
 1814 }
 1815 
 1816 # versioned analog of getUserProblem
 1817 sub getProblemVersion {
 1818   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1819   return ( $self->getProblemVersions([$userID, $setID, $versionID, $problemID]) )[0];
 1820 }
 1821 
 1822 # versioned analog of getUserProblems
 1823 sub getProblemVersions {
 1824   my ($self, @problemVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id problem_id/);
 1825   return $self->{problem_version}->gets(@problemVersionIDs);
 1826 }
 1827 
 1828 # versioned analog of getAllUserProblems
 1829 sub getAllProblemVersions {
 1830   my ( $self, $userID, $setID, $versionID ) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1831   my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID];
 1832   my $order = ["problem_id"];
 1833   return $self->{problem_version_merged}->get_records_where($where,$order);
 1834 }
 1835 
 1836 
 1837 # versioned analog of addUserProblem
 1838 sub addProblemVersion {
 1839   my ($self, $ProblemVersion) = shift->checkArgs(\@_, qw/REC:problem_version/);
 1840 
 1841   croak "addProblemVersion: set version ", $ProblemVersion->version_id, " of set ", $ProblemVersion->set_id, " not found for user ", $ProblemVersion->user_id
 1842     unless $self->{set_version}->exists($ProblemVersion->user_id, $ProblemVersion->set_id, $ProblemVersion->version_id);
 1843   croak "addProblemVersion: problem ", $ProblemVersion->problem_id, " of set ", $ProblemVersion->set_id, " not found for user ", $ProblemVersion->user_id
 1844     unless $self->{problem_user}->exists($ProblemVersion->user_id, $ProblemVersion->set_id, $ProblemVersion->problem_id);
 1845 
 1846   eval {
 1847     return $self->{problem_version}->add($ProblemVersion);
 1848   };
 1849   if (my $ex = caught WeBWorK::DB::Ex::RecordExists) {
 1850     croak "addProblemVersion: problem version exists (perhaps you meant to use putProblemVersion?)";
 1851   } elsif ($@) {
 1852     die $@;
 1853   }
 1854 }
 1855 
 1856 # versioned analog of putUserProblem
 1857 sub putProblemVersion {
 1858   my ($self, $ProblemVersion) = shift->checkArgs(\@_, qw/REC:problem_version/);
 1859   my $rows = $self->{problem_version}->put($ProblemVersion); # DBI returns 0E0 for 0.
 1860   if ($rows == 0) {
 1861     croak "putProblemVersion: problem version not found (perhaps you meant to use addProblemVersion?)";
 1862   } else {
 1863     return $rows;
 1864   }
 1865 }
 1866 
 1867 # versioned analog of deleteUserProblem
 1868 sub deleteProblemVersion {
 1869   # userID, setID, versionID, and problemID can be undefined if being called from this package
 1870   my $U = caller eq __PACKAGE__ ? "!" : "";
 1871   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "version_id$U", "problem_id$U");
 1872   return $self->{problem_version}->delete($userID, $setID, $versionID, $problemID);
 1873 }
 1874 
 1875 ################################################################################
 1876 # problem_version_merged functions (NEW)
 1877 ################################################################################
 1878 
 1879 BEGIN {
 1880   *MergedProblemVersion = gen_schema_accessor("problem_version_merged");
 1881   #*newMergedProblemVersion = gen_new("problem_version_merged");
 1882   #*countMergedProblemVersionsWhere = gen_count_where("problem_version_merged");
 1883   *existsMergedProblemVersionWhere = gen_exists_where("problem_version_merged");
 1884   #*listMergedProblemVersionsWhere = gen_list_where("problem_version_merged");
 1885   *getMergedProblemVersionsWhere = gen_get_records_where("problem_version_merged");
 1886 }
 1887 
 1888 sub existsMergedProblemVersion {
 1889   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1890   return $self->{problem_version_merged}->exists($userID, $setID, $versionID, $problemID);
 1891 }
 1892 
 1893 sub getMergedProblemVersion {
 1894   my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/);
 1895   return ( $self->getMergedProblemVersions([$userID, $setID, $versionID, $problemID]) )[0];
 1896 }
 1897 
 1898 sub getMergedProblemVersions {
 1899   my ($self, @problemVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id problem_id/);
 1900   return $self->{problem_version_merged}->gets(@problemVersionIDs);
 1901 }
 1902 
 1903 sub getAllMergedProblemVersions {
 1904   my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/);
 1905   my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID];
 1906   my $order = ["problem_id"];
 1907   return $self->{problem_version_merged}->get_records_where($where,$order);
 1908 }
 1909 
 1910 ################################################################################
 1911 # utilities
 1912 ################################################################################
 1913 
 1914 sub check_user_id { #  (valid characters are [-a-zA-Z0-9_.,])
 1915   my $value = shift;
 1916   if ($value =~ m/^[-a-zA-Z0-9_.]*,?(set_id:)?[-a-zA-Z0-9_.]*(,g)?$/ ) {
 1917     return 1;
 1918   } else {
 1919     croak "invalid characters in user_id field: '$value' (valid characters are [-a-zA-Z0-9_.,])";
 1920     return 0;
 1921   }
 1922 }
 1923 # the (optional) second argument to checkKeyfields is to support versioned
 1924 # (gateway) sets, which may include commas in certain fields (in particular,
 1925 # set names (e.g., setDerivativeGateway,v1) and user names (e.g.,
 1926 # username,proctorname)
 1927 
 1928 sub checkKeyfields($;$) {
 1929   my ($Record, $versioned) = @_;
 1930   foreach my $keyfield ($Record->KEYFIELDS) {
 1931     my $value = $Record->$keyfield;
 1932 
 1933     croak "undefined '$keyfield' field"
 1934       unless defined $value;
 1935     croak "empty '$keyfield' field"
 1936       unless $value ne "";
 1937 
 1938     if ($keyfield eq "problem_id") {
 1939       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [0-9])"
 1940         unless $value =~ m/^[0-9]*$/;
 1941     } elsif ($versioned and $keyfield eq "set_id") {
 1942       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-zA-Z0-9_.,])"
 1943         unless $value =~ m/^[-a-zA-Z0-9_.,]*$/;
 1944     # } elsif ($versioned and $keyfield eq "user_id") {
 1945     } elsif ($keyfield eq "user_id") {
 1946       check_user_id($value); #  (valid characters are [-a-zA-Z0-9_.,]) see above.
 1947     } elsif ($keyfield eq "ip_mask") {
 1948       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-fA-F0-9_.:/])"
 1949         unless $value =~ m/^[-a-fA-F0-9_.:\/]*$/;
 1950 
 1951     } else {
 1952       croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-zA-Z0-9_.])"
 1953         unless $value =~ m/^[-a-zA-Z0-9_.]*$/;
 1954     }
 1955   }
 1956 }
 1957 
 1958 
 1959 # checkArgs spec syntax:
 1960 #
 1961 # spec = list_item | item*
 1962 # list_item = item is_list
 1963 # is_list = "*"
 1964 # item = item_name undef_ok? optional?
 1965 # item_name = record_item | bare_item
 1966 # record_item = is_versioned? "REC:" table
 1967 # is_versioned = "V"
 1968 # table = \w+
 1969 # bare_item = \w+
 1970 # undef_ok = "!"
 1971 # optional = "?"
 1972 #
 1973 # [[V]REC:]foo[!][?][*]
 1974 
 1975 sub checkArgs {
 1976   my ($self, $args, @spec) = @_;
 1977 
 1978   my $is_list = @spec == 1 && $spec[0] =~ s/\*$//;
 1979   my ($min_args, $max_args);
 1980   if ($is_list) {
 1981     $min_args = 0;
 1982   } else {
 1983     foreach my $i (0..$#spec) {
 1984       #print "$i - $spec[$i]\n";
 1985       if ($spec[$i] =~ s/\?$//) {
 1986         #print "$i - matched\n";
 1987         $min_args = $i unless defined $min_args;
 1988       }
 1989     }
 1990     $min_args = @spec unless defined $min_args;
 1991     $max_args = @spec;
 1992   }
 1993 
 1994   if (@$args < $min_args or defined $max_args and @$args > $max_args) {
 1995     if ($min_args == $max_args) {
 1996       my $s = $min_args == 1 ? "" : "s";
 1997       croak "requires $min_args argument$s";
 1998     } elsif (defined $max_args) {
 1999       croak "requires between $min_args and $max_args arguments";
 2000     } else {
 2001       my $s = $min_args == 1 ? "" : "s";
 2002       croak "requires at least $min_args argument$s";
 2003     }
 2004   }
 2005 
 2006   my ($name, $versioned, $table);
 2007   if ($is_list) {
 2008     $name = $spec[0];
 2009     ($versioned, $table) = $name =~ /^(V?)REC:(.*)/;
 2010   }
 2011 
 2012   foreach my $i (0..@$args-1) {
 2013     my $arg = $args->[$i];
 2014     my $pos = $i+1;
 2015 
 2016     unless ($is_list) {
 2017       $name = $spec[$i];
 2018       ($versioned, $table) = $name =~ /^(V?)REC:(.*)/;
 2019     }
 2020 
 2021     if (defined $table) {
 2022       my $class = $self->{$table}{record};
 2023       #print "arg=$arg class=$class\n";
 2024       croak "argument $pos must be of type $class"
 2025         unless defined $arg and ref $arg and $arg->isa($class);
 2026       eval { checkKeyfields($arg, $versioned) };
 2027       croak "argument $pos contains $@" if $@;
 2028     } else {
 2029       if ($name !~ /!$/) {
 2030         croak "argument $pos must contain a $name"
 2031           unless defined $arg;
 2032       }
 2033     }
 2034   }
 2035 
 2036   return $self, @$args;
 2037 }
 2038 
 2039 sub checkArgsRefList {
 2040   my ($self, $items, @spec) = @_;
 2041   foreach my $i (0..@$items-1) {
 2042     my $item = $items->[$i];
 2043     my $pos = $i+1;
 2044     croak "item $pos must be a reference to an array"
 2045       unless UNIVERSAL::isa($item, "ARRAY");
 2046     eval { $self->checkArgs($item, @spec) };
 2047     croak "item $pos $@" if $@;
 2048   }
 2049 
 2050   return $self, @$items;
 2051 }
 2052 
 2053 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9