View of /trunk/webwork2/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.41 2003/12/09 01:12:30 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($courseEnvironment);
   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 C<%dbLayout>
   48 hash in 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 The C<%dbLayout> hash consists of items keyed by table names. The value of each
  165 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, $ce) = @_;
  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 = %{$ce->{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, $driver->new($source, $params),
  228       $table, $record, $params) };
  229     croak "error instantiating DB schema $schema for table $table: $@"
  230       if $@;
  231 
  232     $self->{$table} = $schemaObject;
  233   }
  234 
  235   return $self;
  236 }
  237 
  238 =head1 METHODS
  239 
  240 =cut
  241 
  242 ################################################################################
  243 # password functions
  244 ################################################################################
  245 
  246 =head2 Password Methods
  247 
  248 =over
  249 
  250 =item newPassword()
  251 
  252 Returns a new, empty password object.
  253 
  254 =cut
  255 
  256 sub newPassword {
  257   my ($self, @prototype) = @_;
  258   return $self->{password}->{record}->new(@prototype);
  259 }
  260 
  261 =item listPasswords()
  262 
  263 Returns a list of user IDs representing the records in the password table.
  264 
  265 =cut
  266 
  267 sub listPasswords {
  268   my ($self) = @_;
  269 
  270   croak "listPasswords: requires 0 arguments"
  271     unless @_ == 1;
  272 
  273   return map { $_->[0] }
  274     $self->{password}->list(undef);
  275 }
  276 
  277 =item addPassword($Password)
  278 
  279 $Password is a record object. The password will be added to the password table
  280 if a password with the same user ID does not already exist. If one does exist,
  281 an exception is thrown. To add a password, a user with a matching user ID must
  282 exist in the user table.
  283 
  284 =cut
  285 
  286 sub addPassword {
  287   my ($self, $Password) = @_;
  288 
  289   croak "addPassword: requires 1 argument"
  290     unless @_ == 2;
  291   croak "addPassword: argument 1 must be of type ", $self->{password}->{record}
  292     unless ref $Password eq $self->{password}->{record};
  293 
  294   checkKeyfields($Password);
  295 
  296   croak "addPassword: password exists (perhaps you meant to use putPassword?)"
  297     if $self->{password}->exists($Password->user_id);
  298   croak "addPassword: user ", $Password->user_id, " not found"
  299     unless $self->{user}->exists($Password->user_id);
  300 
  301   return $self->{password}->add($Password);
  302 }
  303 
  304 =item getPassword($userID)
  305 
  306 If a record with a matching user ID exists, a record object containting that
  307 record's data will be returned. If no such record exists, one will be created.
  308 
  309 =cut
  310 
  311 sub getPassword {
  312   my ($self, $userID) = @_;
  313 
  314   croak "getPassword: requires 1 argument"
  315     unless @_ == 2;
  316   croak "getPassword: argument 1 must contain a user_id"
  317     unless defined $userID;
  318 
  319   #return $self->{password}->get($userID);
  320   return ( $self->getPasswords($userID) )[0];
  321 }
  322 
  323 =item getPasswords(@uesrIDs)
  324 
  325 Return a list of password records associated with the user IDs given. If there
  326 is no record associated with a given user ID, one will be created.
  327 
  328 =cut
  329 
  330 sub getPasswords {
  331   my ($self, @userIDs) = @_;
  332 
  333   #croak "getPasswords: requires 1 or more argument"
  334   # unless @_ >= 2;
  335   foreach my $i (0 .. $#userIDs) {
  336     croak "getPasswords: element $i of argument list must contain a user_id"
  337       unless defined $userIDs[$i];
  338   }
  339 
  340   my @Passwords = $self->{password}->gets(map { [$_] } @userIDs);
  341 
  342   for (my $i = 0; $i < @Passwords; $i++) {
  343     my $Password = $Passwords[$i];
  344     my $userID = $userIDs[$i];
  345     if (not defined $Password) {
  346       #warn "not defined\n";
  347       if ($self->{user}->exists($userID)) {
  348         #warn "user exists\n";
  349         $Password = $self->newPassword(user_id => $userID);
  350         eval { $self->addPassword($Password) };
  351         if ($@ and $@ !~ m/password exists/) {
  352           die "error while auto-creating password record for user $userID: \"$@\"";
  353         }
  354       }
  355     }
  356   }
  357 
  358   return @Passwords;
  359 }
  360 
  361 =item putPassword($Password)
  362 
  363 $Password is a record object. If a password record with the same user ID exists
  364 in the password table, the data in the record is replaced with the data in
  365 $Password. If a matching password record does not exist, an exception is
  366 thrown.
  367 
  368 =cut
  369 
  370 sub putPassword($$) {
  371   my ($self, $Password) = @_;
  372 
  373   croak "putPassword: requires 1 argument"
  374     unless @_ == 2;
  375   croak "putPassword: argument 1 must be of type ", $self->{password}->{record}
  376     unless ref $Password eq $self->{password}->{record};
  377 
  378   checkKeyfields($Password);
  379 
  380   croak "putPassword: password not found (perhaps you meant to use addPassword?)"
  381     unless $self->{password}->exists($Password->user_id);
  382 
  383   return $self->{password}->put($Password);
  384 }
  385 
  386 =item deletePassword($userID)
  387 
  388 If a password record with a user ID matching $userID exists in the password
  389 table, it is removed and the method returns a true value. If one does exist,
  390 a false value is returned.
  391 
  392 =cut
  393 
  394 sub deletePassword($$) {
  395   my ($self, $userID) = @_;
  396 
  397   croak "putPassword: requires 1 argument"
  398     unless @_ == 2;
  399   croak "deletePassword: argument 1 must contain a user_id"
  400     unless defined $userID;
  401 
  402   return $self->{password}->delete($userID);
  403 }
  404 
  405 =back
  406 
  407 =cut
  408 
  409 ################################################################################
  410 # permission functions
  411 ################################################################################
  412 
  413 =head2 Permission Level Methods
  414 
  415 =over
  416 
  417 =item newPermissionLevel()
  418 
  419 Returns a new, empty permission level object.
  420 
  421 =cut
  422 
  423 sub newPermissionLevel {
  424   my ($self, @prototype) = @_;
  425   return $self->{permission}->{record}->new(@prototype);
  426 }
  427 
  428 =item listPermissionLevels()
  429 
  430 Returns a list of user IDs representing the records in the permission table.
  431 
  432 =cut
  433 
  434 sub listPermissionLevels($) {
  435   my ($self) = @_;
  436 
  437   croak "listPermissionLevels: requires 0 arguments"
  438     unless @_ == 1;
  439 
  440   return map { $_->[0] }
  441     $self->{permission}->list(undef);
  442 }
  443 
  444 =item addPermissionLevel($PermissionLevel)
  445 
  446 $PermissionLevel is a record object. The permission level will be added to the
  447 permission table if a permission level with the same user ID does not already
  448 exist. If one does exist, an exception is thrown. To add a permission level, a
  449 user with a matching user ID must exist in the user table.
  450 
  451 =cut
  452 
  453 sub addPermissionLevel($$) {
  454   my ($self, $PermissionLevel) = @_;
  455 
  456   croak "addPermissionLevel: requires 1 argument"
  457     unless @_ == 2;
  458   croak "addPermissionLevel: argument 1 must be of type ", $self->{permission}->{record}
  459     unless ref $PermissionLevel eq $self->{permission}->{record};
  460 
  461   checkKeyfields($PermissionLevel);
  462 
  463   croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)"
  464     if $self->{permission}->exists($PermissionLevel->user_id);
  465   croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found"
  466     unless $self->{user}->exists($PermissionLevel->user_id);
  467 
  468   return $self->{permission}->add($PermissionLevel);
  469 }
  470 
  471 =item getPermissionLevel($userID)
  472 
  473 If a record with a matching user ID exists, a record object containting that
  474 record's data will be returned. If no such record exists, one will be created.
  475 
  476 =cut
  477 
  478 sub getPermissionLevel($$) {
  479   my ($self, $userID) = @_;
  480 
  481   croak "getPermissionLevel: requires 1 argument"
  482     unless @_ == 2;
  483   croak "getPermissionLevel: argument 1 must contain a user_id"
  484     unless defined $userID;
  485 
  486   #return $self->{permission}->get($userID);
  487   return ( $self->getPermissionLevels($userID) )[0];
  488 }
  489 
  490 =item getPermissionLevels(@uesrIDs)
  491 
  492 Return a list of permission level records associated with the user IDs given. If
  493 there is no record associated with a given user ID, one will be created.
  494 
  495 =cut
  496 
  497 sub getPermissionLevels {
  498   my ($self, @userIDs) = @_;
  499 
  500   #croak "getPermissionLevels: requires 1 or more argument"
  501   # unless @_ >= 2;
  502   foreach my $i (0 .. $#userIDs) {
  503     croak "getPermissionLevels: element $i of argument list must contain a user_id"
  504       unless defined $userIDs[$i];
  505   }
  506 
  507   my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs);
  508 
  509   for (my $i = 0; $i < @PermissionLevels; $i++) {
  510     my $PermissionLevel = $PermissionLevels[$i];
  511     my $userID = $userIDs[$i];
  512     if (not defined $PermissionLevel) {
  513       #warn "not defined\n";
  514       if ($self->{user}->exists($userID)) {
  515         #warn "user exists\n";
  516         $PermissionLevel = $self->newPermissionLevel(user_id => $userID);
  517         warn $PermissionLevel->toString, "\n";
  518         eval { $self->addPermissionLevel($PermissionLevel) };
  519         if ($@ and $@ !~ m/permission level exists/) {
  520           die "error while auto-creating permission level record for user $userID: \"$@\"";
  521         }
  522       }
  523     }
  524   }
  525 
  526   return @PermissionLevels;
  527 }
  528 
  529 =item putPermissionLevel($PermissionLevel)
  530 
  531 $PermissionLevel is a record object. If a permission level record with the same
  532 user ID exists in the permission table, the data in the record is replaced with
  533 the data in $PermissionLevel. If a matching permission level record does not
  534 exist, an exception is thrown.
  535 
  536 =cut
  537 
  538 sub putPermissionLevel($$) {
  539   my ($self, $PermissionLevel) = @_;
  540 
  541   croak "putPermissionLevel: requires 1 argument"
  542     unless @_ == 2;
  543   croak "putPermissionLevel: argument 1 must be of type ", $self->{permission}->{record}
  544     unless ref $PermissionLevel eq $self->{permission}->{record};
  545 
  546   checkKeyfields($PermissionLevel);
  547 
  548   croak "putPermissionLevel: permission level not found (perhaps you meant to use addPermissionLevel?)"
  549     unless $self->{permission}->exists($PermissionLevel->user_id);
  550 
  551   return $self->{permission}->put($PermissionLevel);
  552 }
  553 
  554 =item deletePermissionLevel($userID)
  555 
  556 If a permission level record with a user ID matching $userID exists in the
  557 permission table, it is removed and the method returns a true value. If one
  558 does exist, a false value is returned.
  559 
  560 =cut
  561 
  562 sub deletePermissionLevel($$) {
  563   my ($self, $userID) = @_;
  564 
  565   croak "deletePermissionLevel: requires 1 argument"
  566     unless @_ == 2;
  567   croak "deletePermissionLevel: argument 1 must contain a user_id"
  568     unless defined $userID;
  569 
  570   return $self->{permission}->delete($userID);
  571 }
  572 
  573 ################################################################################
  574 # key functions
  575 ################################################################################
  576 
  577 =head2 Key Methods
  578 
  579 =over
  580 
  581 =item newKey()
  582 
  583 Returns a new, empty key object.
  584 
  585 =cut
  586 
  587 sub newKey {
  588   my ($self, @prototype) = @_;
  589   return $self->{key}->{record}->new(@prototype);
  590 }
  591 
  592 =item listKeys()
  593 
  594 Returns a list of user IDs representing the records in the key table.
  595 
  596 =cut
  597 
  598 sub listKeys($) {
  599   my ($self) = @_;
  600 
  601   croak "listKeys: requires 0 arguments"
  602     unless @_ == 1;
  603 
  604   return map { $_->[0] }
  605     $self->{key}->list(undef);
  606 }
  607 
  608 =item addKey($Key)
  609 
  610 $Key is a record object. The key will be added to the key table if a key with
  611 the same user ID does not already exist. If one does exist, an exception is
  612 thrown. To add a key, a user with a matching user ID must exist in the user
  613 table.
  614 
  615 =cut
  616 
  617 sub addKey($$) {
  618   my ($self, $Key) = @_;
  619 
  620   croak "addKey: requires 1 argument"
  621     unless @_ == 2;
  622   croak "addKey: argument 1 must be of type ", $self->{key}->{record}
  623     unless ref $Key eq $self->{key}->{record};
  624 
  625   checkKeyfields($Key);
  626 
  627   croak "addKey: key exists (perhaps you meant to use putKey?)"
  628     if $self->{key}->exists($Key->user_id);
  629   croak "addKey: user ", $Key->user_id, " not found"
  630     unless $self->{user}->exists($Key->user_id);
  631 
  632   return $self->{key}->add($Key);
  633 }
  634 
  635 =item getKey($userID)
  636 
  637 If a record with a matching user ID exists, a record object containting that
  638 record's data will be returned. If no such record exists, an undefined value
  639 will be returned.
  640 
  641 =cut
  642 
  643 sub getKey($$) {
  644   my ($self, $userID) = @_;
  645 
  646   croak "getKey: requires 1 argument"
  647     unless @_ == 2;
  648   croak "getKey: argument 1 must contain a user_id"
  649     unless defined $userID;
  650 
  651   return $self->{key}->get($userID);
  652 }
  653 
  654 =item getKeys(@uesrIDs)
  655 
  656 Return a list of key records associated with the user IDs given. If there is no
  657 record associated with a given user ID, that element of the list will be
  658 undefined.
  659 
  660 =cut
  661 
  662 sub getKeys {
  663   my ($self, @userIDs) = @_;
  664 
  665   #croak "getKeys: requires 1 or more argument"
  666   # unless @_ >= 2;
  667   foreach my $i (0 .. $#userIDs) {
  668     croak "getKeys: element $i of argument list must contain a user_id"
  669       unless defined $userIDs[$i];
  670   }
  671 
  672   return $self->{key}->gets(map { [$_] } @userIDs);
  673 }
  674 
  675 =item putKey($Key)
  676 
  677 $Key is a record object. If a key record with the same user ID exists in the
  678 key table, the data in the record is replaced with the data in $Key. If a
  679 matching key record does not exist, an exception is thrown.
  680 
  681 =cut
  682 
  683 sub putKey($$) {
  684   my ($self, $Key) = @_;
  685 
  686   croak "putKey: requires 1 argument"
  687     unless @_ == 2;
  688   croak "putKey: argument 1 must be of type ", $self->{key}->{record}
  689     unless ref $Key eq $self->{key}->{record};
  690 
  691   checkKeyfields($Key);
  692 
  693   croak "putKey: key not found (perhaps you meant to use addKey?)"
  694     unless $self->{key}->exists($Key->user_id);
  695 
  696   return $self->{key}->put($Key);
  697 }
  698 
  699 =item deleteKey($userID)
  700 
  701 If a key record with a user ID matching $userID exists in the key table, it is
  702 removed and the method returns a true value. If one does exist, a false value
  703 is returned.
  704 
  705 =cut
  706 
  707 sub deleteKey($$) {
  708   my ($self, $userID) = @_;
  709 
  710   croak "deleteKey: requires 1 argument"
  711     unless @_ == 2;
  712   croak "deleteKey: argument 1 must contain a user_id"
  713     unless defined $userID;
  714 
  715   return $self->{key}->delete($userID);
  716 }
  717 
  718 ################################################################################
  719 # user functions
  720 ################################################################################
  721 
  722 =head2 User Methods
  723 
  724 =over
  725 
  726 =item newUser()
  727 
  728 Returns a new, empty user object.
  729 
  730 =cut
  731 
  732 sub newUser {
  733   my ($self, @prototype) = @_;
  734   return $self->{user}->{record}->new(@prototype);
  735 }
  736 
  737 =item listUsers()
  738 
  739 Returns a list of user IDs representing the records in the user table.
  740 
  741 =cut
  742 
  743 sub listUsers {
  744   my ($self) = @_;
  745 
  746   croak "listUsers: requires 0 arguments"
  747     unless @_ == 1;
  748 
  749   return map { $_->[0] }
  750     $self->{user}->list(undef);
  751 }
  752 
  753 =item addUser($User)
  754 
  755 $User is a record object. The user will be added to the user table if a user
  756 with the same user ID does not already exist. If one does exist, an exception
  757 is thrown.
  758 
  759 =cut
  760 
  761 sub addUser {
  762   my ($self, $User) = @_;
  763 
  764   croak "addUser: requires 1 argument"
  765     unless @_ == 2;
  766   croak "addUser: argument 1 must be of type ", $self->{user}->{record}
  767     unless ref $User eq $self->{user}->{record};
  768 
  769   checkKeyfields($User);
  770 
  771   croak "addUser: user exists (perhaps you meant to use putUser?)"
  772     if $self->{user}->exists($User->user_id);
  773 
  774   return $self->{user}->add($User);
  775 }
  776 
  777 =item getUser($userID)
  778 
  779 If a record with a matching user ID exists, a record object containting that
  780 record's data will be returned. If no such record exists, an undefined value
  781 will be returned.
  782 
  783 =cut
  784 
  785 sub getUser {
  786   my ($self, $userID) = @_;
  787 
  788   croak "getUser: requires 1 argument"
  789     unless @_ == 2;
  790   croak "getUser: argument 1 must contain a user_id"
  791     unless defined $userID;
  792 
  793   return $self->{user}->get($userID);
  794 }
  795 
  796 =item getUsers(@uesrIDs)
  797 
  798 Return a list of user records associated with the user IDs given. If there is no
  799 record associated with a given user ID, that element of the list will be
  800 undefined.
  801 
  802 =cut
  803 
  804 sub getUsers {
  805   my ($self, @userIDs) = @_;
  806 
  807   #croak "getUsers: requires 1 or more argument"
  808   # unless @_ >= 2;
  809   foreach my $i (0 .. $#userIDs) {
  810     croak "getUsers: element $i of argument list must contain a user_id"
  811       unless defined $userIDs[$i];
  812   }
  813 
  814   return $self->{user}->gets(map { [$_] } @userIDs);
  815 }
  816 
  817 =item putUser($User)
  818 
  819 $User is a record object. If a user record with the same user ID exists in the
  820 user table, the data in the record is replaced with the data in $User. If a
  821 matching user record does not exist, an exception is thrown.
  822 
  823 =cut
  824 
  825 sub putUser {
  826   my ($self, $User) = @_;
  827 
  828   croak "putUser: requires 1 argument"
  829     unless @_ == 2;
  830   croak "putUser: argument 1 must be of type ", $self->{user}->{record}
  831     unless ref $User eq $self->{user}->{record};
  832 
  833   checkKeyfields($User);
  834 
  835   croak "putUser: user not found (perhaps you meant to use addUser?)"
  836     unless $self->{user}->exists($User->user_id);
  837 
  838   return $self->{user}->put($User);
  839 }
  840 
  841 =item deleteUser($userID)
  842 
  843 If a user record with a user ID matching $userID exists in the user table, it
  844 is removed and the method returns a true value. If one does exist, a false
  845 value is returned. When a user record is deleted, all records associated with
  846 that user are also deleted. This includes the password, permission, and key
  847 records, and all user set records for that user.
  848 
  849 =cut
  850 
  851 sub deleteUser {
  852   my ($self, $userID) = @_;
  853 
  854   croak "deleteUser: requires 1 argument"
  855     unless @_ == 2;
  856   croak "deleteUser: argument 1 must contain a user_id"
  857     unless defined $userID;
  858 
  859   $self->deleteUserSet($userID, undef);
  860   $self->deletePassword($userID);
  861   $self->deletePermissionLevel($userID);
  862   $self->deleteKey($userID);
  863   return $self->{user}->delete($userID);
  864 }
  865 
  866 =back
  867 
  868 =cut
  869 
  870 ################################################################################
  871 # set functions
  872 ################################################################################
  873 
  874 =head2 Global Set Methods
  875 
  876 FIXME: write this
  877 
  878 =over
  879 
  880 =cut
  881 
  882 sub newGlobalSet {
  883   my ($self, @prototype) = @_;
  884   return $self->{set}->{record}->new(@prototype);
  885 }
  886 
  887 sub listGlobalSets {
  888   my ($self) = @_;
  889 
  890   croak "listGlobalSets: requires 0 arguments"
  891     unless @_ == 1;
  892 
  893   return map { $_->[0] }
  894     $self->{set}->list(undef);
  895 }
  896 
  897 sub addGlobalSet {
  898   my ($self, $GlobalSet) = @_;
  899 
  900   croak "addGlobalSet: requires 1 argument"
  901     unless @_ == 2;
  902   croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record}
  903     unless ref $GlobalSet eq $self->{set}->{record};
  904 
  905   checkKeyfields($GlobalSet);
  906 
  907   croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)"
  908     if $self->{set}->exists($GlobalSet->set_id);
  909 
  910   return $self->{set}->add($GlobalSet);
  911 }
  912 
  913 sub getGlobalSet {
  914   my ($self, $setID) = @_;
  915 
  916   croak "getGlobalSet: requires 1 argument"
  917     unless @_ == 2;
  918   croak "getGlobalSet: argument 1 must contain a set_id"
  919     unless defined $setID;
  920 
  921   return $self->{set}->get($setID);
  922 }
  923 
  924 =item getGlobalSets(@setIDs)
  925 
  926 Return a list of global set records associated with the record IDs given. If
  927 there is no record associated with a given record ID, that element of the list
  928 will be undefined.
  929 
  930 =cut
  931 
  932 sub getGlobalSets {
  933   my ($self, @setIDs) = @_;
  934 
  935   #croak "getGlobalSets: requires 1 or more argument"
  936   # unless @_ >= 2;
  937   foreach my $i (0 .. $#setIDs) {
  938     croak "getGlobalSets: element $i of argument list must contain a set_id"
  939       unless defined $setIDs[$i];
  940   }
  941 
  942   return $self->{set}->gets(map { [$_] } @setIDs);
  943 }
  944 
  945 sub putGlobalSet {
  946   my ($self, $GlobalSet) = @_;
  947 
  948   croak "putGlobalSet: requires 1 argument"
  949     unless @_ == 2;
  950   croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record}
  951     unless ref $GlobalSet eq $self->{set}->{record};
  952 
  953   checkKeyfields($GlobalSet);
  954 
  955   croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)"
  956     unless $self->{set}->exists($GlobalSet->set_id);
  957 
  958   return $self->{set}->put($GlobalSet);
  959 }
  960 
  961 sub deleteGlobalSet {
  962   my ($self, $setID) = @_;
  963 
  964   croak "deleteGlobalSet: requires 1 argument"
  965     unless @_ == 2;
  966   croak "deleteGlobalSet: argument 1 must contain a set_id"
  967     unless defined $setID or caller eq __PACKAGE__;
  968 
  969   $self->deleteUserSet(undef, $setID);
  970   $self->deleteGlobalProblem($setID, undef);
  971   return $self->{set}->delete($setID);
  972 }
  973 
  974 =back
  975 
  976 =cut
  977 
  978 ################################################################################
  979 # set_user functions
  980 ################################################################################
  981 
  982 =head2 User-Specific Set Methods
  983 
  984 FIXME: write this
  985 
  986 =over
  987 
  988 =cut
  989 
  990 sub newUserSet {
  991   my ($self, @prototype) = @_;
  992   return $self->{set_user}->{record}->new(@prototype);
  993 }
  994 
  995 sub countSetUsers {
  996   my ($self, $setID) = @_;
  997 
  998   croak "listSetUsers: requires 1 argument"
  999     unless @_ == 2;
 1000   croak "listSetUsers: argument 1 must contain a set_id"
 1001     unless defined $setID;
 1002 
 1003   # inefficient way
 1004   #return scalar $self->{set_user}->list(undef, $setID);
 1005 
 1006   # efficient way
 1007   return $self->{set_user}->count(undef, $setID);
 1008 }
 1009 
 1010 sub listSetUsers {
 1011   my ($self, $setID) = @_;
 1012 
 1013   carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n"
 1014     unless wantarray;
 1015 
 1016   croak "listSetUsers: requires 1 argument"
 1017     unless @_ == 2;
 1018   croak "listSetUsers: argument 1 must contain a set_id"
 1019     unless defined $setID;
 1020 
 1021   return map { $_->[0] } # extract user_id
 1022     $self->{set_user}->list(undef, $setID);
 1023 }
 1024 
 1025 sub listUserSets {
 1026   my ($self, $userID) = @_;
 1027 
 1028   croak "listUserSets: requires 1 argument"
 1029     unless @_ == 2;
 1030   croak "listUserSets: argument 1 must contain a user_id"
 1031     unless defined $userID;
 1032 
 1033   return map { $_->[1] } # extract set_id
 1034     $self->{set_user}->list($userID, undef);
 1035 }
 1036 
 1037 sub addUserSet {
 1038   my ($self, $UserSet) = @_;
 1039 
 1040   croak "addUserSet: requires 1 argument"
 1041     unless @_ == 2;
 1042   croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1043     unless ref $UserSet eq $self->{set_user}->{record};
 1044 
 1045   checkKeyfields($UserSet);
 1046 
 1047   croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"
 1048     if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1049   croak "addUserSet: user ", $UserSet->user_id, " not found"
 1050     unless $self->{user}->exists($UserSet->user_id);
 1051   croak "addUserSet: set ", $UserSet->set_id, " not found"
 1052     unless $self->{set}->exists($UserSet->set_id);
 1053 
 1054   return $self->{set_user}->add($UserSet);
 1055 }
 1056 
 1057 sub getUserSet {
 1058   my ($self, $userID, $setID) = @_;
 1059 
 1060   croak "getUserSet: requires 2 arguments"
 1061     unless @_ == 3;
 1062   croak "getUserSet: argument 1 must contain a user_id"
 1063     unless defined $userID;
 1064   croak "getUserSet: argument 2 must contain a set_id"
 1065     unless defined $setID;
 1066 
 1067   #return $self->{set_user}->get($userID, $setID);
 1068   return ( $self->getUserSets([$userID, $setID]) )[0];
 1069 }
 1070 
 1071 =item getUserSets(@userSetIDs)
 1072 
 1073 Return a list of user set records associated with the record IDs given. If there
 1074 is no record associated with a given record ID, that element of the list will be
 1075 undefined. @userProblemIDs consists of references to arrays in which the first
 1076 element is the user_id and the second element is the set_id.
 1077 
 1078 =cut
 1079 
 1080 sub getUserSets {
 1081   my ($self, @userSetIDs) = @_;
 1082 
 1083   #croak "getUserSets: requires 1 or more argument"
 1084   # unless @_ >= 2;
 1085   foreach my $i (0 .. $#userSetIDs) {
 1086     croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair"
 1087       unless defined $userSetIDs[$i]
 1088              and ref $userSetIDs[$i] eq "ARRAY"
 1089              and @{$userSetIDs[$i]} == 2
 1090              and defined $userSetIDs[$i]->[0]
 1091              and defined $userSetIDs[$i]->[1];
 1092   }
 1093 
 1094   return $self->{set_user}->gets(@userSetIDs);
 1095 }
 1096 
 1097 sub putUserSet {
 1098   my ($self, $UserSet) = @_;
 1099 
 1100   croak "putUserSet: requires 1 argument"
 1101     unless @_ == 2;
 1102   croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1103     unless ref $UserSet eq $self->{set_user}->{record};
 1104 
 1105   checkKeyfields($UserSet);
 1106 
 1107   croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)"
 1108     unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1109   croak "putUserSet: user ", $UserSet->user_id, " not found"
 1110     unless $self->{user}->exists($UserSet->user_id);
 1111   croak "putUserSet: set ", $UserSet->set_id, " not found"
 1112     unless $self->{set}->exists($UserSet->set_id);
 1113 
 1114   return $self->{set_user}->put($UserSet);
 1115 }
 1116 
 1117 sub deleteUserSet {
 1118   my ($self, $userID, $setID) = @_;
 1119 
 1120   croak "getUserSet: requires 2 arguments"
 1121     unless @_ == 3;
 1122   croak "getUserSet: argument 1 must contain a user_id"
 1123     unless defined $userID or caller eq __PACKAGE__;
 1124   croak "getUserSet: argument 2 must contain a set_id"
 1125     unless defined $userID or caller eq __PACKAGE__;
 1126 
 1127   $self->deleteUserProblem($userID, $setID, undef);
 1128   return $self->{set_user}->delete($userID, $setID);
 1129 }
 1130 
 1131 =back
 1132 
 1133 =cut
 1134 
 1135 ################################################################################
 1136 # problem functions
 1137 ################################################################################
 1138 
 1139 =head2 Global Problem Methods
 1140 
 1141 FIXME: write this
 1142 
 1143 =over
 1144 
 1145 =cut
 1146 
 1147 sub newGlobalProblem {
 1148   my ($self, @prototype) = @_;
 1149   return $self->{problem}->{record}->new(@prototype);
 1150 }
 1151 
 1152 sub listGlobalProblems {
 1153   my ($self, $setID) = @_;
 1154 
 1155   croak "listGlobalProblems: requires 1 arguments"
 1156     unless @_ == 2;
 1157   croak "listGlobalProblems: argument 1 must contain a set_id"
 1158     unless defined $setID;
 1159 
 1160   return map { $_->[1] }
 1161     $self->{problem}->list($setID, undef);
 1162 }
 1163 
 1164 sub addGlobalProblem {
 1165   my ($self, $GlobalProblem) = @_;
 1166 
 1167   croak "addGlobalProblem: requires 1 argument"
 1168     unless @_ == 2;
 1169   croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
 1170     unless ref $GlobalProblem eq $self->{problem}->{record};
 1171 
 1172   checkKeyfields($GlobalProblem);
 1173 
 1174   croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)"
 1175     if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
 1176   croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1177     unless $self->{set}->exists($GlobalProblem->set_id);
 1178 
 1179   return $self->{problem}->add($GlobalProblem);
 1180 }
 1181 
 1182 sub getGlobalProblem {
 1183   my ($self, $setID, $problemID) = @_;
 1184 
 1185   croak "getGlobalProblem: requires 2 arguments"
 1186     unless @_ == 3;
 1187   croak "getGlobalProblem: argument 1 must contain a set_id"
 1188     unless defined $setID;
 1189   croak "getGlobalProblem: argument 2 must contain a problem_id"
 1190     unless defined $problemID;
 1191 
 1192   return $self->{problem}->get($setID, $problemID);
 1193 }
 1194 
 1195 =item getGlobalProblems(@problemIDs)
 1196 
 1197 Return a list of global set records associated with the record IDs given. If
 1198 there is no record associated with a given record ID, that element of the list
 1199 will be undefined. @problemIDs consists of references to arrays in which the
 1200 first element is the set_id, and the second element is the problem_id.
 1201 
 1202 =cut
 1203 
 1204 sub getGlobalProblems {
 1205   my ($self, @problemIDs) = @_;
 1206 
 1207   #croak "getGlobalProblems: requires 1 or more argument"
 1208   # unless @_ >= 2;
 1209   foreach my $i (0 .. $#problemIDs) {
 1210     croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair"
 1211       unless defined $problemIDs[$i]
 1212              and ref $problemIDs[$i] eq "ARRAY"
 1213              and @{$problemIDs[$i]} == 2
 1214              and defined $problemIDs[$i]->[0]
 1215              and defined $problemIDs[$i]->[1];
 1216   }
 1217 
 1218   return $self->{problem}->gets(@problemIDs);
 1219 }
 1220 
 1221 sub putGlobalProblem {
 1222   my ($self, $GlobalProblem) = @_;
 1223 
 1224   croak "putGlobalProblem: requires 1 argument"
 1225     unless @_ == 2;
 1226   croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
 1227     unless ref $GlobalProblem eq $self->{problem}->{record};
 1228 
 1229   checkKeyfields($GlobalProblem);
 1230 
 1231   croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)"
 1232     unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
 1233   croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1234     unless $self->{set}->exists($GlobalProblem->set_id);
 1235 
 1236   return $self->{problem}->put($GlobalProblem);
 1237 }
 1238 
 1239 sub deleteGlobalProblem {
 1240   my ($self, $setID, $problemID) = @_;
 1241 
 1242   croak "deleteGlobalProblem: requires 2 arguments"
 1243     unless @_ == 3;
 1244   croak "deleteGlobalProblem: argument 1 must contain a set_id"
 1245     unless defined $setID or caller eq __PACKAGE__;
 1246   croak "deleteGlobalProblem: argument 2 must contain a problem_id"
 1247     unless defined $problemID or caller eq __PACKAGE__;
 1248 
 1249   $self->deleteUserProblem(undef, $setID, $problemID);
 1250   return $self->{problem}->delete($setID, $problemID);
 1251 }
 1252 
 1253 =back
 1254 
 1255 =cut
 1256 
 1257 ################################################################################
 1258 # problem_user functions
 1259 ################################################################################
 1260 
 1261 =head2 User-Specific Problem Methods
 1262 
 1263 FIXME: write this
 1264 
 1265 =over
 1266 
 1267 =cut
 1268 
 1269 sub newUserProblem {
 1270   my ($self, @prototype) = @_;
 1271   return $self->{problem_user}->{record}->new(@prototype);
 1272 }
 1273 
 1274 sub countProblemUsers {
 1275   my ($self, $setID, $problemID) = @_;
 1276 
 1277   croak "countProblemUsers: requires 2 arguments"
 1278     unless @_ == 3;
 1279   croak "countProblemUsers: argument 1 must contain a set_id"
 1280     unless defined $setID;
 1281   croak "countProblemUsers: argument 2 must contain a problem_id"
 1282     unless defined $problemID;
 1283 
 1284   # the slow way
 1285   #return scalar $self->{problem_user}->list(undef, $setID, $problemID);
 1286 
 1287   # the fast way
 1288   return $self->{problem_user}->count(undef, $setID, $problemID);
 1289 }
 1290 
 1291 sub listProblemUsers {
 1292   my ($self, $setID, $problemID) = @_;
 1293 
 1294   carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n"
 1295     unless wantarray;
 1296 
 1297   croak "listProblemUsers: requires 2 arguments"
 1298     unless @_ == 3;
 1299   croak "listProblemUsers: argument 1 must contain a set_id"
 1300     unless defined $setID;
 1301   croak "listProblemUsers: argument 2 must contain a problem_id"
 1302     unless defined $problemID;
 1303 
 1304   return map { $_->[0] } # extract user_id
 1305     $self->{problem_user}->list(undef, $setID, $problemID);
 1306 }
 1307 
 1308 sub listUserProblems {
 1309   my ($self, $userID, $setID) = @_;
 1310 
 1311   croak "listUserProblems: requires 2 arguments"
 1312     unless @_ == 3;
 1313   croak "listUserProblems: argument 1 must contain a user_id"
 1314     unless defined $userID;
 1315   croak "listUserProblems: argument 2 must contain a set_id"
 1316     unless defined $setID;
 1317 
 1318   return map { $_->[2] } # extract problem_id
 1319     $self->{problem_user}->list($userID, $setID, undef);
 1320 }
 1321 
 1322 sub addUserProblem {
 1323   my ($self, $UserProblem) = @_;
 1324 
 1325   croak "addUserProblem: requires 1 argument"
 1326     unless @_ == 2;
 1327   croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
 1328     unless ref $UserProblem eq $self->{problem_user}->{record};
 1329 
 1330   checkKeyfields($UserProblem);
 1331 
 1332   croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)"
 1333     if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
 1334   croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1335     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1336   croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
 1337     unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id);
 1338 
 1339   return $self->{problem_user}->add($UserProblem);
 1340 }
 1341 
 1342 sub getUserProblem {
 1343   my ($self, $userID, $setID, $problemID) = @_;
 1344 
 1345   croak "getUserProblem: requires 3 arguments"
 1346     unless @_ == 4;
 1347   croak "getUserProblem: argument 1 must contain a user_id"
 1348     unless defined $userID;
 1349   croak "getUserProblem: argument 2 must contain a set_id"
 1350     unless defined $setID;
 1351   croak "getUserProblem: argument 3 must contain a problem_id"
 1352     unless defined $problemID;
 1353 
 1354   return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0];
 1355 }
 1356 
 1357 =item getUserProblems(@userProblemIDs)
 1358 
 1359 Return a list of user set records associated with the user IDs given. If there
 1360 is no record associated with a given user ID, that element of the list will be
 1361 undefined. @userProblemIDs consists of references to arrays in which the first
 1362 element is the user_id, the second element is the set_id, and the third element
 1363 is the problem_id.
 1364 
 1365 =cut
 1366 
 1367 sub getUserProblems {
 1368   my ($self, @userProblemIDs) = @_;
 1369 
 1370   #croak "getUserProblems: requires 1 or more argument"
 1371   # unless @_ >= 2;
 1372   foreach my $i (0 .. $#userProblemIDs) {
 1373     croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
 1374       unless defined $userProblemIDs[$i]
 1375              and ref $userProblemIDs[$i] eq "ARRAY"
 1376              and @{$userProblemIDs[$i]} == 3
 1377              and defined $userProblemIDs[$i]->[0]
 1378              and defined $userProblemIDs[$i]->[1]
 1379              and defined $userProblemIDs[$i]->[2];
 1380   }
 1381 
 1382   return $self->{problem_user}->gets(@userProblemIDs);
 1383 }
 1384 
 1385 =item getAllUserProblems($userID, $setID)
 1386 
 1387 Returns a list of UserProblem objects representing all the problems in the
 1388 given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
 1389 more efficient than using listUserProblems and getUserProblems.
 1390 
 1391 =cut
 1392 
 1393 sub getAllUserProblems {
 1394   my ($self, $userID, $setID) = @_;
 1395 
 1396   croak "getUserProblem: requires 2 arguments"
 1397     unless @_ == 3;
 1398   croak "getUserProblem: argument 1 must contain a user_id"
 1399     unless defined $userID;
 1400   croak "getUserProblem: argument 2 must contain a set_id"
 1401     unless defined $setID;
 1402 
 1403   if ($self->{problem_user}->can("getAll")) {
 1404     return $self->{problem_user}->getAll($userID, $setID);
 1405   } else {
 1406     my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef);
 1407     return $self->{problem_user}->gets(@problemIDTriples);
 1408   }
 1409 }
 1410 
 1411 sub putUserProblem {
 1412   my ($self, $UserProblem) = @_;
 1413 
 1414   croak "putUserProblem: requires 1 argument"
 1415     unless @_ == 2;
 1416   croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
 1417     unless ref $UserProblem eq $self->{problem_user}->{record};
 1418 
 1419   checkKeyfields($UserProblem);
 1420 
 1421   croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1422     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1423   croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)"
 1424     unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
 1425   croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
 1426     unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id);
 1427 
 1428   return $self->{problem_user}->put($UserProblem);
 1429 }
 1430 
 1431 sub deleteUserProblem {
 1432   my ($self, $userID, $setID, $problemID) = @_;
 1433 
 1434   croak "getUserProblem: requires 3 arguments"
 1435     unless @_ == 4;
 1436   croak "getUserProblem: argument 1 must contain a user_id"
 1437     unless defined $userID or caller eq __PACKAGE__;
 1438   croak "getUserProblem: argument 2 must contain a set_id"
 1439     unless defined $setID or caller eq __PACKAGE__;
 1440   croak "getUserProblem: argument 3 must contain a problem_id"
 1441     unless defined $problemID or caller eq __PACKAGE__;
 1442 
 1443   return $self->{problem_user}->delete($userID, $setID, $problemID);
 1444 }
 1445 
 1446 =back
 1447 
 1448 =cut
 1449 
 1450 ################################################################################
 1451 # set+set_user functions
 1452 ################################################################################
 1453 
 1454 =head2 Set Merging Methods
 1455 
 1456 These functions combine a global set and a user set to create a merged set,
 1457 which is returned. Any field that is not defined in the user set is taken from
 1458 the global set. Merged sets have the same type as user sets.
 1459 
 1460 =over
 1461 
 1462 =cut
 1463 
 1464 sub getGlobalUserSet {
 1465   carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead";
 1466   return shift->getMergedSet(@_);
 1467 }
 1468 
 1469 =item getMergedSet($userID, $setID)
 1470 
 1471 Returns a merged set record associated with the record IDs given. If there is no
 1472 record associated with a given record ID, the undefined value is returned.
 1473 
 1474 =cut
 1475 
 1476 sub getMergedSet {
 1477   my ($self, $userID, $setID) = @_;
 1478 
 1479   croak "getMergedSet: requires 2 arguments"
 1480     unless @_ == 3;
 1481   croak "getMergedSet: argument 1 must contain a user_id"
 1482     unless defined $userID;
 1483   croak "getMergedSet: argument 2 must contain a set_id"
 1484     unless defined $setID;
 1485 
 1486   return ( $self->getMergedSets([$userID, $setID]) )[0];
 1487 }
 1488 
 1489 =item getMegedSets(@userSetIDs)
 1490 
 1491 Return a list of merged set records associated with the record IDs given. If
 1492 there is no record associated with a given record ID, that element of the list
 1493 will be undefined. @userSetIDs consists of references to arrays in which the
 1494 first element is the user_id and the second element is the set_id.
 1495 
 1496 =cut
 1497 
 1498 sub getMergedSets {
 1499   my ($self, @userSetIDs) = @_;
 1500 
 1501   #croak "getMergedSets: requires 1 or more argument"
 1502   # unless @_ >= 2;
 1503   foreach my $i (0 .. $#userSetIDs) {
 1504     croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair"
 1505       unless defined $userSetIDs[$i]
 1506              and ref $userSetIDs[$i] eq "ARRAY"
 1507              and @{$userSetIDs[$i]} == 2
 1508              and defined $userSetIDs[$i]->[0]
 1509              and defined $userSetIDs[$i]->[1];
 1510   }
 1511 
 1512   # a horrible, terrible hack ;)
 1513   if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash"
 1514       and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
 1515     #warn __PACKAGE__.": using a terrible hack.\n";
 1516     $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer);
 1517     my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs);
 1518     $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer);
 1519     return @MergedSets;
 1520   }
 1521 
 1522   $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer);
 1523   my @UserSets = $self->getUserSets(@userSetIDs); # checked
 1524 
 1525   $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer);
 1526   my @globalSetIDs = map { $_->[1] } @userSetIDs;
 1527   $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer);
 1528   my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked
 1529 
 1530   $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer);
 1531   my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
 1532   my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
 1533 
 1534   $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 1535   for (my $i = 0; $i < @UserSets; $i++) {
 1536     my $UserSet = $UserSets[$i];
 1537     my $GlobalSet = $GlobalSets[$i];
 1538     next unless defined $UserSet and defined $GlobalSet;
 1539     foreach my $field (@commonFields) {
 1540       next if defined $UserSet->$field;
 1541       $UserSet->$field($GlobalSet->$field);
 1542     }
 1543   }
 1544   $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 1545 
 1546   return @UserSets;
 1547 }
 1548 
 1549 =back
 1550 
 1551 =cut
 1552 
 1553 ################################################################################
 1554 # problem+problem_user functions
 1555 ################################################################################
 1556 
 1557 =head2 Problem Merging Methods
 1558 
 1559 These functions combine a global problem and a user problem to create a merged
 1560 problem, which is returned. Any field that is not defined in the user problem is
 1561 taken from the global problem. Merged problems have the same type as user
 1562 problems.
 1563 
 1564 =over
 1565 
 1566 =cut
 1567 
 1568 sub getGlobalUserProblem {
 1569   carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead";
 1570   return shift->getMergedProblem(@_);
 1571 }
 1572 
 1573 =item getMergedProblem($userID, $setID, $problemID)
 1574 
 1575 Returns a merged problem record associated with the record IDs given. If there
 1576 is no record associated with a given record ID, the undefined value is returned.
 1577 
 1578 =cut
 1579 
 1580 sub getMergedProblem {
 1581   my ($self, $userID, $setID, $problemID) = @_;
 1582 
 1583   croak "getGlobalUserSet: requires 3 arguments"
 1584     unless @_ == 4;
 1585   croak "getGlobalUserSet: argument 1 must contain a user_id"
 1586     unless defined $userID;
 1587   croak "getGlobalUserSet: argument 2 must contain a set_id"
 1588     unless defined $setID;
 1589   croak "getGlobalUserSet: argument 3 must contain a problem_id"
 1590     unless defined $problemID;
 1591 
 1592   return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0];
 1593 }
 1594 
 1595 =item getMergedProblems(@userProblemIDs)
 1596 
 1597 Return a list of merged problem records associated with the record IDs given. If
 1598 there is no record associated with a given record ID, that element of the list
 1599 will be undefined. @userProblemIDs consists of references to arrays in which the
 1600 first element is the user_id, the second element is the set_id, and the third
 1601 element is the problem_id.
 1602 
 1603 =cut
 1604 
 1605 sub getMergedProblems {
 1606   my ($self, @userProblemIDs) = @_;
 1607 
 1608   #croak "getMergedProblems: requires 1 or more argument"
 1609   # unless @_ >= 2;
 1610   foreach my $i (0 .. $#userProblemIDs) {
 1611     croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
 1612       unless defined $userProblemIDs[$i]
 1613              and ref $userProblemIDs[$i] eq "ARRAY"
 1614              and @{$userProblemIDs[$i]} == 3
 1615              and defined $userProblemIDs[$i]->[0]
 1616              and defined $userProblemIDs[$i]->[1]
 1617              and defined $userProblemIDs[$i]->[2];
 1618   }
 1619 
 1620   $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer);
 1621   my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked
 1622 
 1623   $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer);
 1624   my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs;
 1625   $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer);
 1626   my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked
 1627 
 1628   $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer);
 1629   my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
 1630   my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
 1631 
 1632   $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 1633   for (my $i = 0; $i < @UserProblems; $i++) {
 1634     my $UserProblem = $UserProblems[$i];
 1635     my $GlobalProblem = $GlobalProblems[$i];
 1636     next unless defined $UserProblem and defined $GlobalProblem;
 1637     foreach my $field (@commonFields) {
 1638       next if defined $UserProblem->$field;
 1639       $UserProblem->$field($GlobalProblem->$field);
 1640     }
 1641   }
 1642   $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 1643 
 1644   return @UserProblems;
 1645 }
 1646 
 1647 =back
 1648 
 1649 =cut
 1650 
 1651 ################################################################################
 1652 # debugging
 1653 ################################################################################
 1654 
 1655 #sub dumpDB($$) {
 1656 # my ($self, $table) = @_;
 1657 # return $self->{$table}->dumpDB();
 1658 #}
 1659 
 1660 ################################################################################
 1661 # utilities
 1662 ################################################################################
 1663 
 1664 sub checkKeyfields($) {
 1665   my ($Record) = @_;
 1666   foreach my $keyfield ($Record->KEYFIELDS) {
 1667     my $value = $Record->$keyfield;
 1668     croak "checkKeyfields: $keyfield is empty"
 1669       unless defined $value and $value ne "";
 1670 
 1671     if ($keyfield eq "problem_id") {
 1672       croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])"
 1673         unless $value =~ m/^\d*$/;
 1674     } else {
 1675       croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])"
 1676         unless $value =~ m/^[\w-]*$/;
 1677     }
 1678   }
 1679 }
 1680 
 1681 =head1 AUTHOR
 1682 
 1683 Written by Sam Hathaway, sh002i (at) math.rochester.edu.
 1684 
 1685 =cut
 1686 
 1687 1;