Parent Directory
| 
Revision Log
CAUTION. Major update!!! Modifications made up until the release of 2.0 on July 16, 2004 on the 2.0 branch have been incorporated into version 2.1 alpha 1. A moderate amount of testing has been done. It will take some time to reconfigure your global.conf file once you update to this version.
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/WeBWorK/DB.pm,v 1.52 2004/06/17 20:11:17 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 # FIXME: this is way too slow! 318 #my @userSetIDs = $self->{set_user}->list(undef, undef); 319 320 # Timing Data 321 # 322 # old method: 323 # TIMING 36119 1 1087502726.923311 (0.139117) mth143: WeBWorK::DB::hashDatabaseOK: about to get orphaned UserSets 324 # TIMING 36119 1 1087502768.074221 (41.290027) mth143: WeBWorK::DB::hashDatabaseOK: done getting orphaned UserSets 325 # 326 # new method: 327 # TIMING 36134 0 1087502854.579133 (0.141437) mth143: WeBWorK::DB::hashDatabaseOK: about to get orphaned UserSets 328 # TIMING 36134 0 1087502856.852504 (2.414808) mth143: WeBWorK::DB::hashDatabaseOK: done getting orphaned UserSets 329 # 330 # yay! 331 332 $WeBWorK::timer->continue(__PACKAGE__ . "::hashDatabaseOK: about to get orphaned UserSets") if defined $WeBWorK::timer; 333 334 # ... so instead, we're going to do things manually 335 336 # key: setID, value: hash of userIDs of users to whom this set is assigned 337 my %orphanUserSets; 338 339 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash") { 340 # we can only do this with WW1Hash 341 #warn "the fast way!\n"; 342 343 # connect 344 $self->{set_user}->{driver}->connect("ro") 345 or return 0, @results, "Failed to connect to set_user database."; 346 347 # get PSVNs for global user (ČN) 348 my @globalUserPSVNs = $self->{set_user}->getPSVNsForUser($globalUserID); 349 #warn "found ", scalar @globalUserPSVNs, " PSVNs for the global user.\n"; 350 351 # get setIDs for PSVNs (M) 352 my @globalUserSetIDs; 353 foreach my $PSVN (@globalUserPSVNs) { 354 #warn "getting setID for PSVN '$PSVN'...\n"; 355 my $string = $self->{set_user}->fetchString($PSVN); 356 my (undef, $setID) = $self->{set_user}->string2IDs($string); # discard userID, problemIDs 357 push @globalUserSetIDs, $setID; 358 #warn "got setID '$setID'\n"; 359 } 360 361 # get PSVNs for each setID (ČN*M) 362 my @okPSVNs = map { $self->{set_user}->getPSVNsForSet($_) } @globalUserSetIDs; 363 #warn "found ", scalar @okPSVNs, " PSVNs for sets assigned to the global user.\n"; 364 365 # get all PSVNs (N*M) 366 my @allPSVNs = $self->{set_user}->getAllPSVNs; 367 #warn "found ", scalar @allPSVNs, " PSVNs total.\n"; 368 369 # eliminate PSVNs of sets that are assigned to the global user 370 my %allPSVNs; 371 @allPSVNs{@allPSVNs} = (); 372 373 foreach my $PSVN (@okPSVNs) { 374 delete $allPSVNs{$PSVN}; 375 } 376 377 # get setIDs for orphan PSVNs 378 foreach my $PSVN (keys %allPSVNs) { 379 #warn "getting userID and setID for PSVN '$PSVN'...\n"; 380 my $string = $self->{set_user}->fetchString($PSVN); 381 my ($userID, $setID) = $self->{set_user}->string2IDs($string); 382 $orphanUserSets{$setID}->{$userID} = 1; 383 #warn "got setID '$setID' for userID '$userID'\n"; 384 } 385 386 # disconnect 387 $self->{set_user}->{driver}->disconnect; 388 } else { 389 # otherwise, do it the slow way (maybe it's not slow with some other schema?) 390 #warn "oddly enough, set_user isn't using WW1Hash, so we have to use the slow list() method"; 391 my @userSetIDs = $self->{set_user}->list(undef, undef); 392 393 foreach my $userSetID (@userSetIDs) { 394 my ($userID, $setID) = @$userSetID; 395 $orphanUserSets{$setID}->{$userID} = 1; 396 } 397 398 foreach my $setID (keys %orphanUserSets) { 399 delete $orphanUserSets{$setID} 400 if exists $orphanUserSets{$setID}->{$globalUserID}; 401 } 402 } 403 404 $WeBWorK::timer->continue(__PACKAGE__ . "::hashDatabaseOK: done getting orphaned UserSets") if defined $WeBWorK::timer; 405 406 if (keys %orphanUserSets) { 407 if ($fix) { 408 foreach my $setID (keys %orphanUserSets) { 409 my $userID = ( keys %{$orphanUserSets{$setID}} )[0]; 410 411 # grab the first UserSet of this set (connect and disconnect required for get1*) 412 $self->{set_user}->{driver}->connect("ro") 413 or return 0, @results, "Failed to connect to set_user database."; 414 my $RawUserSet = $self->{set_user}->get1NoFilter($userID, $setID); 415 $self->{set_user}->{driver}->disconnect(); 416 unless ($RawUserSet) { 417 #warn "failed to fetch UserSet '$setID' for user '$userID'!\n"; 418 next; 419 } 420 421 # change user ID to globalUserID and add to database 422 $RawUserSet->user_id($globalUserID); 423 $self->{set_user}->add($RawUserSet); 424 425 push @results, "Set '$setID' not assigned to global user '$globalUserID' -- FIXED."; 426 427 #warn "hashDatabaseOK($fix): assigned set '$setID' to global user '$globalUserID' -- good.\n"; 428 } 429 } else { 430 foreach my $setID (keys %orphanUserSets) { 431 #warn "hashDatabaseOK($fix): set '$setID' not assigned to global user '$globalUserID' -- bad!\n"; 432 push @results, "Set '$setID' not assigned to global user '$globalUserID'."; 433 } 434 $errorsExist = 1; 435 } 436 } else { 437 #warn "hashDatabaseOK($fix): all sets assigned to global user '$globalUserID' -- good.\n"; 438 } 439 440 ##### done! ##### 441 442 my $status = not $errorsExist; 443 return $status, @results; 444 } 445 446 =back 447 448 =cut 449 450 ################################################################################ 451 # password functions 452 ################################################################################ 453 454 =head2 Password Methods 455 456 =over 457 458 =item newPassword() 459 460 Returns a new, empty password object. 461 462 =cut 463 464 sub newPassword { 465 my ($self, @prototype) = @_; 466 return $self->{password}->{record}->new(@prototype); 467 } 468 469 =item listPasswords() 470 471 Returns a list of user IDs representing the records in the password table. 472 473 =cut 474 475 sub listPasswords { 476 my ($self) = @_; 477 478 croak "listPasswords: requires 0 arguments" 479 unless @_ == 1; 480 481 return map { $_->[0] } 482 $self->{password}->list(undef); 483 } 484 485 =item addPassword($Password) 486 487 $Password is a record object. The password will be added to the password table 488 if a password with the same user ID does not already exist. If one does exist, 489 an exception is thrown. To add a password, a user with a matching user ID must 490 exist in the user table. 491 492 =cut 493 494 sub addPassword { 495 my ($self, $Password) = @_; 496 497 croak "addPassword: requires 1 argument" 498 unless @_ == 2; 499 croak "addPassword: argument 1 must be of type ", $self->{password}->{record} 500 unless ref $Password eq $self->{password}->{record}; 501 502 checkKeyfields($Password); 503 504 croak "addPassword: password exists (perhaps you meant to use putPassword?)" 505 if $self->{password}->exists($Password->user_id); 506 croak "addPassword: user ", $Password->user_id, " not found" 507 unless $self->{user}->exists($Password->user_id); 508 509 return $self->{password}->add($Password); 510 } 511 512 =item getPassword($userID) 513 514 If a record with a matching user ID exists, a record object containting that 515 record's data will be returned. If no such record exists, one will be created. 516 517 =cut 518 519 sub getPassword { 520 my ($self, $userID) = @_; 521 522 croak "getPassword: requires 1 argument" 523 unless @_ == 2; 524 croak "getPassword: argument 1 must contain a user_id" 525 unless defined $userID; 526 527 #return $self->{password}->get($userID); 528 return ( $self->getPasswords($userID) )[0]; 529 } 530 531 =item getPasswords(@uesrIDs) 532 533 Return a list of password records associated with the user IDs given. If there 534 is no record associated with a given user ID, one will be created. 535 536 =cut 537 538 sub getPasswords { 539 my ($self, @userIDs) = @_; 540 541 #croak "getPasswords: requires 1 or more argument" 542 # unless @_ >= 2; 543 foreach my $i (0 .. $#userIDs) { 544 croak "getPasswords: element $i of argument list must contain a user_id" 545 unless defined $userIDs[$i]; 546 } 547 548 my @Passwords = $self->{password}->gets(map { [$_] } @userIDs); 549 550 for (my $i = 0; $i < @Passwords; $i++) { 551 my $Password = $Passwords[$i]; 552 my $userID = $userIDs[$i]; 553 if (not defined $Password) { 554 #warn "not defined\n"; 555 if ($self->{user}->exists($userID)) { 556 #warn "user exists\n"; 557 $Password = $self->newPassword(user_id => $userID); 558 eval { $self->addPassword($Password) }; 559 if ($@ and $@ !~ m/password exists/) { 560 die "error while auto-creating password record for user $userID: \"$@\""; 561 } 562 } 563 } 564 } 565 566 return @Passwords; 567 } 568 569 =item putPassword($Password) 570 571 $Password is a record object. If a password record with the same user ID exists 572 in the password table, the data in the record is replaced with the data in 573 $Password. If a matching password record does not exist, an exception is 574 thrown. 575 576 =cut 577 578 sub putPassword($$) { 579 my ($self, $Password) = @_; 580 581 croak "putPassword: requires 1 argument" 582 unless @_ == 2; 583 croak "putPassword: argument 1 must be of type ", $self->{password}->{record} 584 unless ref $Password eq $self->{password}->{record}; 585 586 checkKeyfields($Password); 587 588 croak "putPassword: password not found (perhaps you meant to use addPassword?)" 589 unless $self->{password}->exists($Password->user_id); 590 591 return $self->{password}->put($Password); 592 } 593 594 =item deletePassword($userID) 595 596 If a password record with a user ID matching $userID exists in the password 597 table, it is removed and the method returns a true value. If one does exist, 598 a false value is returned. 599 600 =cut 601 602 sub deletePassword($$) { 603 my ($self, $userID) = @_; 604 605 croak "putPassword: requires 1 argument" 606 unless @_ == 2; 607 croak "deletePassword: argument 1 must contain a user_id" 608 unless defined $userID; 609 610 return $self->{password}->delete($userID); 611 } 612 613 =back 614 615 =cut 616 617 ################################################################################ 618 # permission functions 619 ################################################################################ 620 621 =head2 Permission Level Methods 622 623 =over 624 625 =item newPermissionLevel() 626 627 Returns a new, empty permission level object. 628 629 =cut 630 631 sub newPermissionLevel { 632 my ($self, @prototype) = @_; 633 return $self->{permission}->{record}->new(@prototype); 634 } 635 636 =item listPermissionLevels() 637 638 Returns a list of user IDs representing the records in the permission table. 639 640 =cut 641 642 sub listPermissionLevels($) { 643 my ($self) = @_; 644 645 croak "listPermissionLevels: requires 0 arguments" 646 unless @_ == 1; 647 648 return map { $_->[0] } 649 $self->{permission}->list(undef); 650 } 651 652 =item addPermissionLevel($PermissionLevel) 653 654 $PermissionLevel is a record object. The permission level will be added to the 655 permission table if a permission level with the same user ID does not already 656 exist. If one does exist, an exception is thrown. To add a permission level, a 657 user with a matching user ID must exist in the user table. 658 659 =cut 660 661 sub addPermissionLevel($$) { 662 my ($self, $PermissionLevel) = @_; 663 664 croak "addPermissionLevel: requires 1 argument" 665 unless @_ == 2; 666 croak "addPermissionLevel: argument 1 must be of type ", $self->{permission}->{record} 667 unless ref $PermissionLevel eq $self->{permission}->{record}; 668 669 checkKeyfields($PermissionLevel); 670 671 croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)" 672 if $self->{permission}->exists($PermissionLevel->user_id); 673 croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found" 674 unless $self->{user}->exists($PermissionLevel->user_id); 675 676 return $self->{permission}->add($PermissionLevel); 677 } 678 679 =item getPermissionLevel($userID) 680 681 If a record with a matching user ID exists, a record object containting that 682 record's data will be returned. If no such record exists, one will be created. 683 684 =cut 685 686 sub getPermissionLevel($$) { 687 my ($self, $userID) = @_; 688 689 croak "getPermissionLevel: requires 1 argument" 690 unless @_ == 2; 691 croak "getPermissionLevel: argument 1 must contain a user_id" 692 unless defined $userID; 693 694 #return $self->{permission}->get($userID); 695 return ( $self->getPermissionLevels($userID) )[0]; 696 } 697 698 =item getPermissionLevels(@uesrIDs) 699 700 Return a list of permission level records associated with the user IDs given. If 701 there is no record associated with a given user ID, one will be created. 702 703 =cut 704 705 sub getPermissionLevels { 706 my ($self, @userIDs) = @_; 707 708 #croak "getPermissionLevels: requires 1 or more argument" 709 # unless @_ >= 2; 710 foreach my $i (0 .. $#userIDs) { 711 croak "getPermissionLevels: element $i of argument list must contain a user_id" 712 unless defined $userIDs[$i]; 713 } 714 715 my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs); 716 717 for (my $i = 0; $i < @PermissionLevels; $i++) { 718 my $PermissionLevel = $PermissionLevels[$i]; 719 my $userID = $userIDs[$i]; 720 if (not defined $PermissionLevel) { 721 #warn "not defined\n"; 722 if ($self->{user}->exists($userID)) { 723 #warn "user exists\n"; 724 $PermissionLevel = $self->newPermissionLevel(user_id => $userID); 725 #warn $PermissionLevel->toString, "\n"; 726 eval { $self->addPermissionLevel($PermissionLevel) }; 727 if ($@ and $@ !~ m/permission level exists/) { 728 die "error while auto-creating permission level record for user $userID: \"$@\""; 729 } 730 $PermissionLevels[$i] = $PermissionLevel; 731 } 732 } 733 } 734 735 return @PermissionLevels; 736 } 737 738 =item putPermissionLevel($PermissionLevel) 739 740 $PermissionLevel is a record object. If a permission level record with the same 741 user ID exists in the permission table, the data in the record is replaced with 742 the data in $PermissionLevel. If a matching permission level record does not 743 exist, an exception is thrown. 744 745 =cut 746 747 sub putPermissionLevel($$) { 748 my ($self, $PermissionLevel) = @_; 749 750 croak "putPermissionLevel: requires 1 argument" 751 unless @_ == 2; 752 croak "putPermissionLevel: argument 1 must be of type ", $self->{permission}->{record} 753 unless ref $PermissionLevel eq $self->{permission}->{record}; 754 755 checkKeyfields($PermissionLevel); 756 757 croak "putPermissionLevel: permission level not found (perhaps you meant to use addPermissionLevel?)" 758 unless $self->{permission}->exists($PermissionLevel->user_id); 759 760 return $self->{permission}->put($PermissionLevel); 761 } 762 763 =item deletePermissionLevel($userID) 764 765 If a permission level record with a user ID matching $userID exists in the 766 permission table, it is removed and the method returns a true value. If one 767 does exist, a false value is returned. 768 769 =cut 770 771 sub deletePermissionLevel($$) { 772 my ($self, $userID) = @_; 773 774 croak "deletePermissionLevel: requires 1 argument" 775 unless @_ == 2; 776 croak "deletePermissionLevel: argument 1 must contain a user_id" 777 unless defined $userID; 778 779 return $self->{permission}->delete($userID); 780 } 781 782 ################################################################################ 783 # key functions 784 ################################################################################ 785 786 =head2 Key Methods 787 788 =over 789 790 =item newKey() 791 792 Returns a new, empty key object. 793 794 =cut 795 796 sub newKey { 797 my ($self, @prototype) = @_; 798 return $self->{key}->{record}->new(@prototype); 799 } 800 801 =item listKeys() 802 803 Returns a list of user IDs representing the records in the key table. 804 805 =cut 806 807 sub listKeys($) { 808 my ($self) = @_; 809 810 croak "listKeys: requires 0 arguments" 811 unless @_ == 1; 812 813 return map { $_->[0] } 814 $self->{key}->list(undef); 815 } 816 817 =item addKey($Key) 818 819 $Key is a record object. The key will be added to the key table if a key with 820 the same user ID does not already exist. If one does exist, an exception is 821 thrown. To add a key, a user with a matching user ID must exist in the user 822 table. 823 824 (Addition for proctored tests: also allow user IDs to match userID1,userID2 825 where both userIDs are valid.) 826 827 =cut 828 829 sub addKey($$) { 830 my ($self, $Key) = @_; 831 832 croak "addKey: requires 1 argument" 833 unless @_ == 2; 834 croak "addKey: argument 1 must be of type ", $self->{key}->{record} 835 unless ref $Key eq $self->{key}->{record}; 836 837 checkKeyfields($Key, 1); # 1 flags the possibility of a comma 838 839 croak "addKey: key exists (perhaps you meant to use putKey?)" 840 if $self->{key}->exists($Key->user_id); 841 if ( $Key->user_id !~ /,/ ) { 842 croak "addKey: user ", $Key->user_id, " not found" 843 unless $self->{user}->exists($Key->user_id); 844 } else { 845 my ( $userID, $proctorID ) = split(/,/, $Key->user_id); 846 croak "addKey: user $userID not found" 847 unless $self->{user}->exists($userID); 848 croak "addKey: proctor $proctorID not found" 849 unless $self->{user}->exists($proctorID); 850 } 851 852 return $self->{key}->add($Key); 853 } 854 855 =item getKey($userID) 856 857 If a record with a matching user ID exists, a record object containting that 858 record's data will be returned. If no such record exists, an undefined value 859 will be returned. 860 861 =cut 862 863 sub getKey($$) { 864 my ($self, $userID) = @_; 865 866 croak "getKey: requires 1 argument" 867 unless @_ == 2; 868 croak "getKey: argument 1 must contain a user_id" 869 unless defined $userID; 870 871 return $self->{key}->get($userID); 872 } 873 874 =item getKeys(@uesrIDs) 875 876 Return a list of key records associated with the user IDs given. If there is no 877 record associated with a given user ID, that element of the list will be 878 undefined. 879 880 =cut 881 882 sub getKeys { 883 my ($self, @userIDs) = @_; 884 885 #croak "getKeys: requires 1 or more argument" 886 # unless @_ >= 2; 887 foreach my $i (0 .. $#userIDs) { 888 croak "getKeys: element $i of argument list must contain a user_id" 889 unless defined $userIDs[$i]; 890 } 891 892 return $self->{key}->gets(map { [$_] } @userIDs); 893 } 894 895 =item putKey($Key) 896 897 $Key is a record object. If a key record with the same user ID exists in the 898 key table, the data in the record is replaced with the data in $Key. If a 899 matching key record does not exist, an exception is thrown. 900 901 =cut 902 903 sub putKey($$) { 904 my ($self, $Key) = @_; 905 906 croak "putKey: requires 1 argument" 907 unless @_ == 2; 908 croak "putKey: argument 1 must be of type ", $self->{key}->{record} 909 unless ref $Key eq $self->{key}->{record}; 910 911 checkKeyfields($Key, 1); # 1 to allow a comma 912 913 croak "putKey: key not found (perhaps you meant to use addKey?)" 914 unless $self->{key}->exists($Key->user_id); 915 916 return $self->{key}->put($Key); 917 } 918 919 =item deleteKey($userID) 920 921 If a key record with a user ID matching $userID exists in the key table, it is 922 removed and the method returns a true value. If one does exist, a false value 923 is returned. 924 925 =cut 926 927 sub deleteKey($$) { 928 my ($self, $userID) = @_; 929 930 croak "deleteKey: requires 1 argument" 931 unless @_ == 2; 932 croak "deleteKey: argument 1 must contain a user_id" 933 unless defined $userID; 934 935 return $self->{key}->delete($userID); 936 } 937 938 ################################################################################ 939 # user functions 940 ################################################################################ 941 942 =head2 User Methods 943 944 =over 945 946 =item newUser() 947 948 Returns a new, empty user object. 949 950 =cut 951 952 sub newUser { 953 my ($self, @prototype) = @_; 954 return $self->{user}->{record}->new(@prototype); 955 } 956 957 =item listUsers() 958 959 Returns a list of user IDs representing the records in the user table. 960 961 =cut 962 963 sub listUsers { 964 my ($self) = @_; 965 966 croak "listUsers: requires 0 arguments" 967 unless @_ == 1; 968 969 return map { $_->[0] } 970 $self->{user}->list(undef); 971 } 972 973 =item addUser($User) 974 975 $User is a record object. The user will be added to the user table if a user 976 with the same user ID does not already exist. If one does exist, an exception 977 is thrown. 978 979 =cut 980 981 sub addUser { 982 my ($self, $User) = @_; 983 984 croak "addUser: requires 1 argument" 985 unless @_ == 2; 986 croak "addUser: argument 1 must be of type ", $self->{user}->{record} 987 unless ref $User eq $self->{user}->{record}; 988 989 checkKeyfields($User); 990 991 croak "addUser: user exists (perhaps you meant to use putUser?)" 992 if $self->{user}->exists($User->user_id); 993 994 return $self->{user}->add($User); 995 } 996 997 =item getUser($userID) 998 999 If a record with a matching user ID exists, a record object containting that 1000 record's data will be returned. If no such record exists, an undefined value 1001 will be returned. 1002 1003 =cut 1004 1005 sub getUser { 1006 my ($self, $userID) = @_; 1007 1008 croak "getUser: requires 1 argument" 1009 unless @_ == 2; 1010 croak "getUser: argument 1 must contain a user_id" 1011 unless defined $userID; 1012 1013 return $self->{user}->get($userID); 1014 } 1015 1016 =item getUsers(@uesrIDs) 1017 1018 Return a list of user records associated with the user IDs given. If there is no 1019 record associated with a given user ID, that element of the list will be 1020 undefined. 1021 1022 =cut 1023 1024 sub getUsers { 1025 my ($self, @userIDs) = @_; 1026 1027 #croak "getUsers: requires 1 or more argument" 1028 # unless @_ >= 2; 1029 foreach my $i (0 .. $#userIDs) { 1030 croak "getUsers: element $i of argument list must contain a user_id" 1031 unless defined $userIDs[$i]; 1032 } 1033 1034 return $self->{user}->gets(map { [$_] } @userIDs); 1035 } 1036 1037 =item putUser($User) 1038 1039 $User is a record object. If a user record with the same user ID exists in the 1040 user table, the data in the record is replaced with the data in $User. If a 1041 matching user record does not exist, an exception is thrown. 1042 1043 =cut 1044 1045 sub putUser { 1046 my ($self, $User) = @_; 1047 1048 croak "putUser: requires 1 argument" 1049 unless @_ == 2; 1050 croak "putUser: argument 1 must be of type ", $self->{user}->{record} 1051 unless ref $User eq $self->{user}->{record}; 1052 1053 checkKeyfields($User); 1054 1055 croak "putUser: user not found (perhaps you meant to use addUser?)" 1056 unless $self->{user}->exists($User->user_id); 1057 1058 return $self->{user}->put($User); 1059 } 1060 1061 =item deleteUser($userID) 1062 1063 If a user record with a user ID matching $userID exists in the user table, it 1064 is removed and the method returns a true value. If one does exist, a false 1065 value is returned. When a user record is deleted, all records associated with 1066 that user are also deleted. This includes the password, permission, and key 1067 records, and all user set records for that user. 1068 1069 =cut 1070 1071 sub deleteUser { 1072 my ($self, $userID) = @_; 1073 1074 croak "deleteUser: requires 1 argument" 1075 unless @_ == 2; 1076 croak "deleteUser: argument 1 must contain a user_id" 1077 unless defined $userID; 1078 1079 $self->deleteUserSet($userID, undef); 1080 $self->deletePassword($userID); 1081 $self->deletePermissionLevel($userID); 1082 $self->deleteKey($userID); 1083 return $self->{user}->delete($userID); 1084 } 1085 1086 =back 1087 1088 =cut 1089 1090 ################################################################################ 1091 # set functions 1092 ################################################################################ 1093 1094 =head2 Global Set Methods 1095 1096 FIXME: write this 1097 1098 =over 1099 1100 =cut 1101 1102 =item newGlobalSet() 1103 1104 =cut 1105 1106 sub newGlobalSet { 1107 my ($self, @prototype) = @_; 1108 return $self->{set}->{record}->new(@prototype); 1109 } 1110 1111 =item listGlobalSets() 1112 1113 =cut 1114 1115 sub listGlobalSets { 1116 my ($self) = @_; 1117 1118 croak "listGlobalSets: requires 0 arguments" 1119 unless @_ == 1; 1120 1121 return map { $_->[0] } 1122 $self->{set}->list(undef); 1123 } 1124 1125 =item addGlobalSet($GlobalSet) 1126 1127 =cut 1128 1129 sub addGlobalSet { 1130 my ($self, $GlobalSet) = @_; 1131 1132 croak "addGlobalSet: requires 1 argument" 1133 unless @_ == 2; 1134 croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record} 1135 unless ref $GlobalSet eq $self->{set}->{record}; 1136 1137 checkKeyfields($GlobalSet); 1138 1139 croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)" 1140 if $self->{set}->exists($GlobalSet->set_id); 1141 1142 return $self->{set}->add($GlobalSet); 1143 } 1144 1145 =item addGlobalSet($setID) 1146 1147 =cut 1148 1149 sub getGlobalSet { 1150 my ($self, $setID) = @_; 1151 1152 croak "getGlobalSet: requires 1 argument" 1153 unless @_ == 2; 1154 croak "getGlobalSet: argument 1 must contain a set_id" 1155 unless defined $setID; 1156 1157 return $self->{set}->get($setID); 1158 } 1159 1160 =item getGlobalSets(@setIDs) 1161 1162 Return a list of global set records associated with the record IDs given. If 1163 there is no record associated with a given record ID, that element of the list 1164 will be undefined. 1165 1166 =cut 1167 1168 sub getGlobalSets { 1169 my ($self, @setIDs) = @_; 1170 1171 #croak "getGlobalSets: requires 1 or more argument" 1172 # unless @_ >= 2; 1173 foreach my $i (0 .. $#setIDs) { 1174 croak "getGlobalSets: element $i of argument list must contain a set_id" 1175 unless defined $setIDs[$i]; 1176 } 1177 1178 return $self->{set}->gets(map { [$_] } @setIDs); 1179 } 1180 1181 =item addGlobalSet($GlobalSet) 1182 1183 =cut 1184 1185 sub putGlobalSet { 1186 my ($self, $GlobalSet) = @_; 1187 1188 croak "putGlobalSet: requires 1 argument" 1189 unless @_ == 2; 1190 croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record} 1191 unless ref $GlobalSet eq $self->{set}->{record}; 1192 1193 checkKeyfields($GlobalSet); 1194 1195 croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)" 1196 unless $self->{set}->exists($GlobalSet->set_id); 1197 1198 return $self->{set}->put($GlobalSet); 1199 } 1200 1201 =item addGlobalSet($setID) 1202 1203 =cut 1204 1205 sub deleteGlobalSet { 1206 my ($self, $setID) = @_; 1207 1208 croak "deleteGlobalSet: requires 1 argument" 1209 unless @_ == 2; 1210 croak "deleteGlobalSet: argument 1 must contain a set_id" 1211 unless defined $setID or caller eq __PACKAGE__; 1212 1213 $self->deleteUserSet(undef, $setID); 1214 1215 $self->deleteGlobalProblem($setID, undef); 1216 return $self->{set}->delete($setID); 1217 } 1218 1219 =back 1220 1221 =cut 1222 1223 ################################################################################ 1224 # set_user functions 1225 ################################################################################ 1226 1227 =head2 User-Specific Set Methods 1228 1229 FIXME: write this 1230 1231 =over 1232 1233 =cut 1234 1235 sub newUserSet { 1236 my ($self, @prototype) = @_; 1237 return $self->{set_user}->{record}->new(@prototype); 1238 } 1239 1240 sub countSetUsers { 1241 my ($self, $setID) = @_; 1242 1243 croak "countSetUsers: requires 1 argument" 1244 unless @_ == 2; 1245 croak "countSetUsers: argument 1 must contain a set_id" 1246 unless defined $setID; 1247 1248 # inefficient way 1249 #return scalar $self->{set_user}->list(undef, $setID); 1250 1251 # efficient way 1252 return $self->{set_user}->count(undef, $setID); 1253 } 1254 1255 sub listSetUsers { 1256 my ($self, $setID) = @_; 1257 1258 carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n" 1259 unless wantarray; 1260 1261 croak "listSetUsers: requires 1 argument" 1262 unless @_ == 2; 1263 croak "listSetUsers: argument 1 must contain a set_id" 1264 unless defined $setID; 1265 1266 return map { $_->[0] } # extract user_id 1267 $self->{set_user}->list(undef, $setID); 1268 } 1269 1270 sub countUserSets { 1271 my ($self, $userID) = @_; 1272 1273 croak "countUserSets: requires 1 argument" 1274 unless @_ == 2; 1275 croak "countUserSets: argument 1 must contain a user_id" 1276 unless defined $userID; 1277 1278 return $self->{set_user}->count($userID, undef); 1279 } 1280 1281 sub listUserSets { 1282 my ($self, $userID) = @_; 1283 1284 croak "listUserSets: requires 1 argument" 1285 unless @_ == 2; 1286 croak "listUserSets: argument 1 must contain a user_id" 1287 unless defined $userID; 1288 1289 return map { $_->[1] } # extract set_id 1290 $self->{set_user}->list($userID, undef); 1291 } 1292 1293 sub addUserSet { 1294 my ($self, $UserSet) = @_; 1295 1296 croak "addUserSet: requires 1 argument" 1297 unless @_ == 2; 1298 croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1299 unless ref $UserSet eq $self->{set_user}->{record}; 1300 1301 checkKeyfields($UserSet); 1302 1303 croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)" 1304 if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1305 croak "addUserSet: user ", $UserSet->user_id, " not found" 1306 unless $self->{user}->exists($UserSet->user_id); 1307 croak "addUserSet: set ", $UserSet->set_id, " not found" 1308 unless $self->{set}->exists($UserSet->set_id); 1309 1310 return $self->{set_user}->add($UserSet); 1311 } 1312 1313 sub addVersionedUserSet { 1314 my ($self, $UserSet) = @_; 1315 1316 # this is the same as addUserSet,allowing for set names of the form setID,vN 1317 1318 croak "addVersionedUserSet: requires 1 argument" 1319 unless @_ == 2; 1320 croak "addVersionedUserSet: argument 1 must be of type ", 1321 $self->{set_user}->{record} 1322 unless ref $UserSet eq $self->{set_user}->{record}; 1323 1324 # $versioned is a flag that we send in to allow commas in the set name 1325 # for versioned sets 1326 my $versioned = 1; 1327 checkKeyfields($UserSet, $versioned); 1328 my ($nonVersionedSetName) = ($UserSet->set_id =~ /^(.*),v\d+$/); 1329 1330 croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)" 1331 if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1332 croak "addUserSet: user ", $UserSet->user_id, " not found" 1333 unless $self->{user}->exists($UserSet->user_id); 1334 # croak "addUserSet: set ", $UserSet->set_id, " not found" 1335 # unless $self->{set}->exists($UserSet->set_id); 1336 # here the appropriate check is whether a global set of the nonversioned set 1337 # name exists 1338 croak "addVersionedUserSet: set ", $nonVersionedSetName, " not found" 1339 unless $self->{set}->exists( $nonVersionedSetName ); 1340 1341 return $self->{set_user}->add($UserSet); 1342 } 1343 1344 sub getUserSet { 1345 my ($self, $userID, $setID) = @_; 1346 1347 croak "getUserSet: requires 2 arguments" 1348 unless @_ == 3; 1349 croak "getUserSet: argument 1 must contain a user_id" 1350 unless defined $userID; 1351 croak "getUserSet: argument 2 must contain a set_id" 1352 unless defined $setID; 1353 1354 #return $self->{set_user}->get($userID, $setID); 1355 return ( $self->getUserSets([$userID, $setID]) )[0]; 1356 } 1357 1358 =item getUserSets(@userSetIDs) 1359 1360 Return a list of user set records associated with the record IDs given. If there 1361 is no record associated with a given record ID, that element of the list will be 1362 undefined. @userProblemIDs consists of references to arrays in which the first 1363 element is the user_id and the second element is the set_id. 1364 1365 =cut 1366 1367 sub getUserSets { 1368 my ($self, @userSetIDs) = @_; 1369 1370 #croak "getUserSets: requires 1 or more argument" 1371 # unless @_ >= 2; 1372 foreach my $i (0 .. $#userSetIDs) { 1373 croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair" 1374 unless defined $userSetIDs[$i] 1375 and ref $userSetIDs[$i] eq "ARRAY" 1376 and @{$userSetIDs[$i]} == 2 1377 and defined $userSetIDs[$i]->[0] 1378 and defined $userSetIDs[$i]->[1]; 1379 } 1380 1381 return $self->{set_user}->gets(@userSetIDs); 1382 } 1383 1384 sub getUserSetVersions { 1385 my ( $self, $uid, $sid, $versionNum ) = @_; 1386 # in: $uid is a userID, $sid is a setID, and $versionNum is a version number 1387 # userID has set versions 1 through $versionNum defined 1388 # out: an array of user set objects is returned for the indicated version 1389 # numbers 1390 1391 croak "getUserSetVersions: requires three arguments, userID, setID, and " . 1392 "versionNum" if ( @_ < 3 ); 1393 1394 my @userSetIDs = (); 1395 foreach my $i ( 1 .. $versionNum ) { 1396 push( @userSetIDs, [ $uid, "$sid,v$i" ] ); 1397 } 1398 1399 return $self->getUserSets( @userSetIDs ); 1400 } 1401 1402 sub putUserSet { 1403 my ($self, $UserSet) = @_; 1404 1405 croak "putUserSet: requires 1 argument" 1406 unless @_ == 2; 1407 croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1408 unless ref $UserSet eq $self->{set_user}->{record}; 1409 1410 checkKeyfields($UserSet); 1411 1412 croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)" 1413 unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1414 croak "putUserSet: user ", $UserSet->user_id, " not found" 1415 unless $self->{user}->exists($UserSet->user_id); 1416 croak "putUserSet: set ", $UserSet->set_id, " not found" 1417 unless $self->{set}->exists($UserSet->set_id); 1418 1419 return $self->{set_user}->put($UserSet); 1420 } 1421 1422 sub putVersionedUserSet { 1423 my ($self, $UserSet) = @_; 1424 # this exists separate from putUserSet only so that we can make it harder 1425 # for anyone else to use commas in setIDs 1426 1427 croak "putUserSet: requires 1 argument" 1428 unless @_ == 2; 1429 croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1430 unless ref $UserSet eq $self->{set_user}->{record}; 1431 1432 # versioned allows us to have a wacked out setID 1433 my $versioned = 1; 1434 checkKeyfields($UserSet, $versioned); 1435 1436 my $nonVersionedSetID = $UserSet->set_id; 1437 $nonVersionedSetID =~ s/,v\d+$//; 1438 # my ($nonVersionedSetID) = ($UserSet->set_id =~ /^(.*)(,v\d+)?$/); 1439 croak "putVersionedUserSet: user set not found (perhaps you meant " . 1440 "to use addUserSet?)" 1441 unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1442 croak "putVersionedUserSet: user ", $UserSet->user_id, " not found" 1443 unless $self->{user}->exists($UserSet->user_id); 1444 croak "putVersionedUserSet: set $nonVersionedSetID not found" 1445 unless $self->{set}->exists($nonVersionedSetID); 1446 1447 return $self->{set_user}->put($UserSet); 1448 } 1449 1450 sub deleteUserSet { 1451 my ($self, $userID, $setID, $skipVersionDel) = @_; 1452 1453 croak "getUserSet: requires 2 arguments" 1454 unless @_ == 3 or @_ == 4; 1455 croak "getUserSet: argument 1 must contain a user_id" 1456 unless defined $userID or caller eq __PACKAGE__; 1457 croak "getUserSet: argument 2 must contain a set_id" 1458 unless defined $userID or caller eq __PACKAGE__; 1459 1460 $self->deleteUserSetVersions( $userID, $setID ) 1461 if ( defined($setID) && ! ( defined($skipVersionDel) && 1462 $skipVersionDel ) ); 1463 $self->deleteUserProblem($userID, $setID, undef); 1464 return $self->{set_user}->delete($userID, $setID); 1465 } 1466 1467 sub deleteUserSetVersions { 1468 my ($self, $userID, $setID) = @_; 1469 1470 # this only gets called from deleteUserSet, so we don't worry about $setID 1471 # not being defined 1472 1473 # make a list of all users to delete set versions for. if we have a userID, 1474 # then just delete versions for that user 1475 my @allUsers = (); 1476 if ( defined( $userID ) ) { 1477 push( @allUsers, $userID ); 1478 } else { 1479 # otherwise, get a list of all users to whom the set is assigned, and delete 1480 # all versions for all of them 1481 @allUsers = $self->listSetUsers( $setID ); 1482 } 1483 1484 # skip version deletion when calling deleteUserSet from here 1485 my $skipVersionDel = 1; 1486 1487 # go through each userID and delete all versions of the set for each 1488 foreach my $uid ( @allUsers ) { 1489 my $setVersionNumber = $self->getUserSetVersionNumber($uid, $setID); 1490 if ( $setVersionNumber ) { 1491 for ( my $i=1; $i<=$setVersionNumber; $i++ ) { 1492 eval { $self->deleteUserSet( $uid, "$setID,v$i", 1493 $skipVersionDel ) }; 1494 return $@ if ( $@ ); 1495 } 1496 } 1497 } 1498 } 1499 1500 sub getUserSetVersionNumber { 1501 my ( $self, $uid, $sid ) = @_; 1502 # in: uid and sid are user and set ids. the setID is the 'global' setID 1503 # for the user, not a versioned value 1504 # out: the latest version number of the set that has been assigned to the 1505 # user is returned. 1506 1507 croak "getUserSetVersionNumber: requires 2 arguments, a user and set ID" 1508 unless @_ == 3 && defined $uid && defined $sid; 1509 1510 # is there a better way of doing this? it seems like we need to know the 1511 # number of versions to be able to do a mass get. something like a get 1512 # where sid looks like $sid,v\d would work... but is incompatible w/gdbm 1513 # my $i=1; 1514 # if ( $self->{set_user}->exists( $uid, $sid ) ) { 1515 # while ( $self->{set_user}->exists( $uid, "$sid,v$i" ) ) { 1516 # $i++; 1517 # } 1518 # } 1519 # return ($i-1); 1520 # or, we can just get all sets for the user and figure out which of them 1521 # look like the sid. 1522 my @allSetIDs = $self->listUserSets( $uid ); 1523 my @setIDs = sort( grep { /^$sid,v\d+$/ } @allSetIDs ); 1524 # my $lastSetID = ( sort( @setIDs ) )[-1]; 1525 my $lastSetID = $setIDs[-1]; 1526 # I think this should be defined, unless the set hasn't been assigned to 1527 # the user at all, which we hope wouldn't have happened at this juncture 1528 if ( not defined($lastSetID) ) { 1529 return 0; 1530 } else { 1531 # we have to deal with the fact that 10 sorts to precede 2 (etc.) 1532 my @vNums = map { /^$sid,v(\d+)$/ } @setIDs; 1533 return ( ( sort {$a<=>$b} @vNums )[-1] ); 1534 } 1535 } 1536 1537 =back 1538 1539 =cut 1540 1541 ################################################################################ 1542 # problem functions 1543 ################################################################################ 1544 1545 =head2 Global Problem Methods 1546 1547 FIXME: write this 1548 1549 =over 1550 1551 =cut 1552 1553 sub newGlobalProblem { 1554 my ($self, @prototype) = @_; 1555 return $self->{problem}->{record}->new(@prototype); 1556 } 1557 1558 sub listGlobalProblems { 1559 my ($self, $setID) = @_; 1560 1561 croak "listGlobalProblems: requires 1 arguments" 1562 unless @_ == 2; 1563 croak "listGlobalProblems: argument 1 must contain a set_id" 1564 unless defined $setID; 1565 1566 return map { $_->[1] } 1567 $self->{problem}->list($setID, undef); 1568 } 1569 1570 sub addGlobalProblem { 1571 my ($self, $GlobalProblem) = @_; 1572 1573 croak "addGlobalProblem: requires 1 argument" 1574 unless @_ == 2; 1575 croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1576 unless ref $GlobalProblem eq $self->{problem}->{record}; 1577 1578 checkKeyfields($GlobalProblem); 1579 1580 croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)" 1581 if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1582 croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1583 unless $self->{set}->exists($GlobalProblem->set_id); 1584 1585 return $self->{problem}->add($GlobalProblem); 1586 } 1587 1588 sub getGlobalProblem { 1589 my ($self, $setID, $problemID) = @_; 1590 1591 croak "getGlobalProblem: requires 2 arguments" 1592 unless @_ == 3; 1593 croak "getGlobalProblem: argument 1 must contain a set_id" 1594 unless defined $setID; 1595 croak "getGlobalProblem: argument 2 must contain a problem_id" 1596 unless defined $problemID; 1597 1598 return $self->{problem}->get($setID, $problemID); 1599 } 1600 1601 =item getGlobalProblems(@problemIDs) 1602 1603 Return a list of global set records associated with the record IDs given. If 1604 there is no record associated with a given record ID, that element of the list 1605 will be undefined. @problemIDs consists of references to arrays in which the 1606 first element is the set_id, and the second element is the problem_id. 1607 1608 =cut 1609 1610 sub getGlobalProblems { 1611 my ($self, @problemIDs) = @_; 1612 1613 #croak "getGlobalProblems: requires 1 or more argument" 1614 # unless @_ >= 2; 1615 foreach my $i (0 .. $#problemIDs) { 1616 croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair" 1617 unless defined $problemIDs[$i] 1618 and ref $problemIDs[$i] eq "ARRAY" 1619 and @{$problemIDs[$i]} == 2 1620 and defined $problemIDs[$i]->[0] 1621 and defined $problemIDs[$i]->[1]; 1622 } 1623 1624 return $self->{problem}->gets(@problemIDs); 1625 } 1626 1627 =item getAllGlobalProblems($setID) 1628 1629 Returns a list of Problem objects representing all the problems in the given 1630 global set. When using the WW1Hash/GlobalTableEmulator schemas, this is far 1631 more efficient than using listGlobalProblems and getGlobalProblems. 1632 1633 =cut 1634 1635 sub getAllGlobalProblems { 1636 my ($self, $setID) = @_; 1637 1638 croak "getAllGlobalProblems: requires 1 arguments" 1639 unless @_ == 2; 1640 croak "getAllGlobalProblems: argument 1 must contain a set_id" 1641 unless defined $setID; 1642 1643 if ($self->{problem}->can("getAll")) { 1644 return $self->{problem}->getAll($setID); 1645 } else { 1646 my @problemIDPairs = $self->{problem}->list($setID, undef); 1647 return $self->{problem}->gets(@problemIDPairs); 1648 } 1649 } 1650 1651 sub putGlobalProblem { 1652 my ($self, $GlobalProblem) = @_; 1653 1654 croak "putGlobalProblem: requires 1 argument" 1655 unless @_ == 2; 1656 croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1657 unless ref $GlobalProblem eq $self->{problem}->{record}; 1658 1659 checkKeyfields($GlobalProblem); 1660 1661 croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)" 1662 unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1663 croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1664 unless $self->{set}->exists($GlobalProblem->set_id); 1665 1666 return $self->{problem}->put($GlobalProblem); 1667 } 1668 1669 sub deleteGlobalProblem { 1670 my ($self, $setID, $problemID) = @_; 1671 1672 croak "deleteGlobalProblem: requires 2 arguments" 1673 unless @_ == 3; 1674 croak "deleteGlobalProblem: argument 1 must contain a set_id" 1675 unless defined $setID or caller eq __PACKAGE__; 1676 croak "deleteGlobalProblem: argument 2 must contain a problem_id" 1677 unless defined $problemID or caller eq __PACKAGE__; 1678 1679 $self->deleteUserProblem(undef, $setID, $problemID); 1680 return $self->{problem}->delete($setID, $problemID); 1681 } 1682 1683 =back 1684 1685 =cut 1686 1687 ################################################################################ 1688 # problem_user functions 1689 ################################################################################ 1690 1691 =head2 User-Specific Problem Methods 1692 1693 FIXME: write this 1694 1695 =over 1696 1697 =cut 1698 1699 sub newUserProblem { 1700 my ($self, @prototype) = @_; 1701 return $self->{problem_user}->{record}->new(@prototype); 1702 } 1703 1704 sub countProblemUsers { 1705 my ($self, $setID, $problemID) = @_; 1706 1707 croak "countProblemUsers: requires 2 arguments" 1708 unless @_ == 3; 1709 croak "countProblemUsers: argument 1 must contain a set_id" 1710 unless defined $setID; 1711 croak "countProblemUsers: argument 2 must contain a problem_id" 1712 unless defined $problemID; 1713 1714 # the slow way 1715 #return scalar $self->{problem_user}->list(undef, $setID, $problemID); 1716 1717 # the fast way 1718 return $self->{problem_user}->count(undef, $setID, $problemID); 1719 } 1720 1721 sub listProblemUsers { 1722 my ($self, $setID, $problemID) = @_; 1723 1724 carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n" 1725 unless wantarray; 1726 1727 croak "listProblemUsers: requires 2 arguments" 1728 unless @_ == 3; 1729 croak "listProblemUsers: argument 1 must contain a set_id" 1730 unless defined $setID; 1731 croak "listProblemUsers: argument 2 must contain a problem_id" 1732 unless defined $problemID; 1733 1734 return map { $_->[0] } # extract user_id 1735 $self->{problem_user}->list(undef, $setID, $problemID); 1736 } 1737 1738 sub listUserProblems { 1739 my ($self, $userID, $setID) = @_; 1740 1741 croak "listUserProblems: requires 2 arguments" 1742 unless @_ == 3; 1743 croak "listUserProblems: argument 1 must contain a user_id" 1744 unless defined $userID; 1745 croak "listUserProblems: argument 2 must contain a set_id" 1746 unless defined $setID; 1747 1748 return map { $_->[2] } # extract problem_id 1749 $self->{problem_user}->list($userID, $setID, undef); 1750 } 1751 1752 sub addUserProblem { 1753 my ($self, $UserProblem) = @_; 1754 1755 croak "addUserProblem: requires 1 argument" 1756 unless @_ == 2; 1757 croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1758 unless ref $UserProblem eq $self->{problem_user}->{record}; 1759 1760 my $setID = $UserProblem->set_id; 1761 if ( $setID =~ /^(.*),v\d+/ ) { # then it's a versioned set 1762 $setID = $1; 1763 checkKeyfields($UserProblem, 1); 1764 } else { 1765 checkKeyfields($UserProblem); 1766 } 1767 1768 croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)" 1769 if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1770 croak "addUserProblem: user set $setID for user ", $UserProblem->user_id, " not found" 1771 unless $self->{set_user}->exists($UserProblem->user_id, $setID); 1772 croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $setID, " not found" 1773 unless $self->{problem}->exists($setID, $UserProblem->problem_id); 1774 1775 return $self->{problem_user}->add($UserProblem); 1776 } 1777 1778 sub getUserProblem { 1779 my ($self, $userID, $setID, $problemID) = @_; 1780 1781 croak "getUserProblem: requires 3 arguments" 1782 unless @_ == 4; 1783 croak "getUserProblem: argument 1 must contain a user_id" 1784 unless defined $userID; 1785 croak "getUserProblem: argument 2 must contain a set_id" 1786 unless defined $setID; 1787 croak "getUserProblem: argument 3 must contain a problem_id" 1788 unless defined $problemID; 1789 1790 return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0]; 1791 } 1792 1793 =item getUserProblems(@userProblemIDs) 1794 1795 Return a list of user set records associated with the user IDs given. If there 1796 is no record associated with a given user ID, that element of the list will be 1797 undefined. @userProblemIDs consists of references to arrays in which the first 1798 element is the user_id, the second element is the set_id, and the third element 1799 is the problem_id. 1800 1801 =cut 1802 1803 sub getUserProblems { 1804 my ($self, @userProblemIDs) = @_; 1805 1806 #croak "getUserProblems: requires 1 or more argument" 1807 # unless @_ >= 2; 1808 foreach my $i (0 .. $#userProblemIDs) { 1809 croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1810 unless defined $userProblemIDs[$i] 1811 and ref $userProblemIDs[$i] eq "ARRAY" 1812 and @{$userProblemIDs[$i]} == 3 1813 and defined $userProblemIDs[$i]->[0] 1814 and defined $userProblemIDs[$i]->[1] 1815 and defined $userProblemIDs[$i]->[2]; 1816 } 1817 1818 return $self->{problem_user}->gets(@userProblemIDs); 1819 } 1820 1821 =item getAllUserProblems($userID, $setID) 1822 1823 Returns a list of UserProblem objects representing all the problems in the 1824 given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far 1825 more efficient than using listUserProblems and getUserProblems. 1826 1827 =cut 1828 1829 sub getAllUserProblems { 1830 my ($self, $userID, $setID) = @_; 1831 1832 croak "getAllUserProblems: requires 2 arguments" 1833 unless @_ == 3; 1834 croak "getAllUserProblems: argument 1 must contain a user_id" 1835 unless defined $userID; 1836 croak "getAllUserProblems: argument 2 must contain a set_id" 1837 unless defined $setID; 1838 1839 if ($self->{problem_user}->can("getAll")) { 1840 return $self->{problem_user}->getAll($userID, $setID); 1841 } else { 1842 my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef); 1843 return $self->{problem_user}->gets(@problemIDTriples); 1844 } 1845 } 1846 1847 sub putUserProblem { 1848 my ($self, $UserProblem, $versioned) = @_; 1849 # $versioned is an optional argument which lets us slip versioned setIDs 1850 # through checkKeyfields. this makes the first croak message a little 1851 # disingenuous, of course. 1852 1853 croak "putUserProblem: requires 1 argument" 1854 unless @_ == 2 or @_ == 3; 1855 croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1856 unless ref $UserProblem eq $self->{problem_user}->{record}; 1857 1858 checkKeyfields($UserProblem, $versioned); 1859 1860 croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1861 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1862 croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)" 1863 unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1864 1865 # allow versioned set names when $versioned is defined and true 1866 my $unversionedSetID = $UserProblem->set_id; 1867 $unversionedSetID =~ s/,v\d+$// if ( defined($versioned) && $versioned ); 1868 croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1869 unless $self->{problem}->exists($unversionedSetID, $UserProblem->problem_id); 1870 1871 return $self->{problem_user}->put($UserProblem); 1872 } 1873 1874 sub deleteUserProblem { 1875 my ($self, $userID, $setID, $problemID) = @_; 1876 1877 croak "getUserProblem: requires 3 arguments" 1878 unless @_ == 4; 1879 croak "getUserProblem: argument 1 must contain a user_id" 1880 unless defined $userID or caller eq __PACKAGE__; 1881 croak "getUserProblem: argument 2 must contain a set_id" 1882 unless defined $setID or caller eq __PACKAGE__; 1883 croak "getUserProblem: argument 3 must contain a problem_id" 1884 unless defined $problemID or caller eq __PACKAGE__; 1885 1886 return $self->{problem_user}->delete($userID, $setID, $problemID); 1887 } 1888 1889 =back 1890 1891 =cut 1892 1893 ################################################################################ 1894 # set+set_user functions 1895 ################################################################################ 1896 1897 =head2 Set Merging Methods 1898 1899 These functions combine a global set and a user set to create a merged set, 1900 which is returned. Any field that is not defined in the user set is taken from 1901 the global set. Merged sets have the same type as user sets. 1902 1903 =over 1904 1905 =cut 1906 1907 sub getGlobalUserSet { 1908 carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead"; 1909 return shift->getMergedSet(@_); 1910 } 1911 1912 =item getMergedSet($userID, $setID) 1913 1914 Returns a merged set record associated with the record IDs given. If there is no 1915 record associated with a given record ID, the undefined value is returned. 1916 1917 =cut 1918 1919 sub getMergedSet { 1920 my ($self, $userID, $setID) = @_; 1921 1922 croak "getMergedSet: requires 2 arguments" 1923 unless @_ == 3; 1924 croak "getMergedSet: argument 1 must contain a user_id" 1925 unless defined $userID; 1926 croak "getMergedSet: argument 2 must contain a set_id" 1927 unless defined $setID; 1928 1929 return ( $self->getMergedSets([$userID, $setID]) )[0]; 1930 } 1931 1932 sub getMergedVersionedSet { 1933 my ( $self, $userID, $setID, $versionNum ) = @_; 1934 # 1935 # getMergedVersionedSet( self, uid, sid [, versionNum] ) 1936 # in: userID uid, setID sid, and optionally version number versionNum 1937 # out: the merged set version for the user; if versionNum is specified, 1938 # return that set version and otherwise the latest version. if 1939 # no versioned set exists for the user, return undef. 1940 # note that sid can be setid,vN, thereby specifying the version number 1941 # explicitly. if this is the case, any specified versionNum is ignored 1942 # we'd like to use getMergedSet to do the dirty work here, but that runs 1943 # into problems because we want to merge with both the template set 1944 # (that is, the userSet setID) and the global set 1945 1946 croak "getMergedVersionedSet: requires at least two arguments, a userID " . 1947 "and setID (missing setID)" if ( @_ < 3 || ! defined( $setID ) ); 1948 1949 my $versionedSetID = $setID; 1950 1951 if ( ( ! defined($versionNum) || ! $versionNum ) && $setID !~ /,v\d+$/ ) { 1952 $versionNum = $self->getUserSetVersionNumber( $userID, $setID ); 1953 1954 if ( ! $versionNum ) { 1955 return undef; 1956 } else { 1957 $versionedSetID .= ",v$versionNum"; 1958 } 1959 } elsif ( defined($versionNum) && $versionNum ) { 1960 $versionedSetID = ($setID =~ /,v\d+$/ ? $setID : "$setID,v$versionNum"); 1961 } else { # the last case is that $setID =~ /,v\d+$/ 1962 $setID =~ s/,v\d+//; 1963 } 1964 1965 croak "getMergedVersionedSet: requires at least two arguments, a userID " . 1966 "and setID (missing userID)" if ( ! defined( $userID ) ); 1967 1968 return ( $self->getMergedVersionedSets( [$userID, $setID, 1969 $versionedSetID] ) )[0]; 1970 } 1971 1972 1973 =item getMegedSets(@userSetIDs) 1974 1975 Return a list of merged set records associated with the record IDs given. If 1976 there is no record associated with a given record ID, that element of the list 1977 will be undefined. @userSetIDs consists of references to arrays in which the 1978 first element is the user_id and the second element is the set_id. 1979 1980 =cut 1981 1982 sub getMergedSets { 1983 my ($self, @userSetIDs) = @_; 1984 1985 #croak "getMergedSets: requires 1 or more argument" 1986 # unless @_ >= 2; 1987 foreach my $i (0 .. $#userSetIDs) { 1988 croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair" 1989 unless defined $userSetIDs[$i] 1990 and ref $userSetIDs[$i] eq "ARRAY" 1991 and @{$userSetIDs[$i]} == 2 1992 and defined $userSetIDs[$i]->[0] 1993 and defined $userSetIDs[$i]->[1]; 1994 } 1995 1996 # a horrible, terrible hack ;) 1997 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash" 1998 and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") { 1999 #warn __PACKAGE__.": using a terrible hack.\n"; 2000 $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer); 2001 my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs); 2002 $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer); 2003 return @MergedSets; 2004 } 2005 2006 $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer); 2007 my @UserSets = $self->getUserSets(@userSetIDs); # checked 2008 2009 $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer); 2010 my @globalSetIDs = map { $_->[1] } @userSetIDs; 2011 $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer); 2012 my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked 2013 2014 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 2015 my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS; 2016 my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS; 2017 2018 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 2019 for (my $i = 0; $i < @UserSets; $i++) { 2020 my $UserSet = $UserSets[$i]; 2021 my $GlobalSet = $GlobalSets[$i]; 2022 next unless defined $UserSet and defined $GlobalSet; 2023 foreach my $field (@commonFields) { 2024 #next if defined $UserSet->$field; 2025 # ok, now we're testing for emptiness as well as definedness. 2026 next if defined $UserSet->$field and $UserSet->$field ne ""; 2027 $UserSet->$field($GlobalSet->$field); 2028 } 2029 } 2030 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 2031 2032 return @UserSets; 2033 } 2034 2035 sub getMergedVersionedSets { 2036 my ($self, @userSetIDs) = @_; 2037 2038 foreach my $i (0 .. $#userSetIDs) { 2039 croak "getMergedSets: element $i of argument list must contain a " . 2040 "<user_id, set_id, versioned_set_id> triple" 2041 unless( defined $userSetIDs[$i] 2042 and ref $userSetIDs[$i] eq "ARRAY" 2043 and @{$userSetIDs[$i]} == 3 2044 and defined $userSetIDs[$i]->[0] 2045 and defined $userSetIDs[$i]->[1] 2046 and defined $userSetIDs[$i]->[2] ); 2047 } 2048 2049 # these are [user_id, set_id] pairs 2050 my @nonversionedUserSetIDs = map { [$_->[0], $_->[1]] } @userSetIDs; 2051 # these are [user_id, versioned_set_id] pairs 2052 my @versionedUserSetIDs = map { [$_->[0], $_->[2]] } @userSetIDs; 2053 2054 # FIXME as long as we're ignoring the global user for gdbm, this is ok... 2055 # (are we?) FIXME 2056 # a horrible, terrible hack ;) 2057 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash" 2058 and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") { 2059 #warn __PACKAGE__.": using a terrible hack.\n"; 2060 $WeBWorK::timer->continue("DB: getsNoFilter start") 2061 if defined($WeBWorK::timer); 2062 my @MergedSets = $self->{set_user}->getsNoFilter(@versionedUserSetIDs); 2063 $WeBWorK::timer->continue("DB: getsNoFilter end") 2064 if defined($WeBWorK::timer); 2065 return @MergedSets; 2066 } 2067 2068 # we merge the nonversioned ("template") user sets (user_id, set_id) and 2069 # the global data into the versioned user sets 2070 $WeBWorK::timer->continue("DB: getUserSets start (nonversioned)") 2071 if defined($WeBWorK::timer); 2072 my @TemplateUserSets = $self->getUserSets(@nonversionedUserSetIDs); 2073 $WeBWorK::timer->continue("DB: getUserSets start (versioned)") 2074 if defined($WeBWorK::timer); 2075 # these are the actual user sets that we want to use 2076 my @versionedUserSets = $self->getUserSets(@versionedUserSetIDs); 2077 2078 $WeBWorK::timer->continue("DB: pull out set IDs start") 2079 if defined($WeBWorK::timer); 2080 my @globalSetIDs = map { $_->[1] } @userSetIDs; 2081 $WeBWorK::timer->continue("DB: getGlobalSets start") 2082 if defined($WeBWorK::timer); 2083 my @GlobalSets = $self->getGlobalSets(@globalSetIDs); 2084 2085 $WeBWorK::timer->continue("DB: calc common fields start") 2086 if defined($WeBWorK::timer); 2087 my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS; 2088 my @commonFields = 2089 grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS; 2090 2091 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 2092 for (my $i = 0; $i < @TemplateUserSets; $i++) { 2093 my $VersionedSet = $versionedUserSets[$i]; 2094 my $TemplateSet = $TemplateUserSets[$i]; 2095 my $GlobalSet = $GlobalSets[$i]; 2096 # shouldn't all of these necessarily be defined? Hmm. 2097 next unless( defined $VersionedSet and (defined $TemplateSet or 2098 defined $GlobalSet) ); 2099 foreach my $field (@commonFields) { 2100 next if defined $VersionedSet->$field; 2101 $VersionedSet->$field($GlobalSet->$field) if (defined($GlobalSet)); 2102 $VersionedSet->$field($TemplateSet->$field) 2103 if (defined($TemplateSet) && defined($TemplateSet->$field)); 2104 } 2105 } 2106 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 2107 2108 return @versionedUserSets; 2109 } 2110 2111 =back 2112 2113 =cut 2114 2115 ################################################################################ 2116 # problem+problem_user functions 2117 ################################################################################ 2118 2119 =head2 Problem Merging Methods 2120 2121 These functions combine a global problem and a user problem to create a merged 2122 problem, which is returned. Any field that is not defined in the user problem is 2123 taken from the global problem. Merged problems have the same type as user 2124 problems. 2125 2126 =over 2127 2128 =cut 2129 2130 sub getGlobalUserProblem { 2131 carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead"; 2132 return shift->getMergedProblem(@_); 2133 } 2134 2135 =item getMergedProblem($userID, $setID, $problemID) 2136 2137 Returns a merged problem record associated with the record IDs given. If there 2138 is no record associated with a given record ID, the undefined value is returned. 2139 2140 =cut 2141 2142 sub getMergedProblem { 2143 my ($self, $userID, $setID, $problemID) = @_; 2144 2145 croak "getGlobalUserSet: requires 3 arguments" 2146 unless @_ == 4; 2147 croak "getGlobalUserSet: argument 1 must contain a user_id" 2148 unless defined $userID; 2149 croak "getGlobalUserSet: argument 2 must contain a set_id" 2150 unless defined $setID; 2151 croak "getGlobalUserSet: argument 3 must contain a problem_id" 2152 unless defined $problemID; 2153 2154 return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0]; 2155 } 2156 2157 sub getMergedVersionedProblem { 2158 my ($self, $userID, $setID, $setVersionID, $problemID) = @_; 2159 2160 # this exists distinct from getMergedProblem only to be able to include the 2161 # setVersionID 2162 2163 croak "getGlobalUserSet: requires 4 arguments" 2164 unless @_ == 5; 2165 croak "getGlobalUserSet: argument 1 must contain a user_id" 2166 unless defined $userID; 2167 croak "getGlobalUserSet: argument 2 must contain a set_id" 2168 unless defined $setID; 2169 croak "getGlobalUserSet: argument 3 must contain a set_id" 2170 unless defined $setVersionID; 2171 croak "getGlobalUserSet: argument 4 must contain a problem_id" 2172 unless defined $problemID; 2173 2174 return ($self->getMergedVersionedProblems([$userID, $setID, $setVersionID, 2175 $problemID]))[0]; 2176 } 2177 2178 =item getMergedProblems(@userProblemIDs) 2179 2180 Return a list of merged problem records associated with the record IDs given. If 2181 there is no record associated with a given record ID, that element of the list 2182 will be undefined. @userProblemIDs consists of references to arrays in which the 2183 first element is the user_id, the second element is the set_id, and the third 2184 element is the problem_id. 2185 2186 =cut 2187 2188 sub getMergedProblems { 2189 my ($self, @userProblemIDs) = @_; 2190 2191 #croak "getMergedProblems: requires 1 or more argument" 2192 # unless @_ >= 2; 2193 foreach my $i (0 .. $#userProblemIDs) { 2194 croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 2195 unless defined $userProblemIDs[$i] 2196 and ref $userProblemIDs[$i] eq "ARRAY" 2197 and @{$userProblemIDs[$i]} == 3 2198 and defined $userProblemIDs[$i]->[0] 2199 and defined $userProblemIDs[$i]->[1] 2200 and defined $userProblemIDs[$i]->[2]; 2201 } 2202 2203 $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer); 2204 my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked 2205 2206 $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer); 2207 my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs; 2208 $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer); 2209 my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked 2210 2211 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 2212 my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS; 2213 my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS; 2214 2215 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 2216 for (my $i = 0; $i < @UserProblems; $i++) { 2217 my $UserProblem = $UserProblems[$i]; 2218 my $GlobalProblem = $GlobalProblems[$i]; 2219 next unless defined $UserProblem and defined $GlobalProblem; 2220 foreach my $field (@commonFields) { 2221 # FIXME: WW1Hash upgrades undefined fileds to "" when creating record objects 2222 # Shouldn't we be testing for emptiness rather than definedness? 2223 # I think the spec says that if a field is EMPTY the global value is used. 2224 #next if defined $UserProblem->$field; 2225 # ok, now we're testing for emptiness as well as definedness. 2226 next if defined $UserProblem->$field and $UserProblem->$field ne ""; 2227 $UserProblem->$field($GlobalProblem->$field); 2228 } 2229 } 2230 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 2231 2232 return @UserProblems; 2233 } 2234 2235 sub getMergedVersionedProblems { 2236 my ($self, @userProblemIDs) = @_; 2237 2238 foreach my $i (0 .. $#userProblemIDs) { 2239 croak "getMergedProblems: element $i of argument list must contain a " . 2240 "<user_id, set_id, versioned_set_id, problem_id> quadruple" 2241 unless( defined $userProblemIDs[$i] 2242 and ref $userProblemIDs[$i] eq "ARRAY" 2243 and @{$userProblemIDs[$i]} == 4 2244 and defined $userProblemIDs[$i]->[0] 2245 and defined $userProblemIDs[$i]->[1] 2246 and defined $userProblemIDs[$i]->[2] 2247 and defined $userProblemIDs[$i]->[3] ); 2248 } 2249 2250 $WeBWorK::timer->continue("DB: getUserProblems start") 2251 if defined($WeBWorK::timer); 2252 2253 # these are triples [user_id, set_id, problem_id] 2254 my @nonversionedProblemIDs = map {[$_->[0],$_->[1],$_->[3]]} @userProblemIDs; 2255 # these are triples [user_id, versioned_set_id, problem_id] 2256 my @versionedProblemIDs = map {[$_->[0],$_->[2],$_->[3]]} @userProblemIDs; 2257 2258 # these are the actual user problems for the version 2259 my @versionUserProblems = $self->getUserProblems(@versionedProblemIDs); 2260 2261 # get global problems (no user_id, set_id = nonversioned set_id) and 2262 # template problems (user_id, set_id = nonversioned set_id); we merge with 2263 # both of these, replacing global values with template values and not 2264 # taking either in the event that the versioned problem already has a 2265 # value for the field in question 2266 $WeBWorK::timer->continue("DB: pull out set/problem IDs start") 2267 if defined($WeBWorK::timer); 2268 my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @nonversionedProblemIDs; 2269 $WeBWorK::timer->continue("DB: getGlobalProblems start") 2270 if defined($WeBWorK::timer); 2271 my @GlobalProblems = $self->getGlobalProblems( @globalProblemIDs ); 2272 $WeBWorK::timer->continue("DB: getTemplateProblems start") 2273 if defined($WeBWorK::timer); 2274 my @TemplateProblems = $self->getUserProblems( @nonversionedProblemIDs ); 2275 2276 $WeBWorK::timer->continue("DB: calc common fields start") 2277 if defined($WeBWorK::timer); 2278 2279 my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS; 2280 my @commonFields = 2281 grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS; 2282 2283 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 2284 for (my $i = 0; $i < @versionUserProblems; $i++) { 2285 my $UserProblem = $versionUserProblems[$i]; 2286 my $GlobalProblem = $GlobalProblems[$i]; 2287 my $TemplateProblem = $TemplateProblems[$i]; 2288 next unless defined $UserProblem and ( defined $GlobalProblem or 2289 defined $TemplateProblem ); 2290 foreach my $field (@commonFields) { 2291 next if defined $UserProblem->$field; 2292 $UserProblem->$field($GlobalProblem->$field) 2293 if ( defined($GlobalProblem) && defined($GlobalProblem->$field) 2294 && $GlobalProblem->$field ne '' ); 2295 $UserProblem->$field($TemplateProblem->$field) 2296 if ( defined($TemplateProblem) && 2297 defined($TemplateProblem->$field) && 2298 $TemplateProblem->$field ne '' ); 2299 } 2300 } 2301 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 2302 2303 return @versionUserProblems; 2304 } 2305 2306 =back 2307 2308 =cut 2309 2310 ################################################################################ 2311 # debugging 2312 ################################################################################ 2313 2314 #sub dumpDB($$) { 2315 # my ($self, $table) = @_; 2316 # return $self->{$table}->dumpDB(); 2317 #} 2318 2319 ################################################################################ 2320 # utilities 2321 ################################################################################ 2322 2323 sub checkKeyfields($;$) { 2324 my ($Record, $versioned) = @_; 2325 foreach my $keyfield ($Record->KEYFIELDS) { 2326 my $value = $Record->$keyfield; 2327 croak "checkKeyfields: $keyfield is empty" 2328 unless defined $value and $value ne ""; 2329 2330 if ($keyfield eq "problem_id") { 2331 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])" 2332 unless $value =~ m/^\d*$/; 2333 } else { 2334 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])" 2335 # this logic is a bit ugly, but it enforces what we want, 2336 # which is that only versioned problem sets are allowed 2337 # to include commas in their names. or, to allow for 2338 # proctor keys, user_ids can have commas too 2339 unless ( $value =~ m/^[\w-]*$/ || 2340 ( $value =~ m/^[\w,-]*$/ && 2341 (defined($versioned) && $versioned) 2342 && 2343 ($keyfield eq "set_id" || 2344 $keyfield eq "user_id") ) ); 2345 } 2346 } 2347 } 2348 2349 =head1 AUTHOR 2350 2351 Written by Sam Hathaway, sh002i (at) math.rochester.edu. 2352 2353 =cut 2354 2355 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |