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

    1 ################################################################################
    2 # WeBWorK Online Homework Delivery System
    3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
    4 # $CVSHeader: webwork-modperl/lib/WeBWorK/DB.pm,v 1.48 2004/06/14 22:58:55 sh002i Exp $
    5 #
    6 # This program is free software; you can redistribute it and/or modify it under
    7 # the terms of either: (a) the GNU General Public License as published by the
    8 # Free Software Foundation; either version 2, or (at your option) any later
    9 # version, or (b) the "Artistic License" which comes with this package.
   10 #
   11 # This program is distributed in the hope that it will be useful, but WITHOUT
   12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
   13 # FOR A PARTICULAR PURPOSE.  See either the GNU General Public License or the
   14 # Artistic License for more details.
   15 ################################################################################
   16 
   17 package WeBWorK::DB;
   18 
   19 =head1 NAME
   20 
   21 WeBWorK::DB - interface with the WeBWorK databases.
   22 
   23 =head1 SYNOPSIS
   24 
   25  my $db = WeBWorK::DB->new($dbLayout);
   26 
   27  my @userIDs = $db->listUsers();
   28  my $Sam = $db->{user}->{record}->new();
   29 
   30  $Sam->user_id("sammy");
   31  $Sam->first_name("Sam");
   32  $Sam->last_name("Hathaway");
   33  # etc.
   34 
   35  $db->addUser($User);
   36  my $Dennis = $db->getUser("dennis");
   37  $Dennis->status("C");
   38  $db->putUser->($Dennis);
   39 
   40  $db->deleteUser("sammy");
   41 
   42 =head1 DESCRIPTION
   43 
   44 WeBWorK::DB provides a consistent interface to a number of database backends.
   45 Access and modification functions are provided for each logical table used by
   46 the webwork system. The particular backend ("schema" and "driver"), record
   47 class, data source, and additional parameters are specified by the hash
   48 referenced by C<$dbLayout>, usually taken from the course environment.
   49 
   50 =head1 ARCHITECTURE
   51 
   52 The new database system uses a three-tier architecture to insulate each layer
   53 from the adjacent layers.
   54 
   55 =head2 Top Layer: DB
   56 
   57 The top layer of the architecture is the DB module. It provides the methods
   58 listed below, and uses schema modules (via tables) to implement those methods.
   59 
   60          / new* list* exists* add* get* get*s put* delete* \          <- api
   61  +------------------------------------------------------------------+
   62  |                                DB                                |
   63  +------------------------------------------------------------------+
   64   \ password permission key user set set_user problem problem_user /  <- tables
   65 
   66 =head2 Middle Layer: Schemas
   67 
   68 The middle layer of the architecture is provided by one or more schema modules.
   69 They are called "schema" modules because they control the structure of the data
   70 for a table. This includes odd things like the way multiple tables are encoded
   71 in a single hash in the WW1Hash schema, and the encoding scheme used.
   72 
   73 The schema modules provide an API that matches the requirements of the DB
   74 layer, on a per-table basis. Each schema module has a style that determines
   75 which drivers it can interface with. For example, WW1Hash is a "hash" style
   76 schema. SQL is a "dbi" style schema.
   77 
   78 =head3 Examples
   79 
   80 Both WeBWorK 1.x and 2.x courses use:
   81 
   82   / password  permission  key \        / user \      <- tables provided
   83  +-----------------------------+  +----------------+
   84  |          Auth1Hash          |  | Classlist1Hash |
   85  +-----------------------------+  +----------------+
   86              \ hash /                  \ hash /      <- driver style required
   87 
   88 WeBWorK 1.x courses also use:
   89 
   90   / set_user problem_user \       / set problem \
   91  +-------------------------+  +---------------------+
   92  |         WW1Hash         |  | GlobalTableEmulator |
   93  +-------------------------+  +---------------------+
   94            \ hash /                   \ null /
   95 
   96 The GlobalTableEmulator schema emulates the global set and problem tables using
   97 data from the set_user and problem_user tables.
   98 
   99 WeBWorK 2.x courses also use:
  100 
  101   / set set_user problem problem_user \
  102  +-------------------------------------+
  103  |               WW2Hash               |
  104  +-------------------------------------+
  105                  \ hash /
  106 
  107 =head2 Bottom Layer: Drivers
  108 
  109 Driver modules implement a style for a schema. They provide physical access to
  110 a data source containing the data for a table. The style of a driver determines
  111 what methods it provides. All drivers provide C<connect(MODE)> and
  112 C<disconnect()> methods. A hash style driver provides a C<hash()> method which
  113 returns the tied hash. A dbi style driver provides a C<handle()> method which
  114 returns the DBI handle.
  115 
  116 =head3 Examples
  117 
  118   / hash \    / hash \    / hash \  <- style
  119  +--------+  +--------+  +--------+
  120  |   DB   |  |  GDBM  |  |   DB3  |
  121  +--------+  +--------+  +--------+
  122 
  123   / dbi \    / ldap \
  124  +-------+  +--------+
  125  |  SQL  |  |  LDAP  |
  126  +-------+  +--------+
  127 
  128 =head2 Record Types
  129 
  130 In C<%dblayout>, each table is assigned a record class, used for passing
  131 complete records to and from the database. The default record classes are
  132 subclasses of the WeBWorK::DB::Record class, and are named as follows: User,
  133 Password, PermissionLevel, Key, Set, UserSet, Problem, UserProblem. In the
  134 following documentation, a reference the the record class for a table means the
  135 record class currently defined for that table in C<%dbLayout>.
  136 
  137 =cut
  138 
  139 use strict;
  140 use warnings;
  141 use Carp;
  142 use Data::Dumper;
  143 use WeBWorK::Timing;
  144 use WeBWorK::Utils qw(runtime_use);
  145 
  146 ################################################################################
  147 # constructor
  148 ################################################################################
  149 
  150 =head1 CONSTRUCTOR
  151 
  152 =over
  153 
  154 =item new($ce)
  155 
  156 The C<new> method creates a DB object and brings up the underlying
  157 schema/driver structure according to the C<%dbLayout> hash in C<$ce>, a
  158 WeBWorK::CourseEnvironment object.
  159 
  160 =back
  161 
  162 =head2 C<$dbLayout> Format
  163 
  164 C<$dbLayout> is a hash reference consisting of items keyed by table names. The
  165 value of each item is a reference to a hash containing the following items:
  166 
  167 =over
  168 
  169 =item record
  170 
  171 The name of a perl module to use for representing the data in a record.
  172 
  173 =item schema
  174 
  175 The name of a perl module to use for access to the table.
  176 
  177 =item driver
  178 
  179 The name of a perl module to use for access to the data source.
  180 
  181 =item source
  182 
  183 The location of the data source that should be used by the driver module.
  184 Depending on the driver, this may be a path, a url, or a DBI spec.
  185 
  186 =item params
  187 
  188 A reference to a hash containing extra information needed by the schema. Some
  189 schemas require parameters, some do not. Consult the documentation for the
  190 schema in question.
  191 
  192 =back
  193 
  194 For each table defined in C<$dbLayout>, C<new> loads the record, schema, and
  195 driver modules. It the schema module's C<tables> method lists the current table
  196 (or contains the string "*") and the output of the schema and driver modules'
  197 C<style> methods match, the table is installed. Otherwise, an exception is
  198 thrown.
  199 
  200 =cut
  201 
  202 sub new($$) {
  203   my ($invocant, $dbLayout) = @_;
  204   my $class = ref($invocant) || $invocant;
  205   my $self = {};
  206   bless $self, $class; # bless this here so we can pass it to the schema
  207 
  208   # load the modules required to handle each table, and create driver
  209   my %dbLayout = %$dbLayout;
  210   foreach my $table (keys %dbLayout) {
  211     my $layout = $dbLayout{$table};
  212     my $record = $layout->{record};
  213     my $schema = $layout->{schema};
  214     my $driver = $layout->{driver};
  215     my $source = $layout->{source};
  216     my $params = $layout->{params};
  217 
  218     runtime_use($record);
  219 
  220     runtime_use($driver);
  221     my $driverObject = eval { $driver->new($source, $params) };
  222     croak "error instantiating DB driver $driver for table $table: $@"
  223       if $@;
  224 
  225     runtime_use($schema);
  226     my $schemaObject = eval { $schema->new(
  227       $self, $driverObject, $table, $record, $params) };
  228     croak "error instantiating DB schema $schema for table $table: $@"
  229       if $@;
  230 
  231     $self->{$table} = $schemaObject;
  232   }
  233 
  234   return $self;
  235 }
  236 
  237 =head1 METHODS
  238 
  239 =cut
  240 
  241 ################################################################################
  242 # general functions
  243 ################################################################################
  244 
  245 =head2 General Methods
  246 
  247 =over
  248 
  249 =cut
  250 
  251 =item hashDatabaseOK($fix)
  252 
  253 If the schema module in use for the C<set> and C<problem> tables is
  254 WeBWorK::DB::Schema::GlobalTableEmulator, the database is checked to make sure
  255 that the "global user" exists and all sets and problems are assigned to it. If
  256 $fix is true, problems found will be fixed: A global user will be created and
  257 all sets/problems assigned to it.
  258 
  259 A list of values is returned. The first value is a boolean value indicating
  260 whether problems remain in the database after hashDatabaseOK() is called. The
  261 remaining values are a list of strings indicating the particular ways in which
  262 the database is (or was) broken.
  263 
  264 =cut
  265 
  266 sub hashDatabaseOK {
  267   my ($self, $fix) = @_;
  268 
  269   my $errorsExist;
  270   my @results;
  271 
  272   ##### do we need to run? #####
  273 
  274   unless (ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
  275     #warn "hashDatabaseOK($fix): no checks necessary, set table does not use GlobalTableEmulator.\n";
  276     return 1;
  277   }
  278 
  279   ##### is globalUserID defined? #####
  280 
  281   my $globalUserID = $self->{set}->{params}->{globalUserID};
  282   if ($globalUserID eq "") {
  283     return 0, "globalUserID not specified (fix this in %dbLayout.)";
  284   } else {
  285     #warn "hashDatabaseOK($fix): globalUserID not empty ($globalUserID) -- good.\n";
  286   }
  287 
  288   ##### does a user with ID globalUserID exist? #####
  289 
  290   my $GlobalUser = $self->getUser($globalUserID);
  291   if (defined $GlobalUser) {
  292     #warn "hashDatabaseOK($fix): user with ID '$globalUserID' exists -- good.\n";
  293   } else {
  294     #warn "hashDatabaseOK($fix): user with ID '$globalUserID' not found -- bad!\n";
  295     if ($fix) {
  296       $self->addUser($self->newUser(
  297         user_id => $globalUserID,
  298         first_name => "Global",
  299         last_name => "User",
  300         email_address => "",
  301         student_id => $globalUserID,
  302         status => "D",
  303         section => "",
  304         recitation => "",
  305         comment => "This user is used to store data about global set and problem records when using a hash-style database.",
  306       ));
  307       push @results, "User $globalUserID does not exist -- FIXED.";
  308       #warn "hashDatabaseOK($fix): created user with ID '$globalUserID' -- good.\n";
  309     } else {
  310       # at this point, we don't go on. no global user means everything below is going to fail.
  311       return 0, "User $globalUserID does not exist.";
  312     }
  313   }
  314 
  315   ##### are all sets assigned to the user with ID globalUserID? #####
  316 
  317   my @userSetIDs = $self->{set_user}->list(undef, undef);
  318 
  319   my %userSetStatus;
  320   foreach my $userSetID (@userSetIDs) {
  321     my ($userID, $setID) = @$userSetID;
  322     $userSetStatus{$setID}->{$userID} = 1;
  323   }
  324 
  325   foreach my $setID (keys %userSetStatus) {
  326     delete $userSetStatus{$setID}
  327       if exists $userSetStatus{$setID}->{$globalUserID};
  328   }
  329 
  330   if (keys %userSetStatus) {
  331     if ($fix) {
  332       foreach my $setID (keys %userSetStatus) {
  333         my $userID = ( keys %{$userSetStatus{$setID}} )[0];
  334 
  335         # grab the first UserSet of this set (connect and disconnect required for get1*)
  336         $self->{set_user}->{driver}->connect("ro");
  337         my $RawUserSet = $self->{set_user}->get1NoFilter($userID, $setID);
  338         $self->{set_user}->{driver}->disconnect();
  339 
  340         # change user ID to globalUserID and add to database
  341         $RawUserSet->user_id($globalUserID);
  342         $self->{set_user}->add($RawUserSet);
  343 
  344         push @results, "Set '$setID' not assigned to global user '$globalUserID' -- FIXED.";
  345 
  346         #warn "hashDatabaseOK($fix): assigned set '$setID' to global user '$globalUserID' -- good.\n";
  347       }
  348     } else {
  349       foreach my $setID (keys %userSetStatus) {
  350         #warn "hashDatabaseOK($fix): set '$setID' not assigned to global user '$globalUserID' -- bad!\n";
  351         push @results, "Set '$setID' not assigned to global user '$globalUserID'.";
  352       }
  353       $errorsExist = 1;
  354     }
  355   } else {
  356     #warn "hashDatabaseOK($fix): all sets assigned to global user '$globalUserID' -- good.\n";
  357   }
  358 
  359   ##### done! #####
  360 
  361   my $status = not $errorsExist;
  362   return $status, @results;
  363 }
  364 
  365 =back
  366 
  367 =cut
  368 
  369 ################################################################################
  370 # password functions
  371 ################################################################################
  372 
  373 =head2 Password Methods
  374 
  375 =over
  376 
  377 =item newPassword()
  378 
  379 Returns a new, empty password object.
  380 
  381 =cut
  382 
  383 sub newPassword {
  384   my ($self, @prototype) = @_;
  385   return $self->{password}->{record}->new(@prototype);
  386 }
  387 
  388 =item listPasswords()
  389 
  390 Returns a list of user IDs representing the records in the password table.
  391 
  392 =cut
  393 
  394 sub listPasswords {
  395   my ($self) = @_;
  396 
  397   croak "listPasswords: requires 0 arguments"
  398     unless @_ == 1;
  399 
  400   return map { $_->[0] }
  401     $self->{password}->list(undef);
  402 }
  403 
  404 =item addPassword($Password)
  405 
  406 $Password is a record object. The password will be added to the password table
  407 if a password with the same user ID does not already exist. If one does exist,
  408 an exception is thrown. To add a password, a user with a matching user ID must
  409 exist in the user table.
  410 
  411 =cut
  412 
  413 sub addPassword {
  414   my ($self, $Password) = @_;
  415 
  416   croak "addPassword: requires 1 argument"
  417     unless @_ == 2;
  418   croak "addPassword: argument 1 must be of type ", $self->{password}->{record}
  419     unless ref $Password eq $self->{password}->{record};
  420 
  421   checkKeyfields($Password);
  422 
  423   croak "addPassword: password exists (perhaps you meant to use putPassword?)"
  424     if $self->{password}->exists($Password->user_id);
  425   croak "addPassword: user ", $Password->user_id, " not found"
  426     unless $self->{user}->exists($Password->user_id);
  427 
  428   return $self->{password}->add($Password);
  429 }
  430 
  431 =item getPassword($userID)
  432 
  433 If a record with a matching user ID exists, a record object containting that
  434 record's data will be returned. If no such record exists, one will be created.
  435 
  436 =cut
  437 
  438 sub getPassword {
  439   my ($self, $userID) = @_;
  440 
  441   croak "getPassword: requires 1 argument"
  442     unless @_ == 2;
  443   croak "getPassword: argument 1 must contain a user_id"
  444     unless defined $userID;
  445 
  446   #return $self->{password}->get($userID);
  447   return ( $self->getPasswords($userID) )[0];
  448 }
  449 
  450 =item getPasswords(@uesrIDs)
  451 
  452 Return a list of password records associated with the user IDs given. If there
  453 is no record associated with a given user ID, one will be created.
  454 
  455 =cut
  456 
  457 sub getPasswords {
  458   my ($self, @userIDs) = @_;
  459 
  460   #croak "getPasswords: requires 1 or more argument"
  461   # unless @_ >= 2;
  462   foreach my $i (0 .. $#userIDs) {
  463     croak "getPasswords: element $i of argument list must contain a user_id"
  464       unless defined $userIDs[$i];
  465   }
  466 
  467   my @Passwords = $self->{password}->gets(map { [$_] } @userIDs);
  468 
  469   for (my $i = 0; $i < @Passwords; $i++) {
  470     my $Password = $Passwords[$i];
  471     my $userID = $userIDs[$i];
  472     if (not defined $Password) {
  473       #warn "not defined\n";
  474       if ($self->{user}->exists($userID)) {
  475         #warn "user exists\n";
  476         $Password = $self->newPassword(user_id => $userID);
  477         eval { $self->addPassword($Password) };
  478         if ($@ and $@ !~ m/password exists/) {
  479           die "error while auto-creating password record for user $userID: \"$@\"";
  480         }
  481       }
  482     }
  483   }
  484 
  485   return @Passwords;
  486 }
  487 
  488 =item putPassword($Password)
  489 
  490 $Password is a record object. If a password record with the same user ID exists
  491 in the password table, the data in the record is replaced with the data in
  492 $Password. If a matching password record does not exist, an exception is
  493 thrown.
  494 
  495 =cut
  496 
  497 sub putPassword($$) {
  498   my ($self, $Password) = @_;
  499 
  500   croak "putPassword: requires 1 argument"
  501     unless @_ == 2;
  502   croak "putPassword: argument 1 must be of type ", $self->{password}->{record}
  503     unless ref $Password eq $self->{password}->{record};
  504 
  505   checkKeyfields($Password);
  506 
  507   croak "putPassword: password not found (perhaps you meant to use addPassword?)"
  508     unless $self->{password}->exists($Password->user_id);
  509 
  510   return $self->{password}->put($Password);
  511 }
  512 
  513 =item deletePassword($userID)
  514 
  515 If a password record with a user ID matching $userID exists in the password
  516 table, it is removed and the method returns a true value. If one does exist,
  517 a false value is returned.
  518 
  519 =cut
  520 
  521 sub deletePassword($$) {
  522   my ($self, $userID) = @_;
  523 
  524   croak "putPassword: requires 1 argument"
  525     unless @_ == 2;
  526   croak "deletePassword: argument 1 must contain a user_id"
  527     unless defined $userID;
  528 
  529   return $self->{password}->delete($userID);
  530 }
  531 
  532 =back
  533 
  534 =cut
  535 
  536 ################################################################################
  537 # permission functions
  538 ################################################################################
  539 
  540 =head2 Permission Level Methods
  541 
  542 =over
  543 
  544 =item newPermissionLevel()
  545 
  546 Returns a new, empty permission level object.
  547 
  548 =cut
  549 
  550 sub newPermissionLevel {
  551   my ($self, @prototype) = @_;
  552   return $self->{permission}->{record}->new(@prototype);
  553 }
  554 
  555 =item listPermissionLevels()
  556 
  557 Returns a list of user IDs representing the records in the permission table.
  558 
  559 =cut
  560 
  561 sub listPermissionLevels($) {
  562   my ($self) = @_;
  563 
  564   croak "listPermissionLevels: requires 0 arguments"
  565     unless @_ == 1;
  566 
  567   return map { $_->[0] }
  568     $self->{permission}->list(undef);
  569 }
  570 
  571 =item addPermissionLevel($PermissionLevel)
  572 
  573 $PermissionLevel is a record object. The permission level will be added to the
  574 permission table if a permission level with the same user ID does not already
  575 exist. If one does exist, an exception is thrown. To add a permission level, a
  576 user with a matching user ID must exist in the user table.
  577 
  578 =cut
  579 
  580 sub addPermissionLevel($$) {
  581   my ($self, $PermissionLevel) = @_;
  582 
  583   croak "addPermissionLevel: requires 1 argument"
  584     unless @_ == 2;
  585   croak "addPermissionLevel: argument 1 must be of type ", $self->{permission}->{record}
  586     unless ref $PermissionLevel eq $self->{permission}->{record};
  587 
  588   checkKeyfields($PermissionLevel);
  589 
  590   croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)"
  591     if $self->{permission}->exists($PermissionLevel->user_id);
  592   croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found"
  593     unless $self->{user}->exists($PermissionLevel->user_id);
  594 
  595   return $self->{permission}->add($PermissionLevel);
  596 }
  597 
  598 =item getPermissionLevel($userID)
  599 
  600 If a record with a matching user ID exists, a record object containting that
  601 record's data will be returned. If no such record exists, one will be created.
  602 
  603 =cut
  604 
  605 sub getPermissionLevel($$) {
  606   my ($self, $userID) = @_;
  607 
  608   croak "getPermissionLevel: requires 1 argument"
  609     unless @_ == 2;
  610   croak "getPermissionLevel: argument 1 must contain a user_id"
  611     unless defined $userID;
  612 
  613   #return $self->{permission}->get($userID);
  614   return ( $self->getPermissionLevels($userID) )[0];
  615 }
  616 
  617 =item getPermissionLevels(@uesrIDs)
  618 
  619 Return a list of permission level records associated with the user IDs given. If
  620 there is no record associated with a given user ID, one will be created.
  621 
  622 =cut
  623 
  624 sub getPermissionLevels {
  625   my ($self, @userIDs) = @_;
  626 
  627   #croak "getPermissionLevels: requires 1 or more argument"
  628   # unless @_ >= 2;
  629   foreach my $i (0 .. $#userIDs) {
  630     croak "getPermissionLevels: element $i of argument list must contain a user_id"
  631       unless defined $userIDs[$i];
  632   }
  633 
  634   my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs);
  635 
  636   for (my $i = 0; $i < @PermissionLevels; $i++) {
  637     my $PermissionLevel = $PermissionLevels[$i];
  638     my $userID = $userIDs[$i];
  639     if (not defined $PermissionLevel) {
  640       #warn "not defined\n";
  641       if ($self->{user}->exists($userID)) {
  642         #warn "user exists\n";
  643         $PermissionLevel = $self->newPermissionLevel(user_id => $userID);
  644         #warn $PermissionLevel->toString, "\n";
  645         eval { $self->addPermissionLevel($PermissionLevel) };
  646         if ($@ and $@ !~ m/permission level exists/) {
  647           die "error while auto-creating permission level record for user $userID: \"$@\"";
  648         }
  649         $PermissionLevels[$i] = $PermissionLevel;
  650       }
  651     }
  652   }
  653 
  654   return @PermissionLevels;
  655 }
  656 
  657 =item putPermissionLevel($PermissionLevel)
  658 
  659 $PermissionLevel is a record object. If a permission level record with the same
  660 user ID exists in the permission table, the data in the record is replaced with
  661 the data in $PermissionLevel. If a matching permission level record does not
  662 exist, an exception is thrown.
  663 
  664 =cut
  665 
  666 sub putPermissionLevel($$) {
  667   my ($self, $PermissionLevel) = @_;
  668 
  669   croak "putPermissionLevel: requires 1 argument"
  670     unless @_ == 2;
  671   croak "putPermissionLevel: argument 1 must be of type ", $self->{permission}->{record}
  672     unless ref $PermissionLevel eq $self->{permission}->{record};
  673 
  674   checkKeyfields($PermissionLevel);
  675 
  676   croak "putPermissionLevel: permission level not found (perhaps you meant to use addPermissionLevel?)"
  677     unless $self->{permission}->exists($PermissionLevel->user_id);
  678 
  679   return $self->{permission}->put($PermissionLevel);
  680 }
  681 
  682 =item deletePermissionLevel($userID)
  683 
  684 If a permission level record with a user ID matching $userID exists in the
  685 permission table, it is removed and the method returns a true value. If one
  686 does exist, a false value is returned.
  687 
  688 =cut
  689 
  690 sub deletePermissionLevel($$) {
  691   my ($self, $userID) = @_;
  692 
  693   croak "deletePermissionLevel: requires 1 argument"
  694     unless @_ == 2;
  695   croak "deletePermissionLevel: argument 1 must contain a user_id"
  696     unless defined $userID;
  697 
  698   return $self->{permission}->delete($userID);
  699 }
  700 
  701 ################################################################################
  702 # key functions
  703 ################################################################################
  704 
  705 =head2 Key Methods
  706 
  707 =over
  708 
  709 =item newKey()
  710 
  711 Returns a new, empty key object.
  712 
  713 =cut
  714 
  715 sub newKey {
  716   my ($self, @prototype) = @_;
  717   return $self->{key}->{record}->new(@prototype);
  718 }
  719 
  720 =item listKeys()
  721 
  722 Returns a list of user IDs representing the records in the key table.
  723 
  724 =cut
  725 
  726 sub listKeys($) {
  727   my ($self) = @_;
  728 
  729   croak "listKeys: requires 0 arguments"
  730     unless @_ == 1;
  731 
  732   return map { $_->[0] }
  733     $self->{key}->list(undef);
  734 }
  735 
  736 =item addKey($Key)
  737 
  738 $Key is a record object. The key will be added to the key table if a key with
  739 the same user ID does not already exist. If one does exist, an exception is
  740 thrown. To add a key, a user with a matching user ID must exist in the user
  741 table.
  742 
  743 =cut
  744 
  745 sub addKey($$) {
  746   my ($self, $Key) = @_;
  747 
  748   croak "addKey: requires 1 argument"
  749     unless @_ == 2;
  750   croak "addKey: argument 1 must be of type ", $self->{key}->{record}
  751     unless ref $Key eq $self->{key}->{record};
  752 
  753   checkKeyfields($Key);
  754 
  755   croak "addKey: key exists (perhaps you meant to use putKey?)"
  756     if $self->{key}->exists($Key->user_id);
  757   croak "addKey: user ", $Key->user_id, " not found"
  758     unless $self->{user}->exists($Key->user_id);
  759 
  760   return $self->{key}->add($Key);
  761 }
  762 
  763 =item getKey($userID)
  764 
  765 If a record with a matching user ID exists, a record object containting that
  766 record's data will be returned. If no such record exists, an undefined value
  767 will be returned.
  768 
  769 =cut
  770 
  771 sub getKey($$) {
  772   my ($self, $userID) = @_;
  773 
  774   croak "getKey: requires 1 argument"
  775     unless @_ == 2;
  776   croak "getKey: argument 1 must contain a user_id"
  777     unless defined $userID;
  778 
  779   return $self->{key}->get($userID);
  780 }
  781 
  782 =item getKeys(@uesrIDs)
  783 
  784 Return a list of key records associated with the user IDs given. If there is no
  785 record associated with a given user ID, that element of the list will be
  786 undefined.
  787 
  788 =cut
  789 
  790 sub getKeys {
  791   my ($self, @userIDs) = @_;
  792 
  793   #croak "getKeys: requires 1 or more argument"
  794   # unless @_ >= 2;
  795   foreach my $i (0 .. $#userIDs) {
  796     croak "getKeys: element $i of argument list must contain a user_id"
  797       unless defined $userIDs[$i];
  798   }
  799 
  800   return $self->{key}->gets(map { [$_] } @userIDs);
  801 }
  802 
  803 =item putKey($Key)
  804 
  805 $Key is a record object. If a key record with the same user ID exists in the
  806 key table, the data in the record is replaced with the data in $Key. If a
  807 matching key record does not exist, an exception is thrown.
  808 
  809 =cut
  810 
  811 sub putKey($$) {
  812   my ($self, $Key) = @_;
  813 
  814   croak "putKey: requires 1 argument"
  815     unless @_ == 2;
  816   croak "putKey: argument 1 must be of type ", $self->{key}->{record}
  817     unless ref $Key eq $self->{key}->{record};
  818 
  819   checkKeyfields($Key);
  820 
  821   croak "putKey: key not found (perhaps you meant to use addKey?)"
  822     unless $self->{key}->exists($Key->user_id);
  823 
  824   return $self->{key}->put($Key);
  825 }
  826 
  827 =item deleteKey($userID)
  828 
  829 If a key record with a user ID matching $userID exists in the key table, it is
  830 removed and the method returns a true value. If one does exist, a false value
  831 is returned.
  832 
  833 =cut
  834 
  835 sub deleteKey($$) {
  836   my ($self, $userID) = @_;
  837 
  838   croak "deleteKey: requires 1 argument"
  839     unless @_ == 2;
  840   croak "deleteKey: argument 1 must contain a user_id"
  841     unless defined $userID;
  842 
  843   return $self->{key}->delete($userID);
  844 }
  845 
  846 ################################################################################
  847 # user functions
  848 ################################################################################
  849 
  850 =head2 User Methods
  851 
  852 =over
  853 
  854 =item newUser()
  855 
  856 Returns a new, empty user object.
  857 
  858 =cut
  859 
  860 sub newUser {
  861   my ($self, @prototype) = @_;
  862   return $self->{user}->{record}->new(@prototype);
  863 }
  864 
  865 =item listUsers()
  866 
  867 Returns a list of user IDs representing the records in the user table.
  868 
  869 =cut
  870 
  871 sub listUsers {
  872   my ($self) = @_;
  873 
  874   croak "listUsers: requires 0 arguments"
  875     unless @_ == 1;
  876 
  877   return map { $_->[0] }
  878     $self->{user}->list(undef);
  879 }
  880 
  881 =item addUser($User)
  882 
  883 $User is a record object. The user will be added to the user table if a user
  884 with the same user ID does not already exist. If one does exist, an exception
  885 is thrown.
  886 
  887 =cut
  888 
  889 sub addUser {
  890   my ($self, $User) = @_;
  891 
  892   croak "addUser: requires 1 argument"
  893     unless @_ == 2;
  894   croak "addUser: argument 1 must be of type ", $self->{user}->{record}
  895     unless ref $User eq $self->{user}->{record};
  896 
  897   checkKeyfields($User);
  898 
  899   croak "addUser: user exists (perhaps you meant to use putUser?)"
  900     if $self->{user}->exists($User->user_id);
  901 
  902   return $self->{user}->add($User);
  903 }
  904 
  905 =item getUser($userID)
  906 
  907 If a record with a matching user ID exists, a record object containting that
  908 record's data will be returned. If no such record exists, an undefined value
  909 will be returned.
  910 
  911 =cut
  912 
  913 sub getUser {
  914   my ($self, $userID) = @_;
  915 
  916   croak "getUser: requires 1 argument"
  917     unless @_ == 2;
  918   croak "getUser: argument 1 must contain a user_id"
  919     unless defined $userID;
  920 
  921   return $self->{user}->get($userID);
  922 }
  923 
  924 =item getUsers(@uesrIDs)
  925 
  926 Return a list of user records associated with the user IDs given. If there is no
  927 record associated with a given user ID, that element of the list will be
  928 undefined.
  929 
  930 =cut
  931 
  932 sub getUsers {
  933   my ($self, @userIDs) = @_;
  934 
  935   #croak "getUsers: requires 1 or more argument"
  936   # unless @_ >= 2;
  937   foreach my $i (0 .. $#userIDs) {
  938     croak "getUsers: element $i of argument list must contain a user_id"
  939       unless defined $userIDs[$i];
  940   }
  941 
  942   return $self->{user}->gets(map { [$_] } @userIDs);
  943 }
  944 
  945 =item putUser($User)
  946 
  947 $User is a record object. If a user record with the same user ID exists in the
  948 user table, the data in the record is replaced with the data in $User. If a
  949 matching user record does not exist, an exception is thrown.
  950 
  951 =cut
  952 
  953 sub putUser {
  954   my ($self, $User) = @_;
  955 
  956   croak "putUser: requires 1 argument"
  957     unless @_ == 2;
  958   croak "putUser: argument 1 must be of type ", $self->{user}->{record}
  959     unless ref $User eq $self->{user}->{record};
  960 
  961   checkKeyfields($User);
  962 
  963   croak "putUser: user not found (perhaps you meant to use addUser?)"
  964     unless $self->{user}->exists($User->user_id);
  965 
  966   return $self->{user}->put($User);
  967 }
  968 
  969 =item deleteUser($userID)
  970 
  971 If a user record with a user ID matching $userID exists in the user table, it
  972 is removed and the method returns a true value. If one does exist, a false
  973 value is returned. When a user record is deleted, all records associated with
  974 that user are also deleted. This includes the password, permission, and key
  975 records, and all user set records for that user.
  976 
  977 =cut
  978 
  979 sub deleteUser {
  980   my ($self, $userID) = @_;
  981 
  982   croak "deleteUser: requires 1 argument"
  983     unless @_ == 2;
  984   croak "deleteUser: argument 1 must contain a user_id"
  985     unless defined $userID;
  986 
  987   $self->deleteUserSet($userID, undef);
  988   $self->deletePassword($userID);
  989   $self->deletePermissionLevel($userID);
  990   $self->deleteKey($userID);
  991   return $self->{user}->delete($userID);
  992 }
  993 
  994 =back
  995 
  996 =cut
  997 
  998 ################################################################################
  999 # set functions
 1000 ################################################################################
 1001 
 1002 =head2 Global Set Methods
 1003 
 1004 FIXME: write this
 1005 
 1006 =over
 1007 
 1008 =cut
 1009 
 1010 =item newGlobalSet()
 1011 
 1012 =cut
 1013 
 1014 sub newGlobalSet {
 1015   my ($self, @prototype) = @_;
 1016   return $self->{set}->{record}->new(@prototype);
 1017 }
 1018 
 1019 =item listGlobalSets()
 1020 
 1021 =cut
 1022 
 1023 sub listGlobalSets {
 1024   my ($self) = @_;
 1025 
 1026   croak "listGlobalSets: requires 0 arguments"
 1027     unless @_ == 1;
 1028 
 1029   return map { $_->[0] }
 1030     $self->{set}->list(undef);
 1031 }
 1032 
 1033 =item addGlobalSet($GlobalSet)
 1034 
 1035 =cut
 1036 
 1037 sub addGlobalSet {
 1038   my ($self, $GlobalSet) = @_;
 1039 
 1040   croak "addGlobalSet: requires 1 argument"
 1041     unless @_ == 2;
 1042   croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record}
 1043     unless ref $GlobalSet eq $self->{set}->{record};
 1044 
 1045   checkKeyfields($GlobalSet);
 1046 
 1047   croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)"
 1048     if $self->{set}->exists($GlobalSet->set_id);
 1049 
 1050   return $self->{set}->add($GlobalSet);
 1051 }
 1052 
 1053 =item addGlobalSet($setID)
 1054 
 1055 =cut
 1056 
 1057 sub getGlobalSet {
 1058   my ($self, $setID) = @_;
 1059 
 1060   croak "getGlobalSet: requires 1 argument"
 1061     unless @_ == 2;
 1062   croak "getGlobalSet: argument 1 must contain a set_id"
 1063     unless defined $setID;
 1064 
 1065   return $self->{set}->get($setID);
 1066 }
 1067 
 1068 =item getGlobalSets(@setIDs)
 1069 
 1070 Return a list of global set records associated with the record IDs given. If
 1071 there is no record associated with a given record ID, that element of the list
 1072 will be undefined.
 1073 
 1074 =cut
 1075 
 1076 sub getGlobalSets {
 1077   my ($self, @setIDs) = @_;
 1078 
 1079   #croak "getGlobalSets: requires 1 or more argument"
 1080   # unless @_ >= 2;
 1081   foreach my $i (0 .. $#setIDs) {
 1082     croak "getGlobalSets: element $i of argument list must contain a set_id"
 1083       unless defined $setIDs[$i];
 1084   }
 1085 
 1086   return $self->{set}->gets(map { [$_] } @setIDs);
 1087 }
 1088 
 1089 =item addGlobalSet($GlobalSet)
 1090 
 1091 =cut
 1092 
 1093 sub putGlobalSet {
 1094   my ($self, $GlobalSet) = @_;
 1095 
 1096   croak "putGlobalSet: requires 1 argument"
 1097     unless @_ == 2;
 1098   croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record}
 1099     unless ref $GlobalSet eq $self->{set}->{record};
 1100 
 1101   checkKeyfields($GlobalSet);
 1102 
 1103   croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)"
 1104     unless $self->{set}->exists($GlobalSet->set_id);
 1105 
 1106   return $self->{set}->put($GlobalSet);
 1107 }
 1108 
 1109 =item addGlobalSet($setID)
 1110 
 1111 =cut
 1112 
 1113 sub deleteGlobalSet {
 1114   my ($self, $setID) = @_;
 1115 
 1116   croak "deleteGlobalSet: requires 1 argument"
 1117     unless @_ == 2;
 1118   croak "deleteGlobalSet: argument 1 must contain a set_id"
 1119     unless defined $setID or caller eq __PACKAGE__;
 1120 
 1121   $self->deleteUserSet(undef, $setID);
 1122   $self->deleteGlobalProblem($setID, undef);
 1123   return $self->{set}->delete($setID);
 1124 }
 1125 
 1126 =back
 1127 
 1128 =cut
 1129 
 1130 ################################################################################
 1131 # set_user functions
 1132 ################################################################################
 1133 
 1134 =head2 User-Specific Set Methods
 1135 
 1136 FIXME: write this
 1137 
 1138 =over
 1139 
 1140 =cut
 1141 
 1142 sub newUserSet {
 1143   my ($self, @prototype) = @_;
 1144   return $self->{set_user}->{record}->new(@prototype);
 1145 }
 1146 
 1147 sub countSetUsers {
 1148   my ($self, $setID) = @_;
 1149 
 1150   croak "listSetUsers: requires 1 argument"
 1151     unless @_ == 2;
 1152   croak "listSetUsers: argument 1 must contain a set_id"
 1153     unless defined $setID;
 1154 
 1155   # inefficient way
 1156   #return scalar $self->{set_user}->list(undef, $setID);
 1157 
 1158   # efficient way
 1159   return $self->{set_user}->count(undef, $setID);
 1160 }
 1161 
 1162 sub listSetUsers {
 1163   my ($self, $setID) = @_;
 1164 
 1165   carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n"
 1166     unless wantarray;
 1167 
 1168   croak "listSetUsers: requires 1 argument"
 1169     unless @_ == 2;
 1170   croak "listSetUsers: argument 1 must contain a set_id"
 1171     unless defined $setID;
 1172 
 1173   return map { $_->[0] } # extract user_id
 1174     $self->{set_user}->list(undef, $setID);
 1175 }
 1176 
 1177 sub listUserSets {
 1178   my ($self, $userID) = @_;
 1179 
 1180   croak "listUserSets: requires 1 argument"
 1181     unless @_ == 2;
 1182   croak "listUserSets: argument 1 must contain a user_id"
 1183     unless defined $userID;
 1184 
 1185   return map { $_->[1] } # extract set_id
 1186     $self->{set_user}->list($userID, undef);
 1187 }
 1188 
 1189 sub addUserSet {
 1190   my ($self, $UserSet) = @_;
 1191 
 1192   croak "addUserSet: requires 1 argument"
 1193     unless @_ == 2;
 1194   croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1195     unless ref $UserSet eq $self->{set_user}->{record};
 1196 
 1197   checkKeyfields($UserSet);
 1198 
 1199   croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"
 1200     if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1201   croak "addUserSet: user ", $UserSet->user_id, " not found"
 1202     unless $self->{user}->exists($UserSet->user_id);
 1203   croak "addUserSet: set ", $UserSet->set_id, " not found"
 1204     unless $self->{set}->exists($UserSet->set_id);
 1205 
 1206   return $self->{set_user}->add($UserSet);
 1207 }
 1208 
 1209 sub getUserSet {
 1210   my ($self, $userID, $setID) = @_;
 1211 
 1212   croak "getUserSet: requires 2 arguments"
 1213     unless @_ == 3;
 1214   croak "getUserSet: argument 1 must contain a user_id"
 1215     unless defined $userID;
 1216   croak "getUserSet: argument 2 must contain a set_id"
 1217     unless defined $setID;
 1218 
 1219   #return $self->{set_user}->get($userID, $setID);
 1220   return ( $self->getUserSets([$userID, $setID]) )[0];
 1221 }
 1222 
 1223 =item getUserSets(@userSetIDs)
 1224 
 1225 Return a list of user set records associated with the record IDs given. If there
 1226 is no record associated with a given record ID, that element of the list will be
 1227 undefined. @userProblemIDs consists of references to arrays in which the first
 1228 element is the user_id and the second element is the set_id.
 1229 
 1230 =cut
 1231 
 1232 sub getUserSets {
 1233   my ($self, @userSetIDs) = @_;
 1234 
 1235   #croak "getUserSets: requires 1 or more argument"
 1236   # unless @_ >= 2;
 1237   foreach my $i (0 .. $#userSetIDs) {
 1238     croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair"
 1239       unless defined $userSetIDs[$i]
 1240              and ref $userSetIDs[$i] eq "ARRAY"
 1241              and @{$userSetIDs[$i]} == 2
 1242              and defined $userSetIDs[$i]->[0]
 1243              and defined $userSetIDs[$i]->[1];
 1244   }
 1245 
 1246   return $self->{set_user}->gets(@userSetIDs);
 1247 }
 1248 
 1249 sub putUserSet {
 1250   my ($self, $UserSet) = @_;
 1251 
 1252   croak "putUserSet: requires 1 argument"
 1253     unless @_ == 2;
 1254   croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1255     unless ref $UserSet eq $self->{set_user}->{record};
 1256 
 1257   checkKeyfields($UserSet);
 1258 
 1259   croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)"
 1260     unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1261   croak "putUserSet: user ", $UserSet->user_id, " not found"
 1262     unless $self->{user}->exists($UserSet->user_id);
 1263   croak "putUserSet: set ", $UserSet->set_id, " not found"
 1264     unless $self->{set}->exists($UserSet->set_id);
 1265 
 1266   return $self->{set_user}->put($UserSet);
 1267 }
 1268 
 1269 sub deleteUserSet {
 1270   my ($self, $userID, $setID) = @_;
 1271 
 1272   croak "getUserSet: requires 2 arguments"
 1273     unless @_ == 3;
 1274   croak "getUserSet: argument 1 must contain a user_id"
 1275     unless defined $userID or caller eq __PACKAGE__;
 1276   croak "getUserSet: argument 2 must contain a set_id"
 1277     unless defined $userID or caller eq __PACKAGE__;
 1278 
 1279   $self->deleteUserProblem($userID, $setID, undef);
 1280   return $self->{set_user}->delete($userID, $setID);
 1281 }
 1282 
 1283 =back
 1284 
 1285 =cut
 1286 
 1287 ################################################################################
 1288 # problem functions
 1289 ################################################################################
 1290 
 1291 =head2 Global Problem Methods
 1292 
 1293 FIXME: write this
 1294 
 1295 =over
 1296 
 1297 =cut
 1298 
 1299 sub newGlobalProblem {
 1300   my ($self, @prototype) = @_;
 1301   return $self->{problem}->{record}->new(@prototype);
 1302 }
 1303 
 1304 sub listGlobalProblems {
 1305   my ($self, $setID) = @_;
 1306 
 1307   croak "listGlobalProblems: requires 1 arguments"
 1308     unless @_ == 2;
 1309   croak "listGlobalProblems: argument 1 must contain a set_id"
 1310     unless defined $setID;
 1311 
 1312   return map { $_->[1] }
 1313     $self->{problem}->list($setID, undef);
 1314 }
 1315 
 1316 sub addGlobalProblem {
 1317   my ($self, $GlobalProblem) = @_;
 1318 
 1319   croak "addGlobalProblem: requires 1 argument"
 1320     unless @_ == 2;
 1321   croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
 1322     unless ref $GlobalProblem eq $self->{problem}->{record};
 1323 
 1324   checkKeyfields($GlobalProblem);
 1325 
 1326   croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)"
 1327     if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
 1328   croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1329     unless $self->{set}->exists($GlobalProblem->set_id);
 1330 
 1331   return $self->{problem}->add($GlobalProblem);
 1332 }
 1333 
 1334 sub getGlobalProblem {
 1335   my ($self, $setID, $problemID) = @_;
 1336 
 1337   croak "getGlobalProblem: requires 2 arguments"
 1338     unless @_ == 3;
 1339   croak "getGlobalProblem: argument 1 must contain a set_id"
 1340     unless defined $setID;
 1341   croak "getGlobalProblem: argument 2 must contain a problem_id"
 1342     unless defined $problemID;
 1343 
 1344   return $self->{problem}->get($setID, $problemID);
 1345 }
 1346 
 1347 =item getGlobalProblems(@problemIDs)
 1348 
 1349 Return a list of global set records associated with the record IDs given. If
 1350 there is no record associated with a given record ID, that element of the list
 1351 will be undefined. @problemIDs consists of references to arrays in which the
 1352 first element is the set_id, and the second element is the problem_id.
 1353 
 1354 =cut
 1355 
 1356 sub getGlobalProblems {
 1357   my ($self, @problemIDs) = @_;
 1358 
 1359   #croak "getGlobalProblems: requires 1 or more argument"
 1360   # unless @_ >= 2;
 1361   foreach my $i (0 .. $#problemIDs) {
 1362     croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair"
 1363       unless defined $problemIDs[$i]
 1364              and ref $problemIDs[$i] eq "ARRAY"
 1365              and @{$problemIDs[$i]} == 2
 1366              and defined $problemIDs[$i]->[0]
 1367              and defined $problemIDs[$i]->[1];
 1368   }
 1369 
 1370   return $self->{problem}->gets(@problemIDs);
 1371 }
 1372 
 1373 =item getAllGlobalProblems($setID)
 1374 
 1375 Returns a list of Problem objects representing all the problems in the given
 1376 global set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
 1377 more efficient than using listGlobalProblems and getGlobalProblems.
 1378 
 1379 =cut
 1380 
 1381 sub getAllGlobalProblems {
 1382   my ($self, $setID) = @_;
 1383 
 1384   croak "getAllGlobalProblems: requires 1 arguments"
 1385     unless @_ == 2;
 1386   croak "getAllGlobalProblems: argument 1 must contain a set_id"
 1387     unless defined $setID;
 1388 
 1389   if ($self->{problem}->can("getAll")) {
 1390     return $self->{problem}->getAll($setID);
 1391   } else {
 1392     my @problemIDPairs = $self->{problem}->list($setID, undef);
 1393     return $self->{problem}->gets(@problemIDPairs);
 1394   }
 1395 }
 1396 
 1397 sub putGlobalProblem {
 1398   my ($self, $GlobalProblem) = @_;
 1399 
 1400   croak "putGlobalProblem: requires 1 argument"
 1401     unless @_ == 2;
 1402   croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
 1403     unless ref $GlobalProblem eq $self->{problem}->{record};
 1404 
 1405   checkKeyfields($GlobalProblem);
 1406 
 1407   croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)"
 1408     unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
 1409   croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1410     unless $self->{set}->exists($GlobalProblem->set_id);
 1411 
 1412   return $self->{problem}->put($GlobalProblem);
 1413 }
 1414 
 1415 sub deleteGlobalProblem {
 1416   my ($self, $setID, $problemID) = @_;
 1417 
 1418   croak "deleteGlobalProblem: requires 2 arguments"
 1419     unless @_ == 3;
 1420   croak "deleteGlobalProblem: argument 1 must contain a set_id"
 1421     unless defined $setID or caller eq __PACKAGE__;
 1422   croak "deleteGlobalProblem: argument 2 must contain a problem_id"
 1423     unless defined $problemID or caller eq __PACKAGE__;
 1424 
 1425   $self->deleteUserProblem(undef, $setID, $problemID);
 1426   return $self->{problem}->delete($setID, $problemID);
 1427 }
 1428 
 1429 =back
 1430 
 1431 =cut
 1432 
 1433 ################################################################################
 1434 # problem_user functions
 1435 ################################################################################
 1436 
 1437 =head2 User-Specific Problem Methods
 1438 
 1439 FIXME: write this
 1440 
 1441 =over
 1442 
 1443 =cut
 1444 
 1445 sub newUserProblem {
 1446   my ($self, @prototype) = @_;
 1447   return $self->{problem_user}->{record}->new(@prototype);
 1448 }
 1449 
 1450 sub countProblemUsers {
 1451   my ($self, $setID, $problemID) = @_;
 1452 
 1453   croak "countProblemUsers: requires 2 arguments"
 1454     unless @_ == 3;
 1455   croak "countProblemUsers: argument 1 must contain a set_id"
 1456     unless defined $setID;
 1457   croak "countProblemUsers: argument 2 must contain a problem_id"
 1458     unless defined $problemID;
 1459 
 1460   # the slow way
 1461   #return scalar $self->{problem_user}->list(undef, $setID, $problemID);
 1462 
 1463   # the fast way
 1464   return $self->{problem_user}->count(undef, $setID, $problemID);
 1465 }
 1466 
 1467 sub listProblemUsers {
 1468   my ($self, $setID, $problemID) = @_;
 1469 
 1470   carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n"
 1471     unless wantarray;
 1472 
 1473   croak "listProblemUsers: requires 2 arguments"
 1474     unless @_ == 3;
 1475   croak "listProblemUsers: argument 1 must contain a set_id"
 1476     unless defined $setID;
 1477   croak "listProblemUsers: argument 2 must contain a problem_id"
 1478     unless defined $problemID;
 1479 
 1480   return map { $_->[0] } # extract user_id
 1481     $self->{problem_user}->list(undef, $setID, $problemID);
 1482 }
 1483 
 1484 sub listUserProblems {
 1485   my ($self, $userID, $setID) = @_;
 1486 
 1487   croak "listUserProblems: requires 2 arguments"
 1488     unless @_ == 3;
 1489   croak "listUserProblems: argument 1 must contain a user_id"
 1490     unless defined $userID;
 1491   croak "listUserProblems: argument 2 must contain a set_id"
 1492     unless defined $setID;
 1493 
 1494   return map { $_->[2] } # extract problem_id
 1495     $self->{problem_user}->list($userID, $setID, undef);
 1496 }
 1497 
 1498 sub addUserProblem {
 1499   my ($self, $UserProblem) = @_;
 1500 
 1501   croak "addUserProblem: requires 1 argument"
 1502     unless @_ == 2;
 1503   croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
 1504     unless ref $UserProblem eq $self->{problem_user}->{record};
 1505 
 1506   checkKeyfields($UserProblem);
 1507 
 1508   croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)"
 1509     if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
 1510   croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1511     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1512   croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
 1513     unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id);
 1514 
 1515   return $self->{problem_user}->add($UserProblem);
 1516 }
 1517 
 1518 sub getUserProblem {
 1519   my ($self, $userID, $setID, $problemID) = @_;
 1520 
 1521   croak "getUserProblem: requires 3 arguments"
 1522     unless @_ == 4;
 1523   croak "getUserProblem: argument 1 must contain a user_id"
 1524     unless defined $userID;
 1525   croak "getUserProblem: argument 2 must contain a set_id"
 1526     unless defined $setID;
 1527   croak "getUserProblem: argument 3 must contain a problem_id"
 1528     unless defined $problemID;
 1529 
 1530   return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0];
 1531 }
 1532 
 1533 =item getUserProblems(@userProblemIDs)
 1534 
 1535 Return a list of user set records associated with the user IDs given. If there
 1536 is no record associated with a given user ID, that element of the list will be
 1537 undefined. @userProblemIDs consists of references to arrays in which the first
 1538 element is the user_id, the second element is the set_id, and the third element
 1539 is the problem_id.
 1540 
 1541 =cut
 1542 
 1543 sub getUserProblems {
 1544   my ($self, @userProblemIDs) = @_;
 1545 
 1546   #croak "getUserProblems: requires 1 or more argument"
 1547   # unless @_ >= 2;
 1548   foreach my $i (0 .. $#userProblemIDs) {
 1549     croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
 1550       unless defined $userProblemIDs[$i]
 1551              and ref $userProblemIDs[$i] eq "ARRAY"
 1552              and @{$userProblemIDs[$i]} == 3
 1553              and defined $userProblemIDs[$i]->[0]
 1554              and defined $userProblemIDs[$i]->[1]
 1555              and defined $userProblemIDs[$i]->[2];
 1556   }
 1557 
 1558   return $self->{problem_user}->gets(@userProblemIDs);
 1559 }
 1560 
 1561 =item getAllUserProblems($userID, $setID)
 1562 
 1563 Returns a list of UserProblem objects representing all the problems in the
 1564 given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
 1565 more efficient than using listUserProblems and getUserProblems.
 1566 
 1567 =cut
 1568 
 1569 sub getAllUserProblems {
 1570   my ($self, $userID, $setID) = @_;
 1571 
 1572   croak "getAllUserProblems: requires 2 arguments"
 1573     unless @_ == 3;
 1574   croak "getAllUserProblems: argument 1 must contain a user_id"
 1575     unless defined $userID;
 1576   croak "getAllUserProblems: argument 2 must contain a set_id"
 1577     unless defined $setID;
 1578 
 1579   if ($self->{problem_user}->can("getAll")) {
 1580     return $self->{problem_user}->getAll($userID, $setID);
 1581   } else {
 1582     my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef);
 1583     return $self->{problem_user}->gets(@problemIDTriples);
 1584   }
 1585 }
 1586 
 1587 sub putUserProblem {
 1588   my ($self, $UserProblem) = @_;
 1589 
 1590   croak "putUserProblem: requires 1 argument"
 1591     unless @_ == 2;
 1592   croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
 1593     unless ref $UserProblem eq $self->{problem_user}->{record};
 1594 
 1595   checkKeyfields($UserProblem);
 1596 
 1597   croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1598     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1599   croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)"
 1600     unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
 1601   croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
 1602     unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id);
 1603 
 1604   return $self->{problem_user}->put($UserProblem);
 1605 }
 1606 
 1607 sub deleteUserProblem {
 1608   my ($self, $userID, $setID, $problemID) = @_;
 1609 
 1610   croak "getUserProblem: requires 3 arguments"
 1611     unless @_ == 4;
 1612   croak "getUserProblem: argument 1 must contain a user_id"
 1613     unless defined $userID or caller eq __PACKAGE__;
 1614   croak "getUserProblem: argument 2 must contain a set_id"
 1615     unless defined $setID or caller eq __PACKAGE__;
 1616   croak "getUserProblem: argument 3 must contain a problem_id"
 1617     unless defined $problemID or caller eq __PACKAGE__;
 1618 
 1619   return $self->{problem_user}->delete($userID, $setID, $problemID);
 1620 }
 1621 
 1622 =back
 1623 
 1624 =cut
 1625 
 1626 ################################################################################
 1627 # set+set_user functions
 1628 ################################################################################
 1629 
 1630 =head2 Set Merging Methods
 1631 
 1632 These functions combine a global set and a user set to create a merged set,
 1633 which is returned. Any field that is not defined in the user set is taken from
 1634 the global set. Merged sets have the same type as user sets.
 1635 
 1636 =over
 1637 
 1638 =cut
 1639 
 1640 sub getGlobalUserSet {
 1641   carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead";
 1642   return shift->getMergedSet(@_);
 1643 }
 1644 
 1645 =item getMergedSet($userID, $setID)
 1646 
 1647 Returns a merged set record associated with the record IDs given. If there is no
 1648 record associated with a given record ID, the undefined value is returned.
 1649 
 1650 =cut
 1651 
 1652 sub getMergedSet {
 1653   my ($self, $userID, $setID) = @_;
 1654 
 1655   croak "getMergedSet: requires 2 arguments"
 1656     unless @_ == 3;
 1657   croak "getMergedSet: argument 1 must contain a user_id"
 1658     unless defined $userID;
 1659   croak "getMergedSet: argument 2 must contain a set_id"
 1660     unless defined $setID;
 1661 
 1662   return ( $self->getMergedSets([$userID, $setID]) )[0];
 1663 }
 1664 
 1665 =item getMegedSets(@userSetIDs)
 1666 
 1667 Return a list of merged set records associated with the record IDs given. If
 1668 there is no record associated with a given record ID, that element of the list
 1669 will be undefined. @userSetIDs consists of references to arrays in which the
 1670 first element is the user_id and the second element is the set_id.
 1671 
 1672 =cut
 1673 
 1674 sub getMergedSets {
 1675   my ($self, @userSetIDs) = @_;
 1676 
 1677   #croak "getMergedSets: requires 1 or more argument"
 1678   # unless @_ >= 2;
 1679   foreach my $i (0 .. $#userSetIDs) {
 1680     croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair"
 1681       unless defined $userSetIDs[$i]
 1682              and ref $userSetIDs[$i] eq "ARRAY"
 1683              and @{$userSetIDs[$i]} == 2
 1684              and defined $userSetIDs[$i]->[0]
 1685              and defined $userSetIDs[$i]->[1];
 1686   }
 1687 
 1688   # a horrible, terrible hack ;)
 1689   if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash"
 1690       and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
 1691     #warn __PACKAGE__.": using a terrible hack.\n";
 1692     $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer);
 1693     my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs);
 1694     $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer);
 1695     return @MergedSets;
 1696   }
 1697 
 1698   $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer);
 1699   my @UserSets = $self->getUserSets(@userSetIDs); # checked
 1700 
 1701   $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer);
 1702   my @globalSetIDs = map { $_->[1] } @userSetIDs;
 1703   $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer);
 1704   my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked
 1705 
 1706   $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer);
 1707   my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
 1708   my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
 1709 
 1710   $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 1711   for (my $i = 0; $i < @UserSets; $i++) {
 1712     my $UserSet = $UserSets[$i];
 1713     my $GlobalSet = $GlobalSets[$i];
 1714     next unless defined $UserSet and defined $GlobalSet;
 1715     foreach my $field (@commonFields) {
 1716       #next if defined $UserSet->$field;
 1717       # ok, now we're testing for emptiness instead of definedness.
 1718       next if $UserSet->$field ne "";
 1719       $UserSet->$field($GlobalSet->$field);
 1720     }
 1721   }
 1722   $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 1723 
 1724   return @UserSets;
 1725 }
 1726 
 1727 =back
 1728 
 1729 =cut
 1730 
 1731 ################################################################################
 1732 # problem+problem_user functions
 1733 ################################################################################
 1734 
 1735 =head2 Problem Merging Methods
 1736 
 1737 These functions combine a global problem and a user problem to create a merged
 1738 problem, which is returned. Any field that is not defined in the user problem is
 1739 taken from the global problem. Merged problems have the same type as user
 1740 problems.
 1741 
 1742 =over
 1743 
 1744 =cut
 1745 
 1746 sub getGlobalUserProblem {
 1747   carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead";
 1748   return shift->getMergedProblem(@_);
 1749 }
 1750 
 1751 =item getMergedProblem($userID, $setID, $problemID)
 1752 
 1753 Returns a merged problem record associated with the record IDs given. If there
 1754 is no record associated with a given record ID, the undefined value is returned.
 1755 
 1756 =cut
 1757 
 1758 sub getMergedProblem {
 1759   my ($self, $userID, $setID, $problemID) = @_;
 1760 
 1761   croak "getGlobalUserSet: requires 3 arguments"
 1762     unless @_ == 4;
 1763   croak "getGlobalUserSet: argument 1 must contain a user_id"
 1764     unless defined $userID;
 1765   croak "getGlobalUserSet: argument 2 must contain a set_id"
 1766     unless defined $setID;
 1767   croak "getGlobalUserSet: argument 3 must contain a problem_id"
 1768     unless defined $problemID;
 1769 
 1770   return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0];
 1771 }
 1772 
 1773 =item getMergedProblems(@userProblemIDs)
 1774 
 1775 Return a list of merged problem records associated with the record IDs given. If
 1776 there is no record associated with a given record ID, that element of the list
 1777 will be undefined. @userProblemIDs consists of references to arrays in which the
 1778 first element is the user_id, the second element is the set_id, and the third
 1779 element is the problem_id.
 1780 
 1781 =cut
 1782 
 1783 sub getMergedProblems {
 1784   my ($self, @userProblemIDs) = @_;
 1785 
 1786   #croak "getMergedProblems: requires 1 or more argument"
 1787   # unless @_ >= 2;
 1788   foreach my $i (0 .. $#userProblemIDs) {
 1789     croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
 1790       unless defined $userProblemIDs[$i]
 1791              and ref $userProblemIDs[$i] eq "ARRAY"
 1792              and @{$userProblemIDs[$i]} == 3
 1793              and defined $userProblemIDs[$i]->[0]
 1794              and defined $userProblemIDs[$i]->[1]
 1795              and defined $userProblemIDs[$i]->[2];
 1796   }
 1797 
 1798   $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer);
 1799   my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked
 1800 
 1801   $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer);
 1802   my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs;
 1803   $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer);
 1804   my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked
 1805 
 1806   $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer);
 1807   my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
 1808   my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
 1809 
 1810   $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 1811   for (my $i = 0; $i < @UserProblems; $i++) {
 1812     my $UserProblem = $UserProblems[$i];
 1813     my $GlobalProblem = $GlobalProblems[$i];
 1814     next unless defined $UserProblem and defined $GlobalProblem;
 1815     foreach my $field (@commonFields) {
 1816       # FIXME: WW1Hash upgrades undefined fileds to "" when creating record objects
 1817       # Shouldn't we be testing for emptiness rather than definedness?
 1818       # I think the spec says that if a field is EMPTY the global value is used.
 1819       #next if defined $UserProblem->$field;
 1820       # ok, now we're testing for emptiness instead of definedness.
 1821       next if $UserProblem->$field ne "";
 1822       $UserProblem->$field($GlobalProblem->$field);
 1823     }
 1824   }
 1825   $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 1826 
 1827   return @UserProblems;
 1828 }
 1829 
 1830 =back
 1831 
 1832 =cut
 1833 
 1834 ################################################################################
 1835 # debugging
 1836 ################################################################################
 1837 
 1838 #sub dumpDB($$) {
 1839 # my ($self, $table) = @_;
 1840 # return $self->{$table}->dumpDB();
 1841 #}
 1842 
 1843 ################################################################################
 1844 # utilities
 1845 ################################################################################
 1846 
 1847 sub checkKeyfields($) {
 1848   my ($Record) = @_;
 1849   foreach my $keyfield ($Record->KEYFIELDS) {
 1850     my $value = $Record->$keyfield;
 1851     croak "checkKeyfields: $keyfield is empty"
 1852       unless defined $value and $value ne "";
 1853 
 1854     if ($keyfield eq "problem_id") {
 1855       croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])"
 1856         unless $value =~ m/^\d*$/;
 1857     } else {
 1858       croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])"
 1859         unless $value =~ m/^[\w-]*$/;
 1860     }
 1861   }
 1862 }
 1863 
 1864 =head1 AUTHOR
 1865 
 1866 Written by Sam Hathaway, sh002i (at) math.rochester.edu.
 1867 
 1868 =cut
 1869 
 1870 1;