View of /branches/rel-2-3-dev/webwork-modperl/lib/WeBWorK/DB.pm

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