Parent Directory
| 
Revision Log
optimized the hell out of the database checking code
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork-modperl/lib/WeBWorK/DB.pm,v 1.51 2004/06/16 18:26:59 toenail 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 =cut 825 826 sub addKey($$) { 827 my ($self, $Key) = @_; 828 829 croak "addKey: requires 1 argument" 830 unless @_ == 2; 831 croak "addKey: argument 1 must be of type ", $self->{key}->{record} 832 unless ref $Key eq $self->{key}->{record}; 833 834 checkKeyfields($Key); 835 836 croak "addKey: key exists (perhaps you meant to use putKey?)" 837 if $self->{key}->exists($Key->user_id); 838 croak "addKey: user ", $Key->user_id, " not found" 839 unless $self->{user}->exists($Key->user_id); 840 841 return $self->{key}->add($Key); 842 } 843 844 =item getKey($userID) 845 846 If a record with a matching user ID exists, a record object containting that 847 record's data will be returned. If no such record exists, an undefined value 848 will be returned. 849 850 =cut 851 852 sub getKey($$) { 853 my ($self, $userID) = @_; 854 855 croak "getKey: requires 1 argument" 856 unless @_ == 2; 857 croak "getKey: argument 1 must contain a user_id" 858 unless defined $userID; 859 860 return $self->{key}->get($userID); 861 } 862 863 =item getKeys(@uesrIDs) 864 865 Return a list of key records associated with the user IDs given. If there is no 866 record associated with a given user ID, that element of the list will be 867 undefined. 868 869 =cut 870 871 sub getKeys { 872 my ($self, @userIDs) = @_; 873 874 #croak "getKeys: requires 1 or more argument" 875 # unless @_ >= 2; 876 foreach my $i (0 .. $#userIDs) { 877 croak "getKeys: element $i of argument list must contain a user_id" 878 unless defined $userIDs[$i]; 879 } 880 881 return $self->{key}->gets(map { [$_] } @userIDs); 882 } 883 884 =item putKey($Key) 885 886 $Key is a record object. If a key record with the same user ID exists in the 887 key table, the data in the record is replaced with the data in $Key. If a 888 matching key record does not exist, an exception is thrown. 889 890 =cut 891 892 sub putKey($$) { 893 my ($self, $Key) = @_; 894 895 croak "putKey: requires 1 argument" 896 unless @_ == 2; 897 croak "putKey: argument 1 must be of type ", $self->{key}->{record} 898 unless ref $Key eq $self->{key}->{record}; 899 900 checkKeyfields($Key); 901 902 croak "putKey: key not found (perhaps you meant to use addKey?)" 903 unless $self->{key}->exists($Key->user_id); 904 905 return $self->{key}->put($Key); 906 } 907 908 =item deleteKey($userID) 909 910 If a key record with a user ID matching $userID exists in the key table, it is 911 removed and the method returns a true value. If one does exist, a false value 912 is returned. 913 914 =cut 915 916 sub deleteKey($$) { 917 my ($self, $userID) = @_; 918 919 croak "deleteKey: requires 1 argument" 920 unless @_ == 2; 921 croak "deleteKey: argument 1 must contain a user_id" 922 unless defined $userID; 923 924 return $self->{key}->delete($userID); 925 } 926 927 ################################################################################ 928 # user functions 929 ################################################################################ 930 931 =head2 User Methods 932 933 =over 934 935 =item newUser() 936 937 Returns a new, empty user object. 938 939 =cut 940 941 sub newUser { 942 my ($self, @prototype) = @_; 943 return $self->{user}->{record}->new(@prototype); 944 } 945 946 =item listUsers() 947 948 Returns a list of user IDs representing the records in the user table. 949 950 =cut 951 952 sub listUsers { 953 my ($self) = @_; 954 955 croak "listUsers: requires 0 arguments" 956 unless @_ == 1; 957 958 return map { $_->[0] } 959 $self->{user}->list(undef); 960 } 961 962 =item addUser($User) 963 964 $User is a record object. The user will be added to the user table if a user 965 with the same user ID does not already exist. If one does exist, an exception 966 is thrown. 967 968 =cut 969 970 sub addUser { 971 my ($self, $User) = @_; 972 973 croak "addUser: requires 1 argument" 974 unless @_ == 2; 975 croak "addUser: argument 1 must be of type ", $self->{user}->{record} 976 unless ref $User eq $self->{user}->{record}; 977 978 checkKeyfields($User); 979 980 croak "addUser: user exists (perhaps you meant to use putUser?)" 981 if $self->{user}->exists($User->user_id); 982 983 return $self->{user}->add($User); 984 } 985 986 =item getUser($userID) 987 988 If a record with a matching user ID exists, a record object containting that 989 record's data will be returned. If no such record exists, an undefined value 990 will be returned. 991 992 =cut 993 994 sub getUser { 995 my ($self, $userID) = @_; 996 997 croak "getUser: requires 1 argument" 998 unless @_ == 2; 999 croak "getUser: argument 1 must contain a user_id" 1000 unless defined $userID; 1001 1002 return $self->{user}->get($userID); 1003 } 1004 1005 =item getUsers(@uesrIDs) 1006 1007 Return a list of user records associated with the user IDs given. If there is no 1008 record associated with a given user ID, that element of the list will be 1009 undefined. 1010 1011 =cut 1012 1013 sub getUsers { 1014 my ($self, @userIDs) = @_; 1015 1016 #croak "getUsers: requires 1 or more argument" 1017 # unless @_ >= 2; 1018 foreach my $i (0 .. $#userIDs) { 1019 croak "getUsers: element $i of argument list must contain a user_id" 1020 unless defined $userIDs[$i]; 1021 } 1022 1023 return $self->{user}->gets(map { [$_] } @userIDs); 1024 } 1025 1026 =item putUser($User) 1027 1028 $User is a record object. If a user record with the same user ID exists in the 1029 user table, the data in the record is replaced with the data in $User. If a 1030 matching user record does not exist, an exception is thrown. 1031 1032 =cut 1033 1034 sub putUser { 1035 my ($self, $User) = @_; 1036 1037 croak "putUser: requires 1 argument" 1038 unless @_ == 2; 1039 croak "putUser: argument 1 must be of type ", $self->{user}->{record} 1040 unless ref $User eq $self->{user}->{record}; 1041 1042 checkKeyfields($User); 1043 1044 croak "putUser: user not found (perhaps you meant to use addUser?)" 1045 unless $self->{user}->exists($User->user_id); 1046 1047 return $self->{user}->put($User); 1048 } 1049 1050 =item deleteUser($userID) 1051 1052 If a user record with a user ID matching $userID exists in the user table, it 1053 is removed and the method returns a true value. If one does exist, a false 1054 value is returned. When a user record is deleted, all records associated with 1055 that user are also deleted. This includes the password, permission, and key 1056 records, and all user set records for that user. 1057 1058 =cut 1059 1060 sub deleteUser { 1061 my ($self, $userID) = @_; 1062 1063 croak "deleteUser: requires 1 argument" 1064 unless @_ == 2; 1065 croak "deleteUser: argument 1 must contain a user_id" 1066 unless defined $userID; 1067 1068 $self->deleteUserSet($userID, undef); 1069 $self->deletePassword($userID); 1070 $self->deletePermissionLevel($userID); 1071 $self->deleteKey($userID); 1072 return $self->{user}->delete($userID); 1073 } 1074 1075 =back 1076 1077 =cut 1078 1079 ################################################################################ 1080 # set functions 1081 ################################################################################ 1082 1083 =head2 Global Set Methods 1084 1085 FIXME: write this 1086 1087 =over 1088 1089 =cut 1090 1091 =item newGlobalSet() 1092 1093 =cut 1094 1095 sub newGlobalSet { 1096 my ($self, @prototype) = @_; 1097 return $self->{set}->{record}->new(@prototype); 1098 } 1099 1100 =item listGlobalSets() 1101 1102 =cut 1103 1104 sub listGlobalSets { 1105 my ($self) = @_; 1106 1107 croak "listGlobalSets: requires 0 arguments" 1108 unless @_ == 1; 1109 1110 return map { $_->[0] } 1111 $self->{set}->list(undef); 1112 } 1113 1114 =item addGlobalSet($GlobalSet) 1115 1116 =cut 1117 1118 sub addGlobalSet { 1119 my ($self, $GlobalSet) = @_; 1120 1121 croak "addGlobalSet: requires 1 argument" 1122 unless @_ == 2; 1123 croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record} 1124 unless ref $GlobalSet eq $self->{set}->{record}; 1125 1126 checkKeyfields($GlobalSet); 1127 1128 croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)" 1129 if $self->{set}->exists($GlobalSet->set_id); 1130 1131 return $self->{set}->add($GlobalSet); 1132 } 1133 1134 =item addGlobalSet($setID) 1135 1136 =cut 1137 1138 sub getGlobalSet { 1139 my ($self, $setID) = @_; 1140 1141 croak "getGlobalSet: requires 1 argument" 1142 unless @_ == 2; 1143 croak "getGlobalSet: argument 1 must contain a set_id" 1144 unless defined $setID; 1145 1146 return $self->{set}->get($setID); 1147 } 1148 1149 =item getGlobalSets(@setIDs) 1150 1151 Return a list of global set records associated with the record IDs given. If 1152 there is no record associated with a given record ID, that element of the list 1153 will be undefined. 1154 1155 =cut 1156 1157 sub getGlobalSets { 1158 my ($self, @setIDs) = @_; 1159 1160 #croak "getGlobalSets: requires 1 or more argument" 1161 # unless @_ >= 2; 1162 foreach my $i (0 .. $#setIDs) { 1163 croak "getGlobalSets: element $i of argument list must contain a set_id" 1164 unless defined $setIDs[$i]; 1165 } 1166 1167 return $self->{set}->gets(map { [$_] } @setIDs); 1168 } 1169 1170 =item addGlobalSet($GlobalSet) 1171 1172 =cut 1173 1174 sub putGlobalSet { 1175 my ($self, $GlobalSet) = @_; 1176 1177 croak "putGlobalSet: requires 1 argument" 1178 unless @_ == 2; 1179 croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record} 1180 unless ref $GlobalSet eq $self->{set}->{record}; 1181 1182 checkKeyfields($GlobalSet); 1183 1184 croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)" 1185 unless $self->{set}->exists($GlobalSet->set_id); 1186 1187 return $self->{set}->put($GlobalSet); 1188 } 1189 1190 =item addGlobalSet($setID) 1191 1192 =cut 1193 1194 sub deleteGlobalSet { 1195 my ($self, $setID) = @_; 1196 1197 croak "deleteGlobalSet: requires 1 argument" 1198 unless @_ == 2; 1199 croak "deleteGlobalSet: argument 1 must contain a set_id" 1200 unless defined $setID or caller eq __PACKAGE__; 1201 1202 $self->deleteUserSet(undef, $setID); 1203 $self->deleteGlobalProblem($setID, undef); 1204 return $self->{set}->delete($setID); 1205 } 1206 1207 =back 1208 1209 =cut 1210 1211 ################################################################################ 1212 # set_user functions 1213 ################################################################################ 1214 1215 =head2 User-Specific Set Methods 1216 1217 FIXME: write this 1218 1219 =over 1220 1221 =cut 1222 1223 sub newUserSet { 1224 my ($self, @prototype) = @_; 1225 return $self->{set_user}->{record}->new(@prototype); 1226 } 1227 1228 sub countSetUsers { 1229 my ($self, $setID) = @_; 1230 1231 croak "countSetUsers: requires 1 argument" 1232 unless @_ == 2; 1233 croak "countSetUsers: argument 1 must contain a set_id" 1234 unless defined $setID; 1235 1236 # inefficient way 1237 #return scalar $self->{set_user}->list(undef, $setID); 1238 1239 # efficient way 1240 return $self->{set_user}->count(undef, $setID); 1241 } 1242 1243 sub listSetUsers { 1244 my ($self, $setID) = @_; 1245 1246 carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n" 1247 unless wantarray; 1248 1249 croak "listSetUsers: requires 1 argument" 1250 unless @_ == 2; 1251 croak "listSetUsers: argument 1 must contain a set_id" 1252 unless defined $setID; 1253 1254 return map { $_->[0] } # extract user_id 1255 $self->{set_user}->list(undef, $setID); 1256 } 1257 1258 sub countUserSets { 1259 my ($self, $userID) = @_; 1260 1261 croak "countUserSets: requires 1 argument" 1262 unless @_ == 2; 1263 croak "countUserSets: argument 1 must contain a user_id" 1264 unless defined $userID; 1265 1266 return $self->{set_user}->count($userID, undef); 1267 } 1268 1269 sub listUserSets { 1270 my ($self, $userID) = @_; 1271 1272 croak "listUserSets: requires 1 argument" 1273 unless @_ == 2; 1274 croak "listUserSets: argument 1 must contain a user_id" 1275 unless defined $userID; 1276 1277 return map { $_->[1] } # extract set_id 1278 $self->{set_user}->list($userID, undef); 1279 } 1280 1281 sub addUserSet { 1282 my ($self, $UserSet) = @_; 1283 1284 croak "addUserSet: requires 1 argument" 1285 unless @_ == 2; 1286 croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1287 unless ref $UserSet eq $self->{set_user}->{record}; 1288 1289 checkKeyfields($UserSet); 1290 1291 croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)" 1292 if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1293 croak "addUserSet: user ", $UserSet->user_id, " not found" 1294 unless $self->{user}->exists($UserSet->user_id); 1295 croak "addUserSet: set ", $UserSet->set_id, " not found" 1296 unless $self->{set}->exists($UserSet->set_id); 1297 1298 return $self->{set_user}->add($UserSet); 1299 } 1300 1301 sub getUserSet { 1302 my ($self, $userID, $setID) = @_; 1303 1304 croak "getUserSet: requires 2 arguments" 1305 unless @_ == 3; 1306 croak "getUserSet: argument 1 must contain a user_id" 1307 unless defined $userID; 1308 croak "getUserSet: argument 2 must contain a set_id" 1309 unless defined $setID; 1310 1311 #return $self->{set_user}->get($userID, $setID); 1312 return ( $self->getUserSets([$userID, $setID]) )[0]; 1313 } 1314 1315 =item getUserSets(@userSetIDs) 1316 1317 Return a list of user set records associated with the record IDs given. If there 1318 is no record associated with a given record ID, that element of the list will be 1319 undefined. @userProblemIDs consists of references to arrays in which the first 1320 element is the user_id and the second element is the set_id. 1321 1322 =cut 1323 1324 sub getUserSets { 1325 my ($self, @userSetIDs) = @_; 1326 1327 #croak "getUserSets: requires 1 or more argument" 1328 # unless @_ >= 2; 1329 foreach my $i (0 .. $#userSetIDs) { 1330 croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair" 1331 unless defined $userSetIDs[$i] 1332 and ref $userSetIDs[$i] eq "ARRAY" 1333 and @{$userSetIDs[$i]} == 2 1334 and defined $userSetIDs[$i]->[0] 1335 and defined $userSetIDs[$i]->[1]; 1336 } 1337 1338 return $self->{set_user}->gets(@userSetIDs); 1339 } 1340 1341 sub putUserSet { 1342 my ($self, $UserSet) = @_; 1343 1344 croak "putUserSet: requires 1 argument" 1345 unless @_ == 2; 1346 croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1347 unless ref $UserSet eq $self->{set_user}->{record}; 1348 1349 checkKeyfields($UserSet); 1350 1351 croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)" 1352 unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1353 croak "putUserSet: user ", $UserSet->user_id, " not found" 1354 unless $self->{user}->exists($UserSet->user_id); 1355 croak "putUserSet: set ", $UserSet->set_id, " not found" 1356 unless $self->{set}->exists($UserSet->set_id); 1357 1358 return $self->{set_user}->put($UserSet); 1359 } 1360 1361 sub deleteUserSet { 1362 my ($self, $userID, $setID) = @_; 1363 1364 croak "getUserSet: requires 2 arguments" 1365 unless @_ == 3; 1366 croak "getUserSet: argument 1 must contain a user_id" 1367 unless defined $userID or caller eq __PACKAGE__; 1368 croak "getUserSet: argument 2 must contain a set_id" 1369 unless defined $userID or caller eq __PACKAGE__; 1370 1371 $self->deleteUserProblem($userID, $setID, undef); 1372 return $self->{set_user}->delete($userID, $setID); 1373 } 1374 1375 =back 1376 1377 =cut 1378 1379 ################################################################################ 1380 # problem functions 1381 ################################################################################ 1382 1383 =head2 Global Problem Methods 1384 1385 FIXME: write this 1386 1387 =over 1388 1389 =cut 1390 1391 sub newGlobalProblem { 1392 my ($self, @prototype) = @_; 1393 return $self->{problem}->{record}->new(@prototype); 1394 } 1395 1396 sub listGlobalProblems { 1397 my ($self, $setID) = @_; 1398 1399 croak "listGlobalProblems: requires 1 arguments" 1400 unless @_ == 2; 1401 croak "listGlobalProblems: argument 1 must contain a set_id" 1402 unless defined $setID; 1403 1404 return map { $_->[1] } 1405 $self->{problem}->list($setID, undef); 1406 } 1407 1408 sub addGlobalProblem { 1409 my ($self, $GlobalProblem) = @_; 1410 1411 croak "addGlobalProblem: requires 1 argument" 1412 unless @_ == 2; 1413 croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1414 unless ref $GlobalProblem eq $self->{problem}->{record}; 1415 1416 checkKeyfields($GlobalProblem); 1417 1418 croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)" 1419 if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1420 croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1421 unless $self->{set}->exists($GlobalProblem->set_id); 1422 1423 return $self->{problem}->add($GlobalProblem); 1424 } 1425 1426 sub getGlobalProblem { 1427 my ($self, $setID, $problemID) = @_; 1428 1429 croak "getGlobalProblem: requires 2 arguments" 1430 unless @_ == 3; 1431 croak "getGlobalProblem: argument 1 must contain a set_id" 1432 unless defined $setID; 1433 croak "getGlobalProblem: argument 2 must contain a problem_id" 1434 unless defined $problemID; 1435 1436 return $self->{problem}->get($setID, $problemID); 1437 } 1438 1439 =item getGlobalProblems(@problemIDs) 1440 1441 Return a list of global set records associated with the record IDs given. If 1442 there is no record associated with a given record ID, that element of the list 1443 will be undefined. @problemIDs consists of references to arrays in which the 1444 first element is the set_id, and the second element is the problem_id. 1445 1446 =cut 1447 1448 sub getGlobalProblems { 1449 my ($self, @problemIDs) = @_; 1450 1451 #croak "getGlobalProblems: requires 1 or more argument" 1452 # unless @_ >= 2; 1453 foreach my $i (0 .. $#problemIDs) { 1454 croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair" 1455 unless defined $problemIDs[$i] 1456 and ref $problemIDs[$i] eq "ARRAY" 1457 and @{$problemIDs[$i]} == 2 1458 and defined $problemIDs[$i]->[0] 1459 and defined $problemIDs[$i]->[1]; 1460 } 1461 1462 return $self->{problem}->gets(@problemIDs); 1463 } 1464 1465 =item getAllGlobalProblems($setID) 1466 1467 Returns a list of Problem objects representing all the problems in the given 1468 global set. When using the WW1Hash/GlobalTableEmulator schemas, this is far 1469 more efficient than using listGlobalProblems and getGlobalProblems. 1470 1471 =cut 1472 1473 sub getAllGlobalProblems { 1474 my ($self, $setID) = @_; 1475 1476 croak "getAllGlobalProblems: requires 1 arguments" 1477 unless @_ == 2; 1478 croak "getAllGlobalProblems: argument 1 must contain a set_id" 1479 unless defined $setID; 1480 1481 if ($self->{problem}->can("getAll")) { 1482 return $self->{problem}->getAll($setID); 1483 } else { 1484 my @problemIDPairs = $self->{problem}->list($setID, undef); 1485 return $self->{problem}->gets(@problemIDPairs); 1486 } 1487 } 1488 1489 sub putGlobalProblem { 1490 my ($self, $GlobalProblem) = @_; 1491 1492 croak "putGlobalProblem: requires 1 argument" 1493 unless @_ == 2; 1494 croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1495 unless ref $GlobalProblem eq $self->{problem}->{record}; 1496 1497 checkKeyfields($GlobalProblem); 1498 1499 croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)" 1500 unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1501 croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1502 unless $self->{set}->exists($GlobalProblem->set_id); 1503 1504 return $self->{problem}->put($GlobalProblem); 1505 } 1506 1507 sub deleteGlobalProblem { 1508 my ($self, $setID, $problemID) = @_; 1509 1510 croak "deleteGlobalProblem: requires 2 arguments" 1511 unless @_ == 3; 1512 croak "deleteGlobalProblem: argument 1 must contain a set_id" 1513 unless defined $setID or caller eq __PACKAGE__; 1514 croak "deleteGlobalProblem: argument 2 must contain a problem_id" 1515 unless defined $problemID or caller eq __PACKAGE__; 1516 1517 $self->deleteUserProblem(undef, $setID, $problemID); 1518 return $self->{problem}->delete($setID, $problemID); 1519 } 1520 1521 =back 1522 1523 =cut 1524 1525 ################################################################################ 1526 # problem_user functions 1527 ################################################################################ 1528 1529 =head2 User-Specific Problem Methods 1530 1531 FIXME: write this 1532 1533 =over 1534 1535 =cut 1536 1537 sub newUserProblem { 1538 my ($self, @prototype) = @_; 1539 return $self->{problem_user}->{record}->new(@prototype); 1540 } 1541 1542 sub countProblemUsers { 1543 my ($self, $setID, $problemID) = @_; 1544 1545 croak "countProblemUsers: requires 2 arguments" 1546 unless @_ == 3; 1547 croak "countProblemUsers: argument 1 must contain a set_id" 1548 unless defined $setID; 1549 croak "countProblemUsers: argument 2 must contain a problem_id" 1550 unless defined $problemID; 1551 1552 # the slow way 1553 #return scalar $self->{problem_user}->list(undef, $setID, $problemID); 1554 1555 # the fast way 1556 return $self->{problem_user}->count(undef, $setID, $problemID); 1557 } 1558 1559 sub listProblemUsers { 1560 my ($self, $setID, $problemID) = @_; 1561 1562 carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n" 1563 unless wantarray; 1564 1565 croak "listProblemUsers: requires 2 arguments" 1566 unless @_ == 3; 1567 croak "listProblemUsers: argument 1 must contain a set_id" 1568 unless defined $setID; 1569 croak "listProblemUsers: argument 2 must contain a problem_id" 1570 unless defined $problemID; 1571 1572 return map { $_->[0] } # extract user_id 1573 $self->{problem_user}->list(undef, $setID, $problemID); 1574 } 1575 1576 sub listUserProblems { 1577 my ($self, $userID, $setID) = @_; 1578 1579 croak "listUserProblems: requires 2 arguments" 1580 unless @_ == 3; 1581 croak "listUserProblems: argument 1 must contain a user_id" 1582 unless defined $userID; 1583 croak "listUserProblems: argument 2 must contain a set_id" 1584 unless defined $setID; 1585 1586 return map { $_->[2] } # extract problem_id 1587 $self->{problem_user}->list($userID, $setID, undef); 1588 } 1589 1590 sub addUserProblem { 1591 my ($self, $UserProblem) = @_; 1592 1593 croak "addUserProblem: requires 1 argument" 1594 unless @_ == 2; 1595 croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1596 unless ref $UserProblem eq $self->{problem_user}->{record}; 1597 1598 checkKeyfields($UserProblem); 1599 1600 croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)" 1601 if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1602 croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1603 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1604 croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1605 unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id); 1606 1607 return $self->{problem_user}->add($UserProblem); 1608 } 1609 1610 sub getUserProblem { 1611 my ($self, $userID, $setID, $problemID) = @_; 1612 1613 croak "getUserProblem: requires 3 arguments" 1614 unless @_ == 4; 1615 croak "getUserProblem: argument 1 must contain a user_id" 1616 unless defined $userID; 1617 croak "getUserProblem: argument 2 must contain a set_id" 1618 unless defined $setID; 1619 croak "getUserProblem: argument 3 must contain a problem_id" 1620 unless defined $problemID; 1621 1622 return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0]; 1623 } 1624 1625 =item getUserProblems(@userProblemIDs) 1626 1627 Return a list of user set records associated with the user IDs given. If there 1628 is no record associated with a given user ID, that element of the list will be 1629 undefined. @userProblemIDs consists of references to arrays in which the first 1630 element is the user_id, the second element is the set_id, and the third element 1631 is the problem_id. 1632 1633 =cut 1634 1635 sub getUserProblems { 1636 my ($self, @userProblemIDs) = @_; 1637 1638 #croak "getUserProblems: requires 1 or more argument" 1639 # unless @_ >= 2; 1640 foreach my $i (0 .. $#userProblemIDs) { 1641 croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1642 unless defined $userProblemIDs[$i] 1643 and ref $userProblemIDs[$i] eq "ARRAY" 1644 and @{$userProblemIDs[$i]} == 3 1645 and defined $userProblemIDs[$i]->[0] 1646 and defined $userProblemIDs[$i]->[1] 1647 and defined $userProblemIDs[$i]->[2]; 1648 } 1649 1650 return $self->{problem_user}->gets(@userProblemIDs); 1651 } 1652 1653 =item getAllUserProblems($userID, $setID) 1654 1655 Returns a list of UserProblem objects representing all the problems in the 1656 given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far 1657 more efficient than using listUserProblems and getUserProblems. 1658 1659 =cut 1660 1661 sub getAllUserProblems { 1662 my ($self, $userID, $setID) = @_; 1663 1664 croak "getAllUserProblems: requires 2 arguments" 1665 unless @_ == 3; 1666 croak "getAllUserProblems: argument 1 must contain a user_id" 1667 unless defined $userID; 1668 croak "getAllUserProblems: argument 2 must contain a set_id" 1669 unless defined $setID; 1670 1671 if ($self->{problem_user}->can("getAll")) { 1672 return $self->{problem_user}->getAll($userID, $setID); 1673 } else { 1674 my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef); 1675 return $self->{problem_user}->gets(@problemIDTriples); 1676 } 1677 } 1678 1679 sub putUserProblem { 1680 my ($self, $UserProblem) = @_; 1681 1682 croak "putUserProblem: requires 1 argument" 1683 unless @_ == 2; 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); 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 croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1694 unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id); 1695 1696 return $self->{problem_user}->put($UserProblem); 1697 } 1698 1699 sub deleteUserProblem { 1700 my ($self, $userID, $setID, $problemID) = @_; 1701 1702 croak "getUserProblem: requires 3 arguments" 1703 unless @_ == 4; 1704 croak "getUserProblem: argument 1 must contain a user_id" 1705 unless defined $userID or caller eq __PACKAGE__; 1706 croak "getUserProblem: argument 2 must contain a set_id" 1707 unless defined $setID or caller eq __PACKAGE__; 1708 croak "getUserProblem: argument 3 must contain a problem_id" 1709 unless defined $problemID or caller eq __PACKAGE__; 1710 1711 return $self->{problem_user}->delete($userID, $setID, $problemID); 1712 } 1713 1714 =back 1715 1716 =cut 1717 1718 ################################################################################ 1719 # set+set_user functions 1720 ################################################################################ 1721 1722 =head2 Set Merging Methods 1723 1724 These functions combine a global set and a user set to create a merged set, 1725 which is returned. Any field that is not defined in the user set is taken from 1726 the global set. Merged sets have the same type as user sets. 1727 1728 =over 1729 1730 =cut 1731 1732 sub getGlobalUserSet { 1733 carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead"; 1734 return shift->getMergedSet(@_); 1735 } 1736 1737 =item getMergedSet($userID, $setID) 1738 1739 Returns a merged set record associated with the record IDs given. If there is no 1740 record associated with a given record ID, the undefined value is returned. 1741 1742 =cut 1743 1744 sub getMergedSet { 1745 my ($self, $userID, $setID) = @_; 1746 1747 croak "getMergedSet: requires 2 arguments" 1748 unless @_ == 3; 1749 croak "getMergedSet: argument 1 must contain a user_id" 1750 unless defined $userID; 1751 croak "getMergedSet: argument 2 must contain a set_id" 1752 unless defined $setID; 1753 1754 return ( $self->getMergedSets([$userID, $setID]) )[0]; 1755 } 1756 1757 =item getMegedSets(@userSetIDs) 1758 1759 Return a list of merged set records associated with the record IDs given. If 1760 there is no record associated with a given record ID, that element of the list 1761 will be undefined. @userSetIDs consists of references to arrays in which the 1762 first element is the user_id and the second element is the set_id. 1763 1764 =cut 1765 1766 sub getMergedSets { 1767 my ($self, @userSetIDs) = @_; 1768 1769 #croak "getMergedSets: requires 1 or more argument" 1770 # unless @_ >= 2; 1771 foreach my $i (0 .. $#userSetIDs) { 1772 croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair" 1773 unless defined $userSetIDs[$i] 1774 and ref $userSetIDs[$i] eq "ARRAY" 1775 and @{$userSetIDs[$i]} == 2 1776 and defined $userSetIDs[$i]->[0] 1777 and defined $userSetIDs[$i]->[1]; 1778 } 1779 1780 # a horrible, terrible hack ;) 1781 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash" 1782 and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") { 1783 #warn __PACKAGE__.": using a terrible hack.\n"; 1784 $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer); 1785 my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs); 1786 $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer); 1787 return @MergedSets; 1788 } 1789 1790 $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer); 1791 my @UserSets = $self->getUserSets(@userSetIDs); # checked 1792 1793 $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer); 1794 my @globalSetIDs = map { $_->[1] } @userSetIDs; 1795 $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer); 1796 my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked 1797 1798 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 1799 my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS; 1800 my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS; 1801 1802 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 1803 for (my $i = 0; $i < @UserSets; $i++) { 1804 my $UserSet = $UserSets[$i]; 1805 my $GlobalSet = $GlobalSets[$i]; 1806 next unless defined $UserSet and defined $GlobalSet; 1807 foreach my $field (@commonFields) { 1808 #next if defined $UserSet->$field; 1809 # ok, now we're testing for emptiness as well as definedness. 1810 next if defined $UserSet->$field and $UserSet->$field ne ""; 1811 $UserSet->$field($GlobalSet->$field); 1812 } 1813 } 1814 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 1815 1816 return @UserSets; 1817 } 1818 1819 =back 1820 1821 =cut 1822 1823 ################################################################################ 1824 # problem+problem_user functions 1825 ################################################################################ 1826 1827 =head2 Problem Merging Methods 1828 1829 These functions combine a global problem and a user problem to create a merged 1830 problem, which is returned. Any field that is not defined in the user problem is 1831 taken from the global problem. Merged problems have the same type as user 1832 problems. 1833 1834 =over 1835 1836 =cut 1837 1838 sub getGlobalUserProblem { 1839 carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead"; 1840 return shift->getMergedProblem(@_); 1841 } 1842 1843 =item getMergedProblem($userID, $setID, $problemID) 1844 1845 Returns a merged problem record associated with the record IDs given. If there 1846 is no record associated with a given record ID, the undefined value is returned. 1847 1848 =cut 1849 1850 sub getMergedProblem { 1851 my ($self, $userID, $setID, $problemID) = @_; 1852 1853 croak "getGlobalUserSet: requires 3 arguments" 1854 unless @_ == 4; 1855 croak "getGlobalUserSet: argument 1 must contain a user_id" 1856 unless defined $userID; 1857 croak "getGlobalUserSet: argument 2 must contain a set_id" 1858 unless defined $setID; 1859 croak "getGlobalUserSet: argument 3 must contain a problem_id" 1860 unless defined $problemID; 1861 1862 return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0]; 1863 } 1864 1865 =item getMergedProblems(@userProblemIDs) 1866 1867 Return a list of merged problem records associated with the record IDs given. If 1868 there is no record associated with a given record ID, that element of the list 1869 will be undefined. @userProblemIDs consists of references to arrays in which the 1870 first element is the user_id, the second element is the set_id, and the third 1871 element is the problem_id. 1872 1873 =cut 1874 1875 sub getMergedProblems { 1876 my ($self, @userProblemIDs) = @_; 1877 1878 #croak "getMergedProblems: requires 1 or more argument" 1879 # unless @_ >= 2; 1880 foreach my $i (0 .. $#userProblemIDs) { 1881 croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1882 unless defined $userProblemIDs[$i] 1883 and ref $userProblemIDs[$i] eq "ARRAY" 1884 and @{$userProblemIDs[$i]} == 3 1885 and defined $userProblemIDs[$i]->[0] 1886 and defined $userProblemIDs[$i]->[1] 1887 and defined $userProblemIDs[$i]->[2]; 1888 } 1889 1890 $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer); 1891 my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked 1892 1893 $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer); 1894 my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs; 1895 $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer); 1896 my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked 1897 1898 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 1899 my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS; 1900 my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS; 1901 1902 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 1903 for (my $i = 0; $i < @UserProblems; $i++) { 1904 my $UserProblem = $UserProblems[$i]; 1905 my $GlobalProblem = $GlobalProblems[$i]; 1906 next unless defined $UserProblem and defined $GlobalProblem; 1907 foreach my $field (@commonFields) { 1908 # FIXME: WW1Hash upgrades undefined fileds to "" when creating record objects 1909 # Shouldn't we be testing for emptiness rather than definedness? 1910 # I think the spec says that if a field is EMPTY the global value is used. 1911 #next if defined $UserProblem->$field; 1912 # ok, now we're testing for emptiness as well as definedness. 1913 next if defined $UserProblem->$field and $UserProblem->$field ne ""; 1914 $UserProblem->$field($GlobalProblem->$field); 1915 } 1916 } 1917 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 1918 1919 return @UserProblems; 1920 } 1921 1922 =back 1923 1924 =cut 1925 1926 ################################################################################ 1927 # debugging 1928 ################################################################################ 1929 1930 #sub dumpDB($$) { 1931 # my ($self, $table) = @_; 1932 # return $self->{$table}->dumpDB(); 1933 #} 1934 1935 ################################################################################ 1936 # utilities 1937 ################################################################################ 1938 1939 sub checkKeyfields($) { 1940 my ($Record) = @_; 1941 foreach my $keyfield ($Record->KEYFIELDS) { 1942 my $value = $Record->$keyfield; 1943 croak "checkKeyfields: $keyfield is empty" 1944 unless defined $value and $value ne ""; 1945 1946 if ($keyfield eq "problem_id") { 1947 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])" 1948 unless $value =~ m/^\d*$/; 1949 } else { 1950 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])" 1951 unless $value =~ m/^[\w-]*$/; 1952 } 1953 } 1954 } 1955 1956 =head1 AUTHOR 1957 1958 Written by Sam Hathaway, sh002i (at) math.rochester.edu. 1959 1960 =cut 1961 1962 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |