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

View of /branches/wheeler/webwork2/lib/WeBWorK/DB.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7141 - (download) (as text) (annotate)
Tue May 29 19:04:03 2012 UTC (7 years, 8 months ago) by wheeler
File size: 69627 byte(s)
Support for LTI 1.0 authentication from a Course Management System

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9