View of /branches/rel-2-1-a1/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 
 1123   $self->deleteGlobalProblem($setID, undef);
 1124   return $self->{set}->delete($setID);
 1125 }
 1126 
 1127 =back
 1128 
 1129 =cut
 1130 
 1131 ################################################################################
 1132 # set_user functions
 1133 ################################################################################
 1134 
 1135 =head2 User-Specific Set Methods
 1136 
 1137 FIXME: write this
 1138 
 1139 =over
 1140 
 1141 =cut
 1142 
 1143 sub newUserSet {
 1144   my ($self, @prototype) = @_;
 1145   return $self->{set_user}->{record}->new(@prototype);
 1146 }
 1147 
 1148 sub countSetUsers {
 1149   my ($self, $setID) = @_;
 1150 
 1151   croak "listSetUsers: requires 1 argument"
 1152     unless @_ == 2;
 1153   croak "listSetUsers: argument 1 must contain a set_id"
 1154     unless defined $setID;
 1155 
 1156   # inefficient way
 1157   #return scalar $self->{set_user}->list(undef, $setID);
 1158 
 1159   # efficient way
 1160   return $self->{set_user}->count(undef, $setID);
 1161 }
 1162 
 1163 sub listSetUsers {
 1164   my ($self, $setID) = @_;
 1165 
 1166   carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n"
 1167     unless wantarray;
 1168 
 1169   croak "listSetUsers: requires 1 argument"
 1170     unless @_ == 2;
 1171   croak "listSetUsers: argument 1 must contain a set_id"
 1172     unless defined $setID;
 1173 
 1174   return map { $_->[0] } # extract user_id
 1175     $self->{set_user}->list(undef, $setID);
 1176 }
 1177 
 1178 sub listUserSets {
 1179   my ($self, $userID) = @_;
 1180 
 1181   croak "listUserSets: requires 1 argument"
 1182     unless @_ == 2;
 1183   croak "listUserSets: argument 1 must contain a user_id"
 1184     unless defined $userID;
 1185 
 1186   return map { $_->[1] } # extract set_id
 1187     $self->{set_user}->list($userID, undef);
 1188 }
 1189 
 1190 sub addUserSet {
 1191   my ($self, $UserSet) = @_;
 1192 
 1193   croak "addUserSet: requires 1 argument"
 1194     unless @_ == 2;
 1195   croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1196     unless ref $UserSet eq $self->{set_user}->{record};
 1197 
 1198   checkKeyfields($UserSet);
 1199 
 1200   croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"
 1201     if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1202   croak "addUserSet: user ", $UserSet->user_id, " not found"
 1203     unless $self->{user}->exists($UserSet->user_id);
 1204   croak "addUserSet: set ", $UserSet->set_id, " not found"
 1205     unless $self->{set}->exists($UserSet->set_id);
 1206 
 1207   return $self->{set_user}->add($UserSet);
 1208 }
 1209 
 1210 sub addVersionedUserSet {
 1211     my ($self, $UserSet) = @_;
 1212 
 1213 # this is the same as addUserSet,allowing for set names of the form setID,vN
 1214 
 1215     croak "addVersionedUserSet: requires 1 argument"
 1216   unless @_ == 2;
 1217     croak "addVersionedUserSet: argument 1 must be of type ",
 1218         $self->{set_user}->{record}
 1219   unless ref $UserSet eq $self->{set_user}->{record};
 1220 
 1221 # $versioned is a flag that we send in to allow commas in the set name
 1222 #    for versioned sets
 1223     my $versioned = 1;
 1224     checkKeyfields($UserSet, $versioned);
 1225     my ($nonVersionedSetName) = ($UserSet->set_id =~ /^(.*),v\d+$/);
 1226 
 1227     croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"
 1228   if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1229     croak "addUserSet: user ", $UserSet->user_id, " not found"
 1230   unless $self->{user}->exists($UserSet->user_id);
 1231 # croak "addUserSet: set ", $UserSet->set_id, " not found"
 1232 #   unless $self->{set}->exists($UserSet->set_id);
 1233 # here the appropriate check is whether a global set of the nonversioned set
 1234 #    name exists
 1235     croak "addVersionedUserSet: set ", $nonVersionedSetName, " not found"
 1236   unless $self->{set}->exists( $nonVersionedSetName );
 1237 
 1238     return $self->{set_user}->add($UserSet);
 1239 }
 1240 
 1241 sub getUserSet {
 1242   my ($self, $userID, $setID) = @_;
 1243 
 1244   croak "getUserSet: requires 2 arguments"
 1245     unless @_ == 3;
 1246   croak "getUserSet: argument 1 must contain a user_id"
 1247     unless defined $userID;
 1248   croak "getUserSet: argument 2 must contain a set_id"
 1249     unless defined $setID;
 1250 
 1251   #return $self->{set_user}->get($userID, $setID);
 1252   return ( $self->getUserSets([$userID, $setID]) )[0];
 1253 }
 1254 
 1255 =item getUserSets(@userSetIDs)
 1256 
 1257 Return a list of user set records associated with the record IDs given. If there
 1258 is no record associated with a given record ID, that element of the list will be
 1259 undefined. @userProblemIDs consists of references to arrays in which the first
 1260 element is the user_id and the second element is the set_id.
 1261 
 1262 =cut
 1263 
 1264 sub getUserSets {
 1265   my ($self, @userSetIDs) = @_;
 1266 
 1267   #croak "getUserSets: requires 1 or more argument"
 1268   # unless @_ >= 2;
 1269   foreach my $i (0 .. $#userSetIDs) {
 1270     croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair"
 1271       unless defined $userSetIDs[$i]
 1272              and ref $userSetIDs[$i] eq "ARRAY"
 1273              and @{$userSetIDs[$i]} == 2
 1274              and defined $userSetIDs[$i]->[0]
 1275              and defined $userSetIDs[$i]->[1];
 1276   }
 1277 
 1278   return $self->{set_user}->gets(@userSetIDs);
 1279 }
 1280 
 1281 sub getUserSetVersions {
 1282     my ( $self, $uid, $sid, $versionNum ) = @_;
 1283 # in:  $uid is a userID, $sid is a setID, and $versionNum is a version number
 1284 #      userID has set versions 1 through $versionNum defined
 1285 # out: an array of user set objects is returned for the indicated version
 1286 #      numbers
 1287 
 1288     croak "getUserSetVersions: requires three arguments, userID, setID, and " .
 1289   "versionNum" if ( @_ < 3 );
 1290 
 1291     my @userSetIDs = ();
 1292     foreach my $i ( 1 .. $versionNum ) {
 1293   push( @userSetIDs, [ $uid, "$sid,v$i" ] );
 1294     }
 1295 
 1296     return $self->getUserSets( @userSetIDs );
 1297 }
 1298 
 1299 sub putUserSet {
 1300   my ($self, $UserSet) = @_;
 1301 
 1302   croak "putUserSet: requires 1 argument"
 1303     unless @_ == 2;
 1304   croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1305     unless ref $UserSet eq $self->{set_user}->{record};
 1306 
 1307   checkKeyfields($UserSet);
 1308 
 1309   croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)"
 1310     unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1311   croak "putUserSet: user ", $UserSet->user_id, " not found"
 1312     unless $self->{user}->exists($UserSet->user_id);
 1313   croak "putUserSet: set ", $UserSet->set_id, " not found"
 1314     unless $self->{set}->exists($UserSet->set_id);
 1315 
 1316   return $self->{set_user}->put($UserSet);
 1317 }
 1318 
 1319 sub putVersionedUserSet {
 1320     my ($self, $UserSet) = @_;
 1321 # this exists separate from putUserSet only so that we can make it harder
 1322 #   for anyone else to use commas in setIDs
 1323 
 1324     croak "putUserSet: requires 1 argument"
 1325   unless @_ == 2;
 1326     croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record}
 1327   unless ref $UserSet eq $self->{set_user}->{record};
 1328 
 1329     # versioned allows us to have a wacked out setID
 1330     my $versioned = 1;
 1331     checkKeyfields($UserSet, $versioned);
 1332 
 1333     my $nonVersionedSetID = $UserSet->set_id;
 1334     $nonVersionedSetID =~ s/,v\d+$//;
 1335 #    my ($nonVersionedSetID) = ($UserSet->set_id =~ /^(.*)(,v\d+)?$/);
 1336     croak "putVersionedUserSet: user set not found (perhaps you meant " .
 1337         "to use addUserSet?)"
 1338   unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
 1339     croak "putVersionedUserSet: user ", $UserSet->user_id, " not found"
 1340   unless $self->{user}->exists($UserSet->user_id);
 1341     croak "putVersionedUserSet: set $nonVersionedSetID not found"
 1342   unless $self->{set}->exists($nonVersionedSetID);
 1343 
 1344     return $self->{set_user}->put($UserSet);
 1345 }
 1346 
 1347 sub deleteUserSet {
 1348   my ($self, $userID, $setID, $skipVersionDel) = @_;
 1349 
 1350   croak "getUserSet: requires 2 arguments"
 1351     unless @_ == 3 or @_ == 4;
 1352   croak "getUserSet: argument 1 must contain a user_id"
 1353     unless defined $userID or caller eq __PACKAGE__;
 1354   croak "getUserSet: argument 2 must contain a set_id"
 1355     unless defined $userID or caller eq __PACKAGE__;
 1356 
 1357   $self->deleteUserSetVersions( $userID, $setID )
 1358       if ( defined($setID) && ! ( defined($skipVersionDel) &&
 1359      $skipVersionDel ) );
 1360   $self->deleteUserProblem($userID, $setID, undef);
 1361   return $self->{set_user}->delete($userID, $setID);
 1362 }
 1363 
 1364 sub deleteUserSetVersions {
 1365     my ($self, $userID, $setID) = @_;
 1366 
 1367 # this only gets called from deleteUserSet, so we don't worry about $setID
 1368 #    not being defined
 1369 
 1370 # make a list of all users to delete set versions for.  if we have a userID,
 1371 #    then just delete versions for that user
 1372     my @allUsers = ();
 1373     if ( defined( $userID ) ) {
 1374   push( @allUsers, $userID );
 1375     } else {
 1376 # otherwise, get a list of all users to whom the set is assigned, and delete
 1377 #    all versions for all of them
 1378   @allUsers = $self->listSetUsers( $setID );
 1379     }
 1380 
 1381 # skip version deletion when calling deleteUserSet from here
 1382     my $skipVersionDel = 1;
 1383 
 1384 # go through each userID and delete all versions of the set for each
 1385     foreach my $uid ( @allUsers ) {
 1386   my $setVersionNumber = $self->getUserSetVersionNumber($uid, $setID);
 1387   if ( $setVersionNumber ) {
 1388       for ( my $i=1; $i<=$setVersionNumber; $i++ ) {
 1389     eval { $self->deleteUserSet( $uid, "$setID,v$i",
 1390                $skipVersionDel ) };
 1391     return $@ if ( $@ );
 1392       }
 1393   }
 1394     }
 1395 }
 1396 
 1397 sub getUserSetVersionNumber {
 1398     my ( $self, $uid, $sid ) = @_;
 1399 # in:  uid and sid are user and set ids.  the setID is the 'global' setID
 1400 #      for the user, not a versioned value
 1401 # out: the latest version number of the set that has been assigned to the
 1402 #      user is returned.
 1403 
 1404     croak "getUserSetVersionNumber: requires 2 arguments, a user and set ID"
 1405   unless @_ == 3 && defined $uid && defined $sid;
 1406 
 1407 # is there a better way of doing this?  it seems like we need to know the
 1408 #    number of versions to be able to do a mass get.  something like a get
 1409 #    where sid looks like $sid,v\d would work... but is incompatible w/gdbm
 1410 #    my $i=1;
 1411 #    if ( $self->{set_user}->exists( $uid, $sid ) ) {
 1412 # while ( $self->{set_user}->exists( $uid, "$sid,v$i" ) ) {
 1413 #     $i++;
 1414 # }
 1415 #    }
 1416 #    return ($i-1);
 1417 # or, we can just get all sets for the user and figure out which of them
 1418 #    look like the sid.
 1419     my @allSetIDs = $self->listUserSets( $uid );
 1420     my @setIDs = sort( grep { /^$sid,v\d+$/ } @allSetIDs );
 1421 #    my $lastSetID = ( sort( @setIDs ) )[-1];
 1422     my $lastSetID = $setIDs[-1];
 1423 # I think this should be defined, unless the set hasn't been assigned to
 1424 #    the user at all, which we hope wouldn't have happened at this juncture
 1425     if ( not defined($lastSetID) ) {
 1426   return 0;
 1427     } else {
 1428   # we have to deal with the fact that 10 sorts to precede 2 (etc.)
 1429   my @vNums = map { /^$sid,v(\d+)$/ } @setIDs;
 1430   return ( ( sort {$a<=>$b} @vNums )[-1] );
 1431     }
 1432 }
 1433 
 1434 =back
 1435 
 1436 =cut
 1437 
 1438 ################################################################################
 1439 # problem functions
 1440 ################################################################################
 1441 
 1442 =head2 Global Problem Methods
 1443 
 1444 FIXME: write this
 1445 
 1446 =over
 1447 
 1448 =cut
 1449 
 1450 sub newGlobalProblem {
 1451   my ($self, @prototype) = @_;
 1452   return $self->{problem}->{record}->new(@prototype);
 1453 }
 1454 
 1455 sub listGlobalProblems {
 1456   my ($self, $setID) = @_;
 1457 
 1458   croak "listGlobalProblems: requires 1 arguments"
 1459     unless @_ == 2;
 1460   croak "listGlobalProblems: argument 1 must contain a set_id"
 1461     unless defined $setID;
 1462 
 1463   return map { $_->[1] }
 1464     $self->{problem}->list($setID, undef);
 1465 }
 1466 
 1467 sub addGlobalProblem {
 1468   my ($self, $GlobalProblem) = @_;
 1469 
 1470   croak "addGlobalProblem: requires 1 argument"
 1471     unless @_ == 2;
 1472   croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
 1473     unless ref $GlobalProblem eq $self->{problem}->{record};
 1474 
 1475   checkKeyfields($GlobalProblem);
 1476 
 1477   croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)"
 1478     if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
 1479   croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1480     unless $self->{set}->exists($GlobalProblem->set_id);
 1481 
 1482   return $self->{problem}->add($GlobalProblem);
 1483 }
 1484 
 1485 sub getGlobalProblem {
 1486   my ($self, $setID, $problemID) = @_;
 1487 
 1488   croak "getGlobalProblem: requires 2 arguments"
 1489     unless @_ == 3;
 1490   croak "getGlobalProblem: argument 1 must contain a set_id"
 1491     unless defined $setID;
 1492   croak "getGlobalProblem: argument 2 must contain a problem_id"
 1493     unless defined $problemID;
 1494 
 1495   return $self->{problem}->get($setID, $problemID);
 1496 }
 1497 
 1498 =item getGlobalProblems(@problemIDs)
 1499 
 1500 Return a list of global set records associated with the record IDs given. If
 1501 there is no record associated with a given record ID, that element of the list
 1502 will be undefined. @problemIDs consists of references to arrays in which the
 1503 first element is the set_id, and the second element is the problem_id.
 1504 
 1505 =cut
 1506 
 1507 sub getGlobalProblems {
 1508   my ($self, @problemIDs) = @_;
 1509 
 1510   #croak "getGlobalProblems: requires 1 or more argument"
 1511   # unless @_ >= 2;
 1512   foreach my $i (0 .. $#problemIDs) {
 1513     croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair"
 1514       unless defined $problemIDs[$i]
 1515              and ref $problemIDs[$i] eq "ARRAY"
 1516              and @{$problemIDs[$i]} == 2
 1517              and defined $problemIDs[$i]->[0]
 1518              and defined $problemIDs[$i]->[1];
 1519   }
 1520 
 1521   return $self->{problem}->gets(@problemIDs);
 1522 }
 1523 
 1524 =item getAllGlobalProblems($setID)
 1525 
 1526 Returns a list of Problem objects representing all the problems in the given
 1527 global set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
 1528 more efficient than using listGlobalProblems and getGlobalProblems.
 1529 
 1530 =cut
 1531 
 1532 sub getAllGlobalProblems {
 1533   my ($self, $setID) = @_;
 1534 
 1535   croak "getAllGlobalProblems: requires 1 arguments"
 1536     unless @_ == 2;
 1537   croak "getAllGlobalProblems: argument 1 must contain a set_id"
 1538     unless defined $setID;
 1539 
 1540   if ($self->{problem}->can("getAll")) {
 1541     return $self->{problem}->getAll($setID);
 1542   } else {
 1543     my @problemIDPairs = $self->{problem}->list($setID, undef);
 1544     return $self->{problem}->gets(@problemIDPairs);
 1545   }
 1546 }
 1547 
 1548 sub putGlobalProblem {
 1549   my ($self, $GlobalProblem) = @_;
 1550 
 1551   croak "putGlobalProblem: requires 1 argument"
 1552     unless @_ == 2;
 1553   croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
 1554     unless ref $GlobalProblem eq $self->{problem}->{record};
 1555 
 1556   checkKeyfields($GlobalProblem);
 1557 
 1558   croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)"
 1559     unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
 1560   croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found"
 1561     unless $self->{set}->exists($GlobalProblem->set_id);
 1562 
 1563   return $self->{problem}->put($GlobalProblem);
 1564 }
 1565 
 1566 sub deleteGlobalProblem {
 1567   my ($self, $setID, $problemID) = @_;
 1568 
 1569   croak "deleteGlobalProblem: requires 2 arguments"
 1570     unless @_ == 3;
 1571   croak "deleteGlobalProblem: argument 1 must contain a set_id"
 1572     unless defined $setID or caller eq __PACKAGE__;
 1573   croak "deleteGlobalProblem: argument 2 must contain a problem_id"
 1574     unless defined $problemID or caller eq __PACKAGE__;
 1575 
 1576   $self->deleteUserProblem(undef, $setID, $problemID);
 1577   return $self->{problem}->delete($setID, $problemID);
 1578 }
 1579 
 1580 =back
 1581 
 1582 =cut
 1583 
 1584 ################################################################################
 1585 # problem_user functions
 1586 ################################################################################
 1587 
 1588 =head2 User-Specific Problem Methods
 1589 
 1590 FIXME: write this
 1591 
 1592 =over
 1593 
 1594 =cut
 1595 
 1596 sub newUserProblem {
 1597   my ($self, @prototype) = @_;
 1598   return $self->{problem_user}->{record}->new(@prototype);
 1599 }
 1600 
 1601 sub countProblemUsers {
 1602   my ($self, $setID, $problemID) = @_;
 1603 
 1604   croak "countProblemUsers: requires 2 arguments"
 1605     unless @_ == 3;
 1606   croak "countProblemUsers: argument 1 must contain a set_id"
 1607     unless defined $setID;
 1608   croak "countProblemUsers: argument 2 must contain a problem_id"
 1609     unless defined $problemID;
 1610 
 1611   # the slow way
 1612   #return scalar $self->{problem_user}->list(undef, $setID, $problemID);
 1613 
 1614   # the fast way
 1615   return $self->{problem_user}->count(undef, $setID, $problemID);
 1616 }
 1617 
 1618 sub listProblemUsers {
 1619   my ($self, $setID, $problemID) = @_;
 1620 
 1621   carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n"
 1622     unless wantarray;
 1623 
 1624   croak "listProblemUsers: requires 2 arguments"
 1625     unless @_ == 3;
 1626   croak "listProblemUsers: argument 1 must contain a set_id"
 1627     unless defined $setID;
 1628   croak "listProblemUsers: argument 2 must contain a problem_id"
 1629     unless defined $problemID;
 1630 
 1631   return map { $_->[0] } # extract user_id
 1632     $self->{problem_user}->list(undef, $setID, $problemID);
 1633 }
 1634 
 1635 sub listUserProblems {
 1636   my ($self, $userID, $setID) = @_;
 1637 
 1638   croak "listUserProblems: requires 2 arguments"
 1639     unless @_ == 3;
 1640   croak "listUserProblems: argument 1 must contain a user_id"
 1641     unless defined $userID;
 1642   croak "listUserProblems: argument 2 must contain a set_id"
 1643     unless defined $setID;
 1644 
 1645   return map { $_->[2] } # extract problem_id
 1646     $self->{problem_user}->list($userID, $setID, undef);
 1647 }
 1648 
 1649 sub addUserProblem {
 1650   my ($self, $UserProblem) = @_;
 1651 
 1652   croak "addUserProblem: requires 1 argument"
 1653     unless @_ == 2;
 1654   croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
 1655     unless ref $UserProblem eq $self->{problem_user}->{record};
 1656 
 1657   my $setID = $UserProblem->set_id;
 1658   if ( $setID =~ /^(.*),v\d+/ ) {  # then it's a versioned set
 1659       $setID = $1;
 1660       checkKeyfields($UserProblem, 1);
 1661   } else {
 1662       checkKeyfields($UserProblem);
 1663   }
 1664 
 1665   croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)"
 1666     if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
 1667   croak "addUserProblem: user set $setID for user ", $UserProblem->user_id, " not found"
 1668     unless $self->{set_user}->exists($UserProblem->user_id, $setID);
 1669   croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $setID, " not found"
 1670     unless $self->{problem}->exists($setID, $UserProblem->problem_id);
 1671 
 1672   return $self->{problem_user}->add($UserProblem);
 1673 }
 1674 
 1675 sub getUserProblem {
 1676   my ($self, $userID, $setID, $problemID) = @_;
 1677 
 1678   croak "getUserProblem: requires 3 arguments"
 1679     unless @_ == 4;
 1680   croak "getUserProblem: argument 1 must contain a user_id"
 1681     unless defined $userID;
 1682   croak "getUserProblem: argument 2 must contain a set_id"
 1683     unless defined $setID;
 1684   croak "getUserProblem: argument 3 must contain a problem_id"
 1685     unless defined $problemID;
 1686 
 1687   return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0];
 1688 }
 1689 
 1690 =item getUserProblems(@userProblemIDs)
 1691 
 1692 Return a list of user set records associated with the user IDs given. If there
 1693 is no record associated with a given user ID, that element of the list will be
 1694 undefined. @userProblemIDs consists of references to arrays in which the first
 1695 element is the user_id, the second element is the set_id, and the third element
 1696 is the problem_id.
 1697 
 1698 =cut
 1699 
 1700 sub getUserProblems {
 1701   my ($self, @userProblemIDs) = @_;
 1702 
 1703   #croak "getUserProblems: requires 1 or more argument"
 1704   # unless @_ >= 2;
 1705   foreach my $i (0 .. $#userProblemIDs) {
 1706     croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
 1707       unless defined $userProblemIDs[$i]
 1708              and ref $userProblemIDs[$i] eq "ARRAY"
 1709              and @{$userProblemIDs[$i]} == 3
 1710              and defined $userProblemIDs[$i]->[0]
 1711              and defined $userProblemIDs[$i]->[1]
 1712              and defined $userProblemIDs[$i]->[2];
 1713   }
 1714 
 1715   return $self->{problem_user}->gets(@userProblemIDs);
 1716 }
 1717 
 1718 =item getAllUserProblems($userID, $setID)
 1719 
 1720 Returns a list of UserProblem objects representing all the problems in the
 1721 given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
 1722 more efficient than using listUserProblems and getUserProblems.
 1723 
 1724 =cut
 1725 
 1726 sub getAllUserProblems {
 1727   my ($self, $userID, $setID) = @_;
 1728 
 1729   croak "getAllUserProblems: requires 2 arguments"
 1730     unless @_ == 3;
 1731   croak "getAllUserProblems: argument 1 must contain a user_id"
 1732     unless defined $userID;
 1733   croak "getAllUserProblems: argument 2 must contain a set_id"
 1734     unless defined $setID;
 1735 
 1736   if ($self->{problem_user}->can("getAll")) {
 1737     return $self->{problem_user}->getAll($userID, $setID);
 1738   } else {
 1739     my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef);
 1740     return $self->{problem_user}->gets(@problemIDTriples);
 1741   }
 1742 }
 1743 
 1744 sub putUserProblem {
 1745   my ($self, $UserProblem, $versioned) = @_;
 1746 # $versioned is an optional argument which lets us slip versioned setIDs
 1747 #    through checkKeyfields.  this makes the first croak message a little
 1748 #    disingenuous, of course.
 1749 
 1750   croak "putUserProblem: requires 1 argument"
 1751     unless @_ == 2 or @_ == 3;
 1752   croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
 1753     unless ref $UserProblem eq $self->{problem_user}->{record};
 1754 
 1755   checkKeyfields($UserProblem, $versioned);
 1756 
 1757   croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
 1758     unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
 1759   croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)"
 1760     unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
 1761 
 1762 # allow versioned set names when $versioned is defined and true
 1763   my $unversionedSetID = $UserProblem->set_id;
 1764   $unversionedSetID =~ s/,v\d+$// if ( defined($versioned) && $versioned );
 1765   croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
 1766     unless $self->{problem}->exists($unversionedSetID, $UserProblem->problem_id);
 1767 
 1768   return $self->{problem_user}->put($UserProblem);
 1769 }
 1770 
 1771 sub deleteUserProblem {
 1772   my ($self, $userID, $setID, $problemID) = @_;
 1773 
 1774   croak "getUserProblem: requires 3 arguments"
 1775     unless @_ == 4;
 1776   croak "getUserProblem: argument 1 must contain a user_id"
 1777     unless defined $userID or caller eq __PACKAGE__;
 1778   croak "getUserProblem: argument 2 must contain a set_id"
 1779     unless defined $setID or caller eq __PACKAGE__;
 1780   croak "getUserProblem: argument 3 must contain a problem_id"
 1781     unless defined $problemID or caller eq __PACKAGE__;
 1782 
 1783   return $self->{problem_user}->delete($userID, $setID, $problemID);
 1784 }
 1785 
 1786 =back
 1787 
 1788 =cut
 1789 
 1790 ################################################################################
 1791 # set+set_user functions
 1792 ################################################################################
 1793 
 1794 =head2 Set Merging Methods
 1795 
 1796 These functions combine a global set and a user set to create a merged set,
 1797 which is returned. Any field that is not defined in the user set is taken from
 1798 the global set. Merged sets have the same type as user sets.
 1799 
 1800 =over
 1801 
 1802 =cut
 1803 
 1804 sub getGlobalUserSet {
 1805   carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead";
 1806   return shift->getMergedSet(@_);
 1807 }
 1808 
 1809 =item getMergedSet($userID, $setID)
 1810 
 1811 Returns a merged set record associated with the record IDs given. If there is no
 1812 record associated with a given record ID, the undefined value is returned.
 1813 
 1814 =cut
 1815 
 1816 sub getMergedSet {
 1817   my ($self, $userID, $setID) = @_;
 1818 
 1819   croak "getMergedSet: requires 2 arguments"
 1820     unless @_ == 3;
 1821   croak "getMergedSet: argument 1 must contain a user_id"
 1822     unless defined $userID;
 1823   croak "getMergedSet: argument 2 must contain a set_id"
 1824     unless defined $setID;
 1825 
 1826   return ( $self->getMergedSets([$userID, $setID]) )[0];
 1827 }
 1828 
 1829 sub getMergedVersionedSet {
 1830     my ( $self, $userID, $setID, $versionNum ) = @_;
 1831 #
 1832 # getMergedVersionedSet( self, uid, sid [, versionNum] )
 1833 #    in:  userID uid, setID sid, and optionally version number versionNum
 1834 #    out: the merged set version for the user; if versionNum is specified,
 1835 #         return that set version and otherwise the latest version.  if
 1836 #         no versioned set exists for the user, return undef.
 1837 #    note that sid can be setid,vN, thereby specifying the version number
 1838 #      explicitly.  if this is the case, any specified versionNum is ignored
 1839 # we'd like to use getMergedSet to do the dirty work here, but that runs
 1840 #    into problems because we want to merge with both the template set
 1841 #    (that is, the userSet setID) and the global set
 1842 
 1843     croak "getMergedVersionedSet: requires at least two arguments, a userID " .
 1844   "and setID (missing setID)" if ( @_ < 3 || ! defined( $setID ) );
 1845 
 1846     my $versionedSetID = $setID;
 1847 
 1848     if ( ( ! defined($versionNum) || ! $versionNum ) && $setID !~ /,v\d+$/ ) {
 1849   $versionNum = $self->getUserSetVersionNumber( $userID, $setID );
 1850 
 1851   if ( ! $versionNum ) {
 1852       return undef;
 1853   } else {
 1854       $versionedSetID .= ",v$versionNum";
 1855   }
 1856     } elsif ( defined($versionNum) && $versionNum ) {
 1857   $versionedSetID = ($setID =~ /,v\d+$/ ? $setID : "$setID,v$versionNum");
 1858     } else {  # the last case is that $setID =~ /,v\d+$/
 1859   $setID =~ s/,v\d+//;
 1860     }
 1861 
 1862     croak "getMergedVersionedSet: requires at least two arguments, a userID " .
 1863   "and setID (missing userID)" if ( ! defined( $userID ) );
 1864 
 1865     return ( $self->getMergedVersionedSets( [$userID, $setID,
 1866                $versionedSetID] ) )[0];
 1867 }
 1868 
 1869 
 1870 =item getMegedSets(@userSetIDs)
 1871 
 1872 Return a list of merged set records associated with the record IDs given. If
 1873 there is no record associated with a given record ID, that element of the list
 1874 will be undefined. @userSetIDs consists of references to arrays in which the
 1875 first element is the user_id and the second element is the set_id.
 1876 
 1877 =cut
 1878 
 1879 sub getMergedSets {
 1880   my ($self, @userSetIDs) = @_;
 1881 
 1882   #croak "getMergedSets: requires 1 or more argument"
 1883   # unless @_ >= 2;
 1884   foreach my $i (0 .. $#userSetIDs) {
 1885     croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair"
 1886       unless defined $userSetIDs[$i]
 1887              and ref $userSetIDs[$i] eq "ARRAY"
 1888              and @{$userSetIDs[$i]} == 2
 1889              and defined $userSetIDs[$i]->[0]
 1890              and defined $userSetIDs[$i]->[1];
 1891   }
 1892 
 1893   # a horrible, terrible hack ;)
 1894   if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash"
 1895       and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
 1896     #warn __PACKAGE__.": using a terrible hack.\n";
 1897     $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer);
 1898     my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs);
 1899     $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer);
 1900     return @MergedSets;
 1901   }
 1902 
 1903   $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer);
 1904   my @UserSets = $self->getUserSets(@userSetIDs); # checked
 1905 
 1906   $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer);
 1907   my @globalSetIDs = map { $_->[1] } @userSetIDs;
 1908   $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer);
 1909   my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked
 1910 
 1911   $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer);
 1912   my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
 1913   my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
 1914 
 1915   $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 1916   for (my $i = 0; $i < @UserSets; $i++) {
 1917     my $UserSet = $UserSets[$i];
 1918     my $GlobalSet = $GlobalSets[$i];
 1919     next unless defined $UserSet and defined $GlobalSet;
 1920     foreach my $field (@commonFields) {
 1921       next if defined $UserSet->$field;
 1922       $UserSet->$field($GlobalSet->$field);
 1923     }
 1924   }
 1925   $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 1926 
 1927   return @UserSets;
 1928 }
 1929 
 1930 sub getMergedVersionedSets {
 1931     my ($self, @userSetIDs) = @_;
 1932 
 1933     foreach my $i (0 .. $#userSetIDs) {
 1934   croak "getMergedSets: element $i of argument list must contain a " .
 1935       "<user_id, set_id, versioned_set_id> triple"
 1936       unless( defined $userSetIDs[$i]
 1937         and ref $userSetIDs[$i] eq "ARRAY"
 1938         and @{$userSetIDs[$i]} == 3
 1939         and defined $userSetIDs[$i]->[0]
 1940         and defined $userSetIDs[$i]->[1]
 1941         and defined $userSetIDs[$i]->[2] );
 1942     }
 1943 
 1944 # these are [user_id, set_id] pairs
 1945     my @nonversionedUserSetIDs = map { [$_->[0], $_->[1]] } @userSetIDs;
 1946 # these are [user_id, versioned_set_id] pairs
 1947     my @versionedUserSetIDs = map { [$_->[0], $_->[2]] } @userSetIDs;
 1948 
 1949 # FIXME  as long as we're ignoring the global user for gdbm, this is ok...
 1950 # (are we?)  FIXME
 1951   # a horrible, terrible hack ;)
 1952     if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash"
 1953   and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
 1954     #warn __PACKAGE__.": using a terrible hack.\n";
 1955   $WeBWorK::timer->continue("DB: getsNoFilter start")
 1956       if defined($WeBWorK::timer);
 1957   my @MergedSets = $self->{set_user}->getsNoFilter(@versionedUserSetIDs);
 1958   $WeBWorK::timer->continue("DB: getsNoFilter end")
 1959       if defined($WeBWorK::timer);
 1960   return @MergedSets;
 1961     }
 1962 
 1963 # we merge the nonversioned ("template") user sets (user_id, set_id) and
 1964 #    the global data into the versioned user sets
 1965     $WeBWorK::timer->continue("DB: getUserSets start (nonversioned)")
 1966   if defined($WeBWorK::timer);
 1967     my @TemplateUserSets = $self->getUserSets(@nonversionedUserSetIDs);
 1968     $WeBWorK::timer->continue("DB: getUserSets start (versioned)")
 1969   if defined($WeBWorK::timer);
 1970 # these are the actual user sets that we want to use
 1971     my @versionedUserSets = $self->getUserSets(@versionedUserSetIDs);
 1972 
 1973     $WeBWorK::timer->continue("DB: pull out set IDs start")
 1974   if defined($WeBWorK::timer);
 1975     my @globalSetIDs = map { $_->[1] } @userSetIDs;
 1976     $WeBWorK::timer->continue("DB: getGlobalSets start")
 1977   if defined($WeBWorK::timer);
 1978     my @GlobalSets = $self->getGlobalSets(@globalSetIDs);
 1979 
 1980     $WeBWorK::timer->continue("DB: calc common fields start")
 1981   if defined($WeBWorK::timer);
 1982     my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
 1983     my @commonFields =
 1984   grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
 1985 
 1986     $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 1987     for (my $i = 0; $i < @TemplateUserSets; $i++) {
 1988   my $VersionedSet = $versionedUserSets[$i];
 1989   my $TemplateSet = $TemplateUserSets[$i];
 1990   my $GlobalSet = $GlobalSets[$i];
 1991     # shouldn't all of these necessarily be defined?  Hmm.
 1992   next unless( defined $VersionedSet and (defined $TemplateSet or
 1993             defined $GlobalSet) );
 1994   foreach my $field (@commonFields) {
 1995       next if defined $VersionedSet->$field;
 1996       $VersionedSet->$field($GlobalSet->$field) if (defined($GlobalSet));
 1997       $VersionedSet->$field($TemplateSet->$field)
 1998     if (defined($TemplateSet) && defined($TemplateSet->$field));
 1999   }
 2000     }
 2001     $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 2002 
 2003     return @versionedUserSets;
 2004 }
 2005 
 2006 =back
 2007 
 2008 =cut
 2009 
 2010 ################################################################################
 2011 # problem+problem_user functions
 2012 ################################################################################
 2013 
 2014 =head2 Problem Merging Methods
 2015 
 2016 These functions combine a global problem and a user problem to create a merged
 2017 problem, which is returned. Any field that is not defined in the user problem is
 2018 taken from the global problem. Merged problems have the same type as user
 2019 problems.
 2020 
 2021 =over
 2022 
 2023 =cut
 2024 
 2025 sub getGlobalUserProblem {
 2026   carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead";
 2027   return shift->getMergedProblem(@_);
 2028 }
 2029 
 2030 =item getMergedProblem($userID, $setID, $problemID)
 2031 
 2032 Returns a merged problem record associated with the record IDs given. If there
 2033 is no record associated with a given record ID, the undefined value is returned.
 2034 
 2035 =cut
 2036 
 2037 sub getMergedProblem {
 2038   my ($self, $userID, $setID, $problemID) = @_;
 2039 
 2040   croak "getGlobalUserSet: requires 3 arguments"
 2041     unless @_ == 4;
 2042   croak "getGlobalUserSet: argument 1 must contain a user_id"
 2043     unless defined $userID;
 2044   croak "getGlobalUserSet: argument 2 must contain a set_id"
 2045     unless defined $setID;
 2046   croak "getGlobalUserSet: argument 3 must contain a problem_id"
 2047     unless defined $problemID;
 2048 
 2049   return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0];
 2050 }
 2051 
 2052 sub getMergedVersionedProblem {
 2053     my ($self, $userID, $setID, $setVersionID, $problemID) = @_;
 2054 
 2055 # this exists distinct from getMergedProblem only to be able to include the
 2056 #    setVersionID
 2057 
 2058     croak "getGlobalUserSet: requires 4 arguments"
 2059   unless @_ == 5;
 2060     croak "getGlobalUserSet: argument 1 must contain a user_id"
 2061   unless defined $userID;
 2062     croak "getGlobalUserSet: argument 2 must contain a set_id"
 2063   unless defined $setID;
 2064     croak "getGlobalUserSet: argument 3 must contain a set_id"
 2065   unless defined $setVersionID;
 2066     croak "getGlobalUserSet: argument 4 must contain a problem_id"
 2067   unless defined $problemID;
 2068 
 2069     return ($self->getMergedVersionedProblems([$userID, $setID, $setVersionID,
 2070                  $problemID]))[0];
 2071 }
 2072 
 2073 =item getMergedProblems(@userProblemIDs)
 2074 
 2075 Return a list of merged problem records associated with the record IDs given. If
 2076 there is no record associated with a given record ID, that element of the list
 2077 will be undefined. @userProblemIDs consists of references to arrays in which the
 2078 first element is the user_id, the second element is the set_id, and the third
 2079 element is the problem_id.
 2080 
 2081 =cut
 2082 
 2083 sub getMergedProblems {
 2084   my ($self, @userProblemIDs) = @_;
 2085 
 2086   #croak "getMergedProblems: requires 1 or more argument"
 2087   # unless @_ >= 2;
 2088   foreach my $i (0 .. $#userProblemIDs) {
 2089     croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
 2090       unless defined $userProblemIDs[$i]
 2091              and ref $userProblemIDs[$i] eq "ARRAY"
 2092              and @{$userProblemIDs[$i]} == 3
 2093              and defined $userProblemIDs[$i]->[0]
 2094              and defined $userProblemIDs[$i]->[1]
 2095              and defined $userProblemIDs[$i]->[2];
 2096   }
 2097 
 2098   $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer);
 2099   my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked
 2100 
 2101   $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer);
 2102   my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs;
 2103   $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer);
 2104   my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked
 2105 
 2106   $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer);
 2107   my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
 2108   my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
 2109 
 2110   $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 2111   for (my $i = 0; $i < @UserProblems; $i++) {
 2112     my $UserProblem = $UserProblems[$i];
 2113     my $GlobalProblem = $GlobalProblems[$i];
 2114     next unless defined $UserProblem and defined $GlobalProblem;
 2115     foreach my $field (@commonFields) {
 2116       # FIXME: WW1Hash upgrades undefined fileds to "" when creating record objects
 2117       # Shouldn't we be testing for emptiness rather than definedness?
 2118       # I think the spec says that if a field is EMPTY the global value is used.
 2119       next if defined $UserProblem->$field;
 2120       $UserProblem->$field($GlobalProblem->$field);
 2121     }
 2122   }
 2123   $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 2124 
 2125   return @UserProblems;
 2126 }
 2127 
 2128 sub getMergedVersionedProblems {
 2129     my ($self, @userProblemIDs) = @_;
 2130 
 2131     foreach my $i (0 .. $#userProblemIDs) {
 2132   croak "getMergedProblems: element $i of argument list must contain a " .
 2133       "<user_id, set_id, versioned_set_id, problem_id> quadruple"
 2134       unless( defined $userProblemIDs[$i]
 2135         and ref $userProblemIDs[$i] eq "ARRAY"
 2136         and @{$userProblemIDs[$i]} == 4
 2137         and defined $userProblemIDs[$i]->[0]
 2138         and defined $userProblemIDs[$i]->[1]
 2139         and defined $userProblemIDs[$i]->[2]
 2140         and defined $userProblemIDs[$i]->[3] );
 2141     }
 2142 
 2143     $WeBWorK::timer->continue("DB: getUserProblems start")
 2144   if defined($WeBWorK::timer);
 2145 
 2146 # these are triples [user_id, set_id, problem_id]
 2147     my @nonversionedProblemIDs = map {[$_->[0],$_->[1],$_->[3]]} @userProblemIDs;
 2148 # these are triples [user_id, versioned_set_id, problem_id]
 2149     my @versionedProblemIDs = map {[$_->[0],$_->[2],$_->[3]]} @userProblemIDs;
 2150 
 2151 # these are the actual user problems for the version
 2152     my @versionUserProblems = $self->getUserProblems(@versionedProblemIDs);
 2153 
 2154 # get global problems (no user_id, set_id = nonversioned set_id) and
 2155 #    template problems (user_id, set_id = nonversioned set_id); we merge with
 2156 #    both of these, replacing global values with template values and not
 2157 #    taking either in the event that the versioned problem already has a
 2158 #    value for the field in question
 2159     $WeBWorK::timer->continue("DB: pull out set/problem IDs start")
 2160   if defined($WeBWorK::timer);
 2161     my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @nonversionedProblemIDs;
 2162     $WeBWorK::timer->continue("DB: getGlobalProblems start")
 2163   if defined($WeBWorK::timer);
 2164     my @GlobalProblems = $self->getGlobalProblems( @globalProblemIDs );
 2165     $WeBWorK::timer->continue("DB: getTemplateProblems start")
 2166   if defined($WeBWorK::timer);
 2167     my @TemplateProblems = $self->getUserProblems( @nonversionedProblemIDs );
 2168 
 2169     $WeBWorK::timer->continue("DB: calc common fields start")
 2170   if defined($WeBWorK::timer);
 2171 
 2172     my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
 2173     my @commonFields =
 2174   grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
 2175 
 2176     $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer);
 2177     for (my $i = 0; $i < @versionUserProblems; $i++) {
 2178   my $UserProblem = $versionUserProblems[$i];
 2179   my $GlobalProblem = $GlobalProblems[$i];
 2180   my $TemplateProblem = $TemplateProblems[$i];
 2181   next unless defined $UserProblem and ( defined $GlobalProblem or
 2182                  defined $TemplateProblem );
 2183   foreach my $field (@commonFields) {
 2184       next if defined $UserProblem->$field;
 2185       $UserProblem->$field($GlobalProblem->$field)
 2186     if ( defined($GlobalProblem) && defined($GlobalProblem->$field)
 2187          && $GlobalProblem->$field ne '' );
 2188       $UserProblem->$field($TemplateProblem->$field)
 2189     if ( defined($TemplateProblem) &&
 2190          defined($TemplateProblem->$field) &&
 2191          $TemplateProblem->$field ne '' );
 2192   }
 2193     }
 2194     $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer);
 2195 
 2196     return @versionUserProblems;
 2197 }
 2198 
 2199 =back
 2200 
 2201 =cut
 2202 
 2203 ################################################################################
 2204 # debugging
 2205 ################################################################################
 2206 
 2207 #sub dumpDB($$) {
 2208 # my ($self, $table) = @_;
 2209 # return $self->{$table}->dumpDB();
 2210 #}
 2211 
 2212 ################################################################################
 2213 # utilities
 2214 ################################################################################
 2215 
 2216 sub checkKeyfields($;$) {
 2217   my ($Record, $versioned) = @_;
 2218   foreach my $keyfield ($Record->KEYFIELDS) {
 2219     my $value = $Record->$keyfield;
 2220     croak "checkKeyfields: $keyfield is empty"
 2221       unless defined $value and $value ne "";
 2222 
 2223     if ($keyfield eq "problem_id") {
 2224       croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])"
 2225         unless $value =~ m/^\d*$/;
 2226     } else {
 2227       croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])"
 2228         # this logic is a bit ugly, but it enforces what we want,
 2229         #   which is that only versioned problem sets are allowed
 2230         #   to include commas in their names.
 2231         unless ( $value =~ m/^[\w-]*$/ ||
 2232            ( $value =~ m/^[\w,-]*$/ &&
 2233              (defined($versioned) && $versioned) &&
 2234              $keyfield eq "set_id" ) );
 2235     }
 2236   }
 2237 }
 2238 
 2239 =head1 AUTHOR
 2240 
 2241 Written by Sam Hathaway, sh002i (at) math.rochester.edu.
 2242 
 2243 =cut
 2244 
 2245 1;