Parent Directory
| 
Revision Log
eliminate false positives in hashDatabaseOK()
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.55 2004/09/23 18:45:48 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($dbLayout) 155 156 The C<new> method creates a DB object and brings up the underlying schema/driver 157 structure according to the hash referenced by C<$dbLayout>. 158 159 =back 160 161 =head2 C<$dbLayout> Format 162 163 C<$dbLayout> is a hash reference consisting of items keyed by table names. The 164 value of each item is a reference to a hash containing the following items: 165 166 =over 167 168 =item record 169 170 The name of a perl module to use for representing the data in a record. 171 172 =item schema 173 174 The name of a perl module to use for access to the table. 175 176 =item driver 177 178 The name of a perl module to use for access to the data source. 179 180 =item source 181 182 The location of the data source that should be used by the driver module. 183 Depending on the driver, this may be a path, a url, or a DBI spec. 184 185 =item params 186 187 A reference to a hash containing extra information needed by the schema. Some 188 schemas require parameters, some do not. Consult the documentation for the 189 schema in question. 190 191 =back 192 193 For each table defined in C<$dbLayout>, C<new> loads the record, schema, and 194 driver modules. It the schema module's C<tables> method lists the current table 195 (or contains the string "*") and the output of the schema and driver modules' 196 C<style> methods match, the table is installed. Otherwise, an exception is 197 thrown. 198 199 =cut 200 201 sub new($$) { 202 my ($invocant, $dbLayout) = @_; 203 my $class = ref($invocant) || $invocant; 204 my $self = {}; 205 bless $self, $class; # bless this here so we can pass it to the schema 206 207 # load the modules required to handle each table, and create driver 208 my %dbLayout = %$dbLayout; 209 foreach my $table (keys %dbLayout) { 210 my $layout = $dbLayout{$table}; 211 my $record = $layout->{record}; 212 my $schema = $layout->{schema}; 213 my $driver = $layout->{driver}; 214 my $source = $layout->{source}; 215 my $params = $layout->{params}; 216 217 runtime_use($record); 218 219 runtime_use($driver); 220 my $driverObject = eval { $driver->new($source, $params) }; 221 croak "error instantiating DB driver $driver for table $table: $@" 222 if $@; 223 224 runtime_use($schema); 225 my $schemaObject = eval { $schema->new( 226 $self, $driverObject, $table, $record, $params) }; 227 croak "error instantiating DB schema $schema for table $table: $@" 228 if $@; 229 230 $self->{$table} = $schemaObject; 231 } 232 233 return $self; 234 } 235 236 =head1 METHODS 237 238 =cut 239 240 ################################################################################ 241 # general functions 242 ################################################################################ 243 244 =head2 General Methods 245 246 =over 247 248 =cut 249 250 =item hashDatabaseOK($fix) 251 252 If the schema module in use for the C<set> and C<problem> tables is 253 WeBWorK::DB::Schema::GlobalTableEmulator, the database is checked to make sure 254 that the "global user" exists and all sets and problems are assigned to it. If 255 $fix is true, problems found will be fixed: A global user will be created and 256 all sets/problems assigned to it. 257 258 A list of values is returned. The first value is a boolean value indicating 259 whether problems remain in the database after hashDatabaseOK() is called. The 260 remaining values are a list of strings indicating the particular ways in which 261 the database is (or was) broken. 262 263 =cut 264 265 sub hashDatabaseOK { 266 my ($self, $fix) = @_; 267 268 my $errorsExist; 269 my @results; 270 271 ##### do we need to run? ##### 272 273 unless (ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") { 274 #warn "hashDatabaseOK($fix): no checks necessary, set table does not use GlobalTableEmulator.\n"; 275 return 1; 276 } 277 278 ##### is globalUserID defined? ##### 279 280 my $globalUserID = $self->{set}->{params}->{globalUserID}; 281 if ($globalUserID eq "") { 282 return 0, "globalUserID not specified (fix this in %dbLayout.)"; 283 } else { 284 #warn "hashDatabaseOK($fix): globalUserID not empty ($globalUserID) -- good.\n"; 285 } 286 287 ##### does a user with ID globalUserID exist? ##### 288 289 my $GlobalUser = $self->getUser($globalUserID); 290 if (defined $GlobalUser) { 291 #warn "hashDatabaseOK($fix): user with ID '$globalUserID' exists -- good.\n"; 292 } else { 293 #warn "hashDatabaseOK($fix): user with ID '$globalUserID' not found -- bad!\n"; 294 if ($fix) { 295 $self->addUser($self->newUser( 296 user_id => $globalUserID, 297 first_name => "Global", 298 last_name => "User", 299 email_address => "", 300 student_id => $globalUserID, 301 status => "D", 302 section => "", 303 recitation => "", 304 comment => "This user is used to store data about global set and problem records when using a hash-style database.", 305 )); 306 push @results, "User $globalUserID does not exist -- FIXED."; 307 #warn "hashDatabaseOK($fix): created user with ID '$globalUserID' -- good.\n"; 308 } else { 309 # at this point, we don't go on. no global user means everything below is going to fail. 310 return 0, "User $globalUserID does not exist."; 311 } 312 } 313 314 ##### are all sets assigned to the user with ID globalUserID? ##### 315 316 # FIXME: this is way too slow! 317 #my @userSetIDs = $self->{set_user}->list(undef, undef); 318 319 # Timing Data 320 # 321 # old method: 322 # TIMING 36119 1 1087502726.923311 (0.139117) mth143: WeBWorK::DB::hashDatabaseOK: about to get orphaned UserSets 323 # TIMING 36119 1 1087502768.074221 (41.290027) mth143: WeBWorK::DB::hashDatabaseOK: done getting orphaned UserSets 324 # 325 # new method: 326 # TIMING 36134 0 1087502854.579133 (0.141437) mth143: WeBWorK::DB::hashDatabaseOK: about to get orphaned UserSets 327 # TIMING 36134 0 1087502856.852504 (2.414808) mth143: WeBWorK::DB::hashDatabaseOK: done getting orphaned UserSets 328 # 329 # yay! 330 331 $WeBWorK::timer->continue(__PACKAGE__ . "::hashDatabaseOK: about to get orphaned UserSets") if defined $WeBWorK::timer; 332 333 # ... so instead, we're going to do things manually 334 335 # key: setID, value: hash of userIDs of users to whom this set is assigned 336 my %orphanUserSets; 337 338 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash") { 339 # we can only do this with WW1Hash 340 #warn "the fast way!\n"; 341 342 # connect 343 $self->{set_user}->{driver}->connect("ro") 344 or return 0, @results, "Failed to connect to set_user database."; 345 346 # get PSVNs for global user ( N) 347 # this reads from "login<>global_user" 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 # this reads from "set<>$_" 363 my @okPSVNs = map { $self->{set_user}->getPSVNsForSet($_) } @globalUserSetIDs; 364 #warn "found ", scalar @okPSVNs, " PSVNs for sets assigned to the global user.\n"; 365 366 # get all PSVNs (N*M) 367 # uses: grep { m/^\d+$/ } keys %{ $self->{driver}->hash() } 368 my @allPSVNs = $self->{set_user}->getAllPSVNs; 369 #warn "found ", scalar @allPSVNs, " PSVNs total.\n"; 370 371 # eliminate PSVNs of sets that are assigned to the global user 372 my %allPSVNs; 373 @allPSVNs{@allPSVNs} = (); 374 375 foreach my $PSVN (@okPSVNs) { 376 delete $allPSVNs{$PSVN}; 377 } 378 379 #warn "the orphan PSVNs are: ", join(", ", keys %allPSVNs), "\n"; 380 381 # get setIDs for orphan PSVNs 382 foreach my $PSVN (keys %allPSVNs) { 383 #warn "getting userID and setID for PSVN '$PSVN'...\n"; 384 my $string = $self->{set_user}->fetchString($PSVN); 385 my ($userID, $setID) = $self->{set_user}->string2IDs($string); 386 $orphanUserSets{$setID}->{$userID} = 1; 387 #warn "got setID '$setID' for userID '$userID'\n"; 388 } 389 390 # disconnect 391 $self->{set_user}->{driver}->disconnect; 392 } else { 393 # otherwise, do it the slow way (maybe it's not slow with some other schema?) 394 #warn "oddly enough, set_user isn't using WW1Hash, so we have to use the slow list() method"; 395 my @userSetIDs = $self->{set_user}->list(undef, undef); 396 397 foreach my $userSetID (@userSetIDs) { 398 my ($userID, $setID) = @$userSetID; 399 $orphanUserSets{$setID}->{$userID} = 1; 400 } 401 402 foreach my $setID (keys %orphanUserSets) { 403 delete $orphanUserSets{$setID} 404 if exists $orphanUserSets{$setID}->{$globalUserID}; 405 } 406 } 407 408 $WeBWorK::timer->continue(__PACKAGE__ . "::hashDatabaseOK: done getting orphaned UserSets") if defined $WeBWorK::timer; 409 410 if (keys %orphanUserSets) { 411 foreach my $setID (keys %orphanUserSets) { 412 # detect "false positives" -- sets that are assigned to the global user 413 # but for some reason don't appear in any set index. 414 if ($self->{set_user}->exists($globalUserID, $setID)) { 415 my @userIDs = keys %{$orphanUserSets{$setID}}; 416 warn "Set ID '$setID' for users '@userIDs' do not appear in any set index. Index re-build recommended.\n"; 417 push @results, "Set ID '$setID' for users '@userIDs' do not appear in any set index. Index re-build recommended.\n"; 418 } else { 419 if ($fix) { 420 my ($userID) = keys %{$orphanUserSets{$setID}}; 421 422 # grab the first UserSet of this set (connect and disconnect required for get1*) 423 $self->{set_user}->{driver}->connect("ro") 424 or return 0, @results, "Failed to connect to set_user database."; 425 my $RawUserSet = $self->{set_user}->get1NoFilter($userID, $setID); 426 my @RawUserProblems = $self->{problem_user}->getAllNoFilter($userID, $setID); 427 $self->{set_user}->{driver}->disconnect(); 428 unless ($RawUserSet) { 429 warn "failed to fetch UserSet '$setID' for user '$userID'!\n"; 430 next; 431 } 432 433 # change user ID to globalUserID and add to database 434 $RawUserSet->user_id($globalUserID); 435 $self->{set_user}->add($RawUserSet); 436 foreach my $RawUserProblem (@RawUserProblems) { 437 $RawUserProblem->user_id($globalUserID); 438 $self->{problem_user}->add($RawUserProblem); 439 #warn "hashDatabaseOK($fix): assigned problem '", $RawUserProblem->problem_id, "' from set '$setID' to global user '$globalUserID' -- good.\n"; 440 } 441 442 #warn "hashDatabaseOK($fix): assigned set '$setID' to global user '$globalUserID' -- good.\n"; 443 push @results, "Set '$setID' not assigned to global user '$globalUserID' -- FIXED."; 444 } else { 445 #warn "hashDatabaseOK($fix): set '$setID' not assigned to global user '$globalUserID' -- bad!\n"; 446 push @results, "Set '$setID' not assigned to global user '$globalUserID'."; 447 } 448 } 449 } 450 } else { 451 #warn "hashDatabaseOK($fix): all sets assigned to global user '$globalUserID' -- good.\n"; 452 } 453 454 ##### done! ##### 455 456 my $status = not $errorsExist; 457 return $status, @results; 458 } 459 460 =back 461 462 =cut 463 464 ################################################################################ 465 # password functions 466 ################################################################################ 467 468 =head2 Password Methods 469 470 =over 471 472 =item newPassword() 473 474 Returns a new, empty password object. 475 476 =cut 477 478 sub newPassword { 479 my ($self, @prototype) = @_; 480 return $self->{password}->{record}->new(@prototype); 481 } 482 483 =item listPasswords() 484 485 Returns a list of user IDs representing the records in the password table. 486 487 =cut 488 489 sub listPasswords { 490 my ($self) = @_; 491 492 croak "listPasswords: requires 0 arguments" 493 unless @_ == 1; 494 495 return map { $_->[0] } 496 $self->{password}->list(undef); 497 } 498 499 =item addPassword($Password) 500 501 $Password is a record object. The password will be added to the password table 502 if a password with the same user ID does not already exist. If one does exist, 503 an exception is thrown. To add a password, a user with a matching user ID must 504 exist in the user table. 505 506 =cut 507 508 sub addPassword { 509 my ($self, $Password) = @_; 510 511 croak "addPassword: requires 1 argument" 512 unless @_ == 2; 513 croak "addPassword: argument 1 must be of type ", $self->{password}->{record} 514 unless ref $Password eq $self->{password}->{record}; 515 516 checkKeyfields($Password); 517 518 croak "addPassword: password exists (perhaps you meant to use putPassword?)" 519 if $self->{password}->exists($Password->user_id); 520 croak "addPassword: user ", $Password->user_id, " not found" 521 unless $self->{user}->exists($Password->user_id); 522 523 return $self->{password}->add($Password); 524 } 525 526 =item getPassword($userID) 527 528 If a record with a matching user ID exists, a record object containting that 529 record's data will be returned. If no such record exists, one will be created. 530 531 =cut 532 533 sub getPassword { 534 my ($self, $userID) = @_; 535 536 croak "getPassword: requires 1 argument" 537 unless @_ == 2; 538 croak "getPassword: argument 1 must contain a user_id" 539 unless defined $userID; 540 541 #return $self->{password}->get($userID); 542 return ( $self->getPasswords($userID) )[0]; 543 } 544 545 =item getPasswords(@uesrIDs) 546 547 Return a list of password records associated with the user IDs given. If there 548 is no record associated with a given user ID, one will be created. 549 550 =cut 551 552 sub getPasswords { 553 my ($self, @userIDs) = @_; 554 555 #croak "getPasswords: requires 1 or more argument" 556 # unless @_ >= 2; 557 foreach my $i (0 .. $#userIDs) { 558 croak "getPasswords: element $i of argument list must contain a user_id" 559 unless defined $userIDs[$i]; 560 } 561 562 my @Passwords = $self->{password}->gets(map { [$_] } @userIDs); 563 564 for (my $i = 0; $i < @Passwords; $i++) { 565 my $Password = $Passwords[$i]; 566 my $userID = $userIDs[$i]; 567 if (not defined $Password) { 568 if ($self->{user}->exists($userID)) { 569 $Password = $self->newPassword(user_id => $userID); 570 eval { $self->addPassword($Password) }; 571 if ($@ and $@ !~ m/password exists/) { 572 die "error while auto-creating password record for user $userID: \"$@\""; 573 } 574 } 575 } 576 } 577 578 return @Passwords; 579 } 580 581 =item putPassword($Password) 582 583 $Password is a record object. If a password record with the same user ID exists 584 in the password table, the data in the record is replaced with the data in 585 $Password. If a matching password record does not exist, one will be created. 586 (This is different from most other "put" methods.) 587 588 =cut 589 590 sub putPassword($$) { 591 my ($self, $Password) = @_; 592 593 croak "putPassword: requires 1 argument" 594 unless @_ == 2; 595 croak "putPassword: argument 1 must be of type ", $self->{password}->{record} 596 unless ref $Password eq $self->{password}->{record}; 597 598 checkKeyfields($Password); 599 600 # For Passwords and PermissionLevels, auto-create a record when it doesn't 601 # already exist. This should be safe. 602 if ($self->{password}->exists($Password->user_id)) { 603 return $self->{password}->put($Password); 604 } else { 605 return $self->addPassword($Password); 606 } 607 } 608 609 =item deletePassword($userID) 610 611 If a password record with a user ID matching $userID exists in the password 612 table, it is removed and the method returns a true value. If one does exist, 613 a false value is returned. 614 615 =cut 616 617 sub deletePassword($$) { 618 my ($self, $userID) = @_; 619 620 croak "putPassword: requires 1 argument" 621 unless @_ == 2; 622 croak "deletePassword: argument 1 must contain a user_id" 623 unless defined $userID; 624 625 return $self->{password}->delete($userID); 626 } 627 628 =back 629 630 =cut 631 632 ################################################################################ 633 # permission functions 634 ################################################################################ 635 636 =head2 Permission Level Methods 637 638 =over 639 640 =item newPermissionLevel() 641 642 Returns a new, empty permission level object. 643 644 =cut 645 646 sub newPermissionLevel { 647 my ($self, @prototype) = @_; 648 return $self->{permission}->{record}->new(@prototype); 649 } 650 651 =item listPermissionLevels() 652 653 Returns a list of user IDs representing the records in the permission table. 654 655 =cut 656 657 sub listPermissionLevels($) { 658 my ($self) = @_; 659 660 croak "listPermissionLevels: requires 0 arguments" 661 unless @_ == 1; 662 663 return map { $_->[0] } 664 $self->{permission}->list(undef); 665 } 666 667 =item addPermissionLevel($PermissionLevel) 668 669 $PermissionLevel is a record object. The permission level will be added to the 670 permission table if a permission level with the same user ID does not already 671 exist. If one does exist, an exception is thrown. To add a permission level, a 672 user with a matching user ID must exist in the user table. 673 674 =cut 675 676 sub addPermissionLevel($$) { 677 my ($self, $PermissionLevel) = @_; 678 679 croak "addPermissionLevel: requires 1 argument" 680 unless @_ == 2; 681 croak "addPermissionLevel: argument 1 must be of type ", $self->{permission}->{record} 682 unless ref $PermissionLevel eq $self->{permission}->{record}; 683 684 checkKeyfields($PermissionLevel); 685 686 croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)" 687 if $self->{permission}->exists($PermissionLevel->user_id); 688 croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found" 689 unless $self->{user}->exists($PermissionLevel->user_id); 690 691 return $self->{permission}->add($PermissionLevel); 692 } 693 694 =item getPermissionLevel($userID) 695 696 If a record with a matching user ID exists, a record object containting that 697 record's data will be returned. If no such record exists, one will be created. 698 699 =cut 700 701 sub getPermissionLevel($$) { 702 my ($self, $userID) = @_; 703 704 croak "getPermissionLevel: requires 1 argument" 705 unless @_ == 2; 706 croak "getPermissionLevel: argument 1 must contain a user_id" 707 unless defined $userID; 708 709 #return $self->{permission}->get($userID); 710 return ( $self->getPermissionLevels($userID) )[0]; 711 } 712 713 =item getPermissionLevels(@uesrIDs) 714 715 Return a list of permission level records associated with the user IDs given. If 716 there is no record associated with a given user ID, one will be created. 717 718 =cut 719 720 sub getPermissionLevels { 721 my ($self, @userIDs) = @_; 722 723 #croak "getPermissionLevels: requires 1 or more argument" 724 # unless @_ >= 2; 725 foreach my $i (0 .. $#userIDs) { 726 croak "getPermissionLevels: element $i of argument list must contain a user_id" 727 unless defined $userIDs[$i]; 728 } 729 730 my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs); 731 732 for (my $i = 0; $i < @PermissionLevels; $i++) { 733 my $PermissionLevel = $PermissionLevels[$i]; 734 my $userID = $userIDs[$i]; 735 if (not defined $PermissionLevel) { 736 if ($self->{user}->exists($userID)) { 737 $PermissionLevel = $self->newPermissionLevel(user_id => $userID); 738 eval { $self->addPermissionLevel($PermissionLevel) }; 739 if ($@ and $@ !~ m/permission level exists/) { 740 die "error while auto-creating permission level record for user $userID: \"$@\""; 741 } 742 $PermissionLevels[$i] = $PermissionLevel; 743 } 744 } 745 } 746 747 return @PermissionLevels; 748 } 749 750 =item putPermissionLevel($PermissionLevel) 751 752 $PermissionLevel is a record object. If a permission level record with the same 753 user ID exists in the permission table, the data in the record is replaced with 754 the data in $PermissionLevel. If a matching permission level record does not 755 exist, one will be created. (This is different from most other "put" methods.) 756 757 =cut 758 759 sub putPermissionLevel($$) { 760 my ($self, $PermissionLevel) = @_; 761 762 croak "putPermissionLevel: requires 1 argument" 763 unless @_ == 2; 764 croak "putPermissionLevel: argument 1 must be of type ", $self->{permission}->{record} 765 unless ref $PermissionLevel eq $self->{permission}->{record}; 766 767 checkKeyfields($PermissionLevel); 768 769 # For Passwords and PermissionLevels, auto-create a record when it doesn't 770 # already exist. This should be safe. 771 if ($self->{permission}->exists($PermissionLevel->user_id)) { 772 return $self->{permission}->put($PermissionLevel); 773 } else { 774 return $self->{permission}->add($PermissionLevel); 775 } 776 } 777 778 =item deletePermissionLevel($userID) 779 780 If a permission level record with a user ID matching $userID exists in the 781 permission table, it is removed and the method returns a true value. If one 782 does exist, a false value is returned. 783 784 =cut 785 786 sub deletePermissionLevel($$) { 787 my ($self, $userID) = @_; 788 789 croak "deletePermissionLevel: requires 1 argument" 790 unless @_ == 2; 791 croak "deletePermissionLevel: argument 1 must contain a user_id" 792 unless defined $userID; 793 794 return $self->{permission}->delete($userID); 795 } 796 797 ################################################################################ 798 # key functions 799 ################################################################################ 800 801 =head2 Key Methods 802 803 =over 804 805 =item newKey() 806 807 Returns a new, empty key object. 808 809 =cut 810 811 sub newKey { 812 my ($self, @prototype) = @_; 813 return $self->{key}->{record}->new(@prototype); 814 } 815 816 =item listKeys() 817 818 Returns a list of user IDs representing the records in the key table. 819 820 =cut 821 822 sub listKeys($) { 823 my ($self) = @_; 824 825 croak "listKeys: requires 0 arguments" 826 unless @_ == 1; 827 828 return map { $_->[0] } 829 $self->{key}->list(undef); 830 } 831 832 =item addKey($Key) 833 834 $Key is a record object. The key will be added to the key table if a key with 835 the same user ID does not already exist. If one does exist, an exception is 836 thrown. To add a key, a user with a matching user ID must exist in the user 837 table. 838 839 =cut 840 841 sub addKey($$) { 842 my ($self, $Key) = @_; 843 844 croak "addKey: requires 1 argument" 845 unless @_ == 2; 846 croak "addKey: argument 1 must be of type ", $self->{key}->{record} 847 unless ref $Key eq $self->{key}->{record}; 848 849 checkKeyfields($Key); 850 851 croak "addKey: key exists (perhaps you meant to use putKey?)" 852 if $self->{key}->exists($Key->user_id); 853 croak "addKey: user ", $Key->user_id, " not found" 854 unless $self->{user}->exists($Key->user_id); 855 856 return $self->{key}->add($Key); 857 } 858 859 =item getKey($userID) 860 861 If a record with a matching user ID exists, a record object containting that 862 record's data will be returned. If no such record exists, an undefined value 863 will be returned. 864 865 =cut 866 867 sub getKey($$) { 868 my ($self, $userID) = @_; 869 870 croak "getKey: requires 1 argument" 871 unless @_ == 2; 872 croak "getKey: argument 1 must contain a user_id" 873 unless defined $userID; 874 875 return $self->{key}->get($userID); 876 } 877 878 =item getKeys(@uesrIDs) 879 880 Return a list of key records associated with the user IDs given. If there is no 881 record associated with a given user ID, that element of the list will be 882 undefined. 883 884 =cut 885 886 sub getKeys { 887 my ($self, @userIDs) = @_; 888 889 #croak "getKeys: requires 1 or more argument" 890 # unless @_ >= 2; 891 foreach my $i (0 .. $#userIDs) { 892 croak "getKeys: element $i of argument list must contain a user_id" 893 unless defined $userIDs[$i]; 894 } 895 896 return $self->{key}->gets(map { [$_] } @userIDs); 897 } 898 899 =item putKey($Key) 900 901 $Key is a record object. If a key record with the same user ID exists in the 902 key table, the data in the record is replaced with the data in $Key. If a 903 matching key record does not exist, an exception is thrown. 904 905 =cut 906 907 sub putKey($$) { 908 my ($self, $Key) = @_; 909 910 croak "putKey: requires 1 argument" 911 unless @_ == 2; 912 croak "putKey: argument 1 must be of type ", $self->{key}->{record} 913 unless ref $Key eq $self->{key}->{record}; 914 915 checkKeyfields($Key); 916 917 croak "putKey: key not found (perhaps you meant to use addKey?)" 918 unless $self->{key}->exists($Key->user_id); 919 920 return $self->{key}->put($Key); 921 } 922 923 =item deleteKey($userID) 924 925 If a key record with a user ID matching $userID exists in the key table, it is 926 removed and the method returns a true value. If one does exist, a false value 927 is returned. 928 929 =cut 930 931 sub deleteKey($$) { 932 my ($self, $userID) = @_; 933 934 croak "deleteKey: requires 1 argument" 935 unless @_ == 2; 936 croak "deleteKey: argument 1 must contain a user_id" 937 unless defined $userID; 938 939 return $self->{key}->delete($userID); 940 } 941 942 ################################################################################ 943 # user functions 944 ################################################################################ 945 946 =head2 User Methods 947 948 =over 949 950 =item newUser() 951 952 Returns a new, empty user object. 953 954 =cut 955 956 sub newUser { 957 my ($self, @prototype) = @_; 958 return $self->{user}->{record}->new(@prototype); 959 } 960 961 =item listUsers() 962 963 Returns a list of user IDs representing the records in the user table. 964 965 =cut 966 967 sub listUsers { 968 my ($self) = @_; 969 970 croak "listUsers: requires 0 arguments" 971 unless @_ == 1; 972 973 return map { $_->[0] } 974 $self->{user}->list(undef); 975 } 976 977 =item addUser($User) 978 979 $User is a record object. The user will be added to the user table if a user 980 with the same user ID does not already exist. If one does exist, an exception 981 is thrown. 982 983 =cut 984 985 sub addUser { 986 my ($self, $User) = @_; 987 988 croak "addUser: requires 1 argument" 989 unless @_ == 2; 990 croak "addUser: argument 1 must be of type ", $self->{user}->{record} 991 unless ref $User eq $self->{user}->{record}; 992 993 checkKeyfields($User); 994 995 croak "addUser: user exists (perhaps you meant to use putUser?)" 996 if $self->{user}->exists($User->user_id); 997 998 return $self->{user}->add($User); 999 } 1000 1001 =item getUser($userID) 1002 1003 If a record with a matching user ID exists, a record object containting that 1004 record's data will be returned. If no such record exists, an undefined value 1005 will be returned. 1006 1007 =cut 1008 1009 sub getUser { 1010 my ($self, $userID) = @_; 1011 1012 croak "getUser: requires 1 argument" 1013 unless @_ == 2; 1014 croak "getUser: argument 1 must contain a user_id" 1015 unless defined $userID; 1016 1017 return $self->{user}->get($userID); 1018 } 1019 1020 =item getUsers(@uesrIDs) 1021 1022 Return a list of user records associated with the user IDs given. If there is no 1023 record associated with a given user ID, that element of the list will be 1024 undefined. 1025 1026 =cut 1027 1028 sub getUsers { 1029 my ($self, @userIDs) = @_; 1030 1031 #croak "getUsers: requires 1 or more argument" 1032 # unless @_ >= 2; 1033 foreach my $i (0 .. $#userIDs) { 1034 croak "getUsers: element $i of argument list must contain a user_id" 1035 unless defined $userIDs[$i]; 1036 } 1037 1038 return $self->{user}->gets(map { [$_] } @userIDs); 1039 } 1040 1041 =item putUser($User) 1042 1043 $User is a record object. If a user record with the same user ID exists in the 1044 user table, the data in the record is replaced with the data in $User. If a 1045 matching user record does not exist, an exception is thrown. 1046 1047 =cut 1048 1049 sub putUser { 1050 my ($self, $User) = @_; 1051 1052 croak "putUser: requires 1 argument" 1053 unless @_ == 2; 1054 croak "putUser: argument 1 must be of type ", $self->{user}->{record} 1055 unless ref $User eq $self->{user}->{record}; 1056 1057 checkKeyfields($User); 1058 1059 croak "putUser: user not found (perhaps you meant to use addUser?)" 1060 unless $self->{user}->exists($User->user_id); 1061 1062 return $self->{user}->put($User); 1063 } 1064 1065 =item deleteUser($userID) 1066 1067 If a user record with a user ID matching $userID exists in the user table, it 1068 is removed and the method returns a true value. If one does exist, a false 1069 value is returned. When a user record is deleted, all records associated with 1070 that user are also deleted. This includes the password, permission, and key 1071 records, and all user set records for that user. 1072 1073 =cut 1074 1075 sub deleteUser { 1076 my ($self, $userID) = @_; 1077 1078 croak "deleteUser: requires 1 argument" 1079 unless @_ == 2; 1080 croak "deleteUser: argument 1 must contain a user_id" 1081 unless defined $userID; 1082 1083 $self->deleteUserSet($userID, undef); 1084 $self->deletePassword($userID); 1085 $self->deletePermissionLevel($userID); 1086 $self->deleteKey($userID); 1087 return $self->{user}->delete($userID); 1088 } 1089 1090 =back 1091 1092 =cut 1093 1094 ################################################################################ 1095 # set functions 1096 ################################################################################ 1097 1098 =head2 Global Set Methods 1099 1100 FIXME: write this 1101 1102 =over 1103 1104 =cut 1105 1106 =item newGlobalSet() 1107 1108 =cut 1109 1110 sub newGlobalSet { 1111 my ($self, @prototype) = @_; 1112 return $self->{set}->{record}->new(@prototype); 1113 } 1114 1115 =item listGlobalSets() 1116 1117 =cut 1118 1119 sub listGlobalSets { 1120 my ($self) = @_; 1121 1122 croak "listGlobalSets: requires 0 arguments" 1123 unless @_ == 1; 1124 1125 return map { $_->[0] } 1126 $self->{set}->list(undef); 1127 } 1128 1129 =item addGlobalSet($GlobalSet) 1130 1131 =cut 1132 1133 sub addGlobalSet { 1134 my ($self, $GlobalSet) = @_; 1135 1136 croak "addGlobalSet: requires 1 argument" 1137 unless @_ == 2; 1138 croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record} 1139 unless ref $GlobalSet eq $self->{set}->{record}; 1140 1141 checkKeyfields($GlobalSet); 1142 1143 croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)" 1144 if $self->{set}->exists($GlobalSet->set_id); 1145 1146 return $self->{set}->add($GlobalSet); 1147 } 1148 1149 =item addGlobalSet($setID) 1150 1151 =cut 1152 1153 sub getGlobalSet { 1154 my ($self, $setID) = @_; 1155 1156 croak "getGlobalSet: requires 1 argument" 1157 unless @_ == 2; 1158 croak "getGlobalSet: argument 1 must contain a set_id" 1159 unless defined $setID; 1160 1161 return $self->{set}->get($setID); 1162 } 1163 1164 =item getGlobalSets(@setIDs) 1165 1166 Return a list of global set records associated with the record IDs given. If 1167 there is no record associated with a given record ID, that element of the list 1168 will be undefined. 1169 1170 =cut 1171 1172 sub getGlobalSets { 1173 my ($self, @setIDs) = @_; 1174 1175 #croak "getGlobalSets: requires 1 or more argument" 1176 # unless @_ >= 2; 1177 foreach my $i (0 .. $#setIDs) { 1178 croak "getGlobalSets: element $i of argument list must contain a set_id" 1179 unless defined $setIDs[$i]; 1180 } 1181 1182 return $self->{set}->gets(map { [$_] } @setIDs); 1183 } 1184 1185 =item addGlobalSet($GlobalSet) 1186 1187 =cut 1188 1189 sub putGlobalSet { 1190 my ($self, $GlobalSet) = @_; 1191 1192 croak "putGlobalSet: requires 1 argument" 1193 unless @_ == 2; 1194 croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record} 1195 unless ref $GlobalSet eq $self->{set}->{record}; 1196 1197 checkKeyfields($GlobalSet); 1198 1199 croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)" 1200 unless $self->{set}->exists($GlobalSet->set_id); 1201 1202 return $self->{set}->put($GlobalSet); 1203 } 1204 1205 =item addGlobalSet($setID) 1206 1207 =cut 1208 1209 sub deleteGlobalSet { 1210 my ($self, $setID) = @_; 1211 1212 croak "deleteGlobalSet: requires 1 argument" 1213 unless @_ == 2; 1214 croak "deleteGlobalSet: argument 1 must contain a set_id" 1215 unless defined $setID or caller eq __PACKAGE__; 1216 1217 $self->deleteUserSet(undef, $setID); 1218 $self->deleteGlobalProblem($setID, undef); 1219 return $self->{set}->delete($setID); 1220 } 1221 1222 =back 1223 1224 =cut 1225 1226 ################################################################################ 1227 # set_user functions 1228 ################################################################################ 1229 1230 =head2 User-Specific Set Methods 1231 1232 FIXME: write this 1233 1234 =over 1235 1236 =cut 1237 1238 sub newUserSet { 1239 my ($self, @prototype) = @_; 1240 return $self->{set_user}->{record}->new(@prototype); 1241 } 1242 1243 sub countSetUsers { 1244 my ($self, $setID) = @_; 1245 1246 croak "countSetUsers: requires 1 argument" 1247 unless @_ == 2; 1248 croak "countSetUsers: argument 1 must contain a set_id" 1249 unless defined $setID; 1250 1251 # inefficient way 1252 #return scalar $self->{set_user}->list(undef, $setID); 1253 1254 # efficient way 1255 return $self->{set_user}->count(undef, $setID); 1256 } 1257 1258 sub listSetUsers { 1259 my ($self, $setID) = @_; 1260 1261 carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n" 1262 unless wantarray; 1263 1264 croak "listSetUsers: requires 1 argument" 1265 unless @_ == 2; 1266 croak "listSetUsers: argument 1 must contain a set_id" 1267 unless defined $setID; 1268 1269 return map { $_->[0] } # extract user_id 1270 $self->{set_user}->list(undef, $setID); 1271 } 1272 1273 sub countUserSets { 1274 my ($self, $userID) = @_; 1275 1276 croak "countUserSets: requires 1 argument" 1277 unless @_ == 2; 1278 croak "countUserSets: argument 1 must contain a user_id" 1279 unless defined $userID; 1280 1281 return $self->{set_user}->count($userID, undef); 1282 } 1283 1284 sub listUserSets { 1285 my ($self, $userID) = @_; 1286 1287 croak "listUserSets: requires 1 argument" 1288 unless @_ == 2; 1289 croak "listUserSets: argument 1 must contain a user_id" 1290 unless defined $userID; 1291 1292 return map { $_->[1] } # extract set_id 1293 $self->{set_user}->list($userID, undef); 1294 } 1295 1296 sub addUserSet { 1297 my ($self, $UserSet) = @_; 1298 1299 croak "addUserSet: requires 1 argument" 1300 unless @_ == 2; 1301 croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1302 unless ref $UserSet eq $self->{set_user}->{record}; 1303 1304 checkKeyfields($UserSet); 1305 1306 croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)" 1307 if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1308 croak "addUserSet: user ", $UserSet->user_id, " not found" 1309 unless $self->{user}->exists($UserSet->user_id); 1310 croak "addUserSet: set ", $UserSet->set_id, " not found" 1311 unless $self->{set}->exists($UserSet->set_id); 1312 1313 return $self->{set_user}->add($UserSet); 1314 } 1315 1316 sub getUserSet { 1317 my ($self, $userID, $setID) = @_; 1318 1319 croak "getUserSet: requires 2 arguments" 1320 unless @_ == 3; 1321 croak "getUserSet: argument 1 must contain a user_id" 1322 unless defined $userID; 1323 croak "getUserSet: argument 2 must contain a set_id" 1324 unless defined $setID; 1325 1326 #return $self->{set_user}->get($userID, $setID); 1327 return ( $self->getUserSets([$userID, $setID]) )[0]; 1328 } 1329 1330 =item getUserSets(@userSetIDs) 1331 1332 Return a list of user set records associated with the record IDs given. If there 1333 is no record associated with a given record ID, that element of the list will be 1334 undefined. @userProblemIDs consists of references to arrays in which the first 1335 element is the user_id and the second element is the set_id. 1336 1337 =cut 1338 1339 sub getUserSets { 1340 my ($self, @userSetIDs) = @_; 1341 1342 #croak "getUserSets: requires 1 or more argument" 1343 # unless @_ >= 2; 1344 foreach my $i (0 .. $#userSetIDs) { 1345 croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair" 1346 unless defined $userSetIDs[$i] 1347 and ref $userSetIDs[$i] eq "ARRAY" 1348 and @{$userSetIDs[$i]} == 2 1349 and defined $userSetIDs[$i]->[0] 1350 and defined $userSetIDs[$i]->[1]; 1351 } 1352 1353 return $self->{set_user}->gets(@userSetIDs); 1354 } 1355 1356 sub putUserSet { 1357 my ($self, $UserSet) = @_; 1358 1359 croak "putUserSet: requires 1 argument" 1360 unless @_ == 2; 1361 croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1362 unless ref $UserSet eq $self->{set_user}->{record}; 1363 1364 checkKeyfields($UserSet); 1365 1366 croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)" 1367 unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1368 croak "putUserSet: user ", $UserSet->user_id, " not found" 1369 unless $self->{user}->exists($UserSet->user_id); 1370 croak "putUserSet: set ", $UserSet->set_id, " not found" 1371 unless $self->{set}->exists($UserSet->set_id); 1372 1373 return $self->{set_user}->put($UserSet); 1374 } 1375 1376 sub deleteUserSet { 1377 my ($self, $userID, $setID) = @_; 1378 1379 croak "getUserSet: requires 2 arguments" 1380 unless @_ == 3; 1381 croak "getUserSet: argument 1 must contain a user_id" 1382 unless defined $userID or caller eq __PACKAGE__; 1383 croak "getUserSet: argument 2 must contain a set_id" 1384 unless defined $userID or caller eq __PACKAGE__; 1385 1386 $self->deleteUserProblem($userID, $setID, undef); 1387 return $self->{set_user}->delete($userID, $setID); 1388 } 1389 1390 =back 1391 1392 =cut 1393 1394 ################################################################################ 1395 # problem functions 1396 ################################################################################ 1397 1398 =head2 Global Problem Methods 1399 1400 FIXME: write this 1401 1402 =over 1403 1404 =cut 1405 1406 sub newGlobalProblem { 1407 my ($self, @prototype) = @_; 1408 return $self->{problem}->{record}->new(@prototype); 1409 } 1410 1411 sub listGlobalProblems { 1412 my ($self, $setID) = @_; 1413 1414 croak "listGlobalProblems: requires 1 arguments" 1415 unless @_ == 2; 1416 croak "listGlobalProblems: argument 1 must contain a set_id" 1417 unless defined $setID; 1418 1419 return map { $_->[1] } 1420 $self->{problem}->list($setID, undef); 1421 } 1422 1423 sub addGlobalProblem { 1424 my ($self, $GlobalProblem) = @_; 1425 1426 croak "addGlobalProblem: requires 1 argument" 1427 unless @_ == 2; 1428 croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1429 unless ref $GlobalProblem eq $self->{problem}->{record}; 1430 1431 checkKeyfields($GlobalProblem); 1432 1433 croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)" 1434 if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1435 croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1436 unless $self->{set}->exists($GlobalProblem->set_id); 1437 1438 return $self->{problem}->add($GlobalProblem); 1439 } 1440 1441 sub getGlobalProblem { 1442 my ($self, $setID, $problemID) = @_; 1443 1444 croak "getGlobalProblem: requires 2 arguments" 1445 unless @_ == 3; 1446 croak "getGlobalProblem: argument 1 must contain a set_id" 1447 unless defined $setID; 1448 croak "getGlobalProblem: argument 2 must contain a problem_id" 1449 unless defined $problemID; 1450 1451 return $self->{problem}->get($setID, $problemID); 1452 } 1453 1454 =item getGlobalProblems(@problemIDs) 1455 1456 Return a list of global set records associated with the record IDs given. If 1457 there is no record associated with a given record ID, that element of the list 1458 will be undefined. @problemIDs consists of references to arrays in which the 1459 first element is the set_id, and the second element is the problem_id. 1460 1461 =cut 1462 1463 sub getGlobalProblems { 1464 my ($self, @problemIDs) = @_; 1465 1466 #croak "getGlobalProblems: requires 1 or more argument" 1467 # unless @_ >= 2; 1468 foreach my $i (0 .. $#problemIDs) { 1469 croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair" 1470 unless defined $problemIDs[$i] 1471 and ref $problemIDs[$i] eq "ARRAY" 1472 and @{$problemIDs[$i]} == 2 1473 and defined $problemIDs[$i]->[0] 1474 and defined $problemIDs[$i]->[1]; 1475 } 1476 1477 return $self->{problem}->gets(@problemIDs); 1478 } 1479 1480 =item getAllGlobalProblems($setID) 1481 1482 Returns a list of Problem objects representing all the problems in the given 1483 global set. When using the WW1Hash/GlobalTableEmulator schemas, this is far 1484 more efficient than using listGlobalProblems and getGlobalProblems. 1485 1486 =cut 1487 1488 sub getAllGlobalProblems { 1489 my ($self, $setID) = @_; 1490 1491 croak "getAllGlobalProblems: requires 1 arguments" 1492 unless @_ == 2; 1493 croak "getAllGlobalProblems: argument 1 must contain a set_id" 1494 unless defined $setID; 1495 1496 if ($self->{problem}->can("getAll")) { 1497 return $self->{problem}->getAll($setID); 1498 } else { 1499 my @problemIDPairs = $self->{problem}->list($setID, undef); 1500 return $self->{problem}->gets(@problemIDPairs); 1501 } 1502 } 1503 1504 sub putGlobalProblem { 1505 my ($self, $GlobalProblem) = @_; 1506 1507 croak "putGlobalProblem: requires 1 argument" 1508 unless @_ == 2; 1509 croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1510 unless ref $GlobalProblem eq $self->{problem}->{record}; 1511 1512 checkKeyfields($GlobalProblem); 1513 1514 croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)" 1515 unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1516 croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1517 unless $self->{set}->exists($GlobalProblem->set_id); 1518 1519 return $self->{problem}->put($GlobalProblem); 1520 } 1521 1522 sub deleteGlobalProblem { 1523 my ($self, $setID, $problemID) = @_; 1524 1525 croak "deleteGlobalProblem: requires 2 arguments" 1526 unless @_ == 3; 1527 croak "deleteGlobalProblem: argument 1 must contain a set_id" 1528 unless defined $setID or caller eq __PACKAGE__; 1529 croak "deleteGlobalProblem: argument 2 must contain a problem_id" 1530 unless defined $problemID or caller eq __PACKAGE__; 1531 1532 $self->deleteUserProblem(undef, $setID, $problemID); 1533 return $self->{problem}->delete($setID, $problemID); 1534 } 1535 1536 =back 1537 1538 =cut 1539 1540 ################################################################################ 1541 # problem_user functions 1542 ################################################################################ 1543 1544 =head2 User-Specific Problem Methods 1545 1546 FIXME: write this 1547 1548 =over 1549 1550 =cut 1551 1552 sub newUserProblem { 1553 my ($self, @prototype) = @_; 1554 return $self->{problem_user}->{record}->new(@prototype); 1555 } 1556 1557 sub countProblemUsers { 1558 my ($self, $setID, $problemID) = @_; 1559 1560 croak "countProblemUsers: requires 2 arguments" 1561 unless @_ == 3; 1562 croak "countProblemUsers: argument 1 must contain a set_id" 1563 unless defined $setID; 1564 croak "countProblemUsers: argument 2 must contain a problem_id" 1565 unless defined $problemID; 1566 1567 # the slow way 1568 #return scalar $self->{problem_user}->list(undef, $setID, $problemID); 1569 1570 # the fast way 1571 return $self->{problem_user}->count(undef, $setID, $problemID); 1572 } 1573 1574 sub listProblemUsers { 1575 my ($self, $setID, $problemID) = @_; 1576 1577 carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n" 1578 unless wantarray; 1579 1580 croak "listProblemUsers: requires 2 arguments" 1581 unless @_ == 3; 1582 croak "listProblemUsers: argument 1 must contain a set_id" 1583 unless defined $setID; 1584 croak "listProblemUsers: argument 2 must contain a problem_id" 1585 unless defined $problemID; 1586 1587 return map { $_->[0] } # extract user_id 1588 $self->{problem_user}->list(undef, $setID, $problemID); 1589 } 1590 1591 sub listUserProblems { 1592 my ($self, $userID, $setID) = @_; 1593 1594 croak "listUserProblems: requires 2 arguments" 1595 unless @_ == 3; 1596 croak "listUserProblems: argument 1 must contain a user_id" 1597 unless defined $userID; 1598 croak "listUserProblems: argument 2 must contain a set_id" 1599 unless defined $setID; 1600 1601 return map { $_->[2] } # extract problem_id 1602 $self->{problem_user}->list($userID, $setID, undef); 1603 } 1604 1605 sub addUserProblem { 1606 my ($self, $UserProblem) = @_; 1607 1608 croak "addUserProblem: requires 1 argument" 1609 unless @_ == 2; 1610 croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1611 unless ref $UserProblem eq $self->{problem_user}->{record}; 1612 1613 checkKeyfields($UserProblem); 1614 1615 croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)" 1616 if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1617 croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1618 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1619 croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1620 unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id); 1621 1622 return $self->{problem_user}->add($UserProblem); 1623 } 1624 1625 sub getUserProblem { 1626 my ($self, $userID, $setID, $problemID) = @_; 1627 1628 croak "getUserProblem: requires 3 arguments" 1629 unless @_ == 4; 1630 croak "getUserProblem: argument 1 must contain a user_id" 1631 unless defined $userID; 1632 croak "getUserProblem: argument 2 must contain a set_id" 1633 unless defined $setID; 1634 croak "getUserProblem: argument 3 must contain a problem_id" 1635 unless defined $problemID; 1636 1637 return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0]; 1638 } 1639 1640 =item getUserProblems(@userProblemIDs) 1641 1642 Return a list of user set records associated with the user IDs given. If there 1643 is no record associated with a given user ID, that element of the list will be 1644 undefined. @userProblemIDs consists of references to arrays in which the first 1645 element is the user_id, the second element is the set_id, and the third element 1646 is the problem_id. 1647 1648 =cut 1649 1650 sub getUserProblems { 1651 my ($self, @userProblemIDs) = @_; 1652 1653 #croak "getUserProblems: requires 1 or more argument" 1654 # unless @_ >= 2; 1655 foreach my $i (0 .. $#userProblemIDs) { 1656 croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1657 unless defined $userProblemIDs[$i] 1658 and ref $userProblemIDs[$i] eq "ARRAY" 1659 and @{$userProblemIDs[$i]} == 3 1660 and defined $userProblemIDs[$i]->[0] 1661 and defined $userProblemIDs[$i]->[1] 1662 and defined $userProblemIDs[$i]->[2]; 1663 } 1664 1665 return $self->{problem_user}->gets(@userProblemIDs); 1666 } 1667 1668 =item getAllUserProblems($userID, $setID) 1669 1670 Returns a list of UserProblem objects representing all the problems in the 1671 given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far 1672 more efficient than using listUserProblems and getUserProblems. 1673 1674 =cut 1675 1676 sub getAllUserProblems { 1677 my ($self, $userID, $setID) = @_; 1678 1679 croak "getAllUserProblems: requires 2 arguments" 1680 unless @_ == 3; 1681 croak "getAllUserProblems: argument 1 must contain a user_id" 1682 unless defined $userID; 1683 croak "getAllUserProblems: argument 2 must contain a set_id" 1684 unless defined $setID; 1685 1686 if ($self->{problem_user}->can("getAll")) { 1687 return $self->{problem_user}->getAll($userID, $setID); 1688 } else { 1689 my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef); 1690 return $self->{problem_user}->gets(@problemIDTriples); 1691 } 1692 } 1693 1694 sub putUserProblem { 1695 my ($self, $UserProblem) = @_; 1696 1697 croak "putUserProblem: requires 1 argument" 1698 unless @_ == 2; 1699 croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1700 unless ref $UserProblem eq $self->{problem_user}->{record}; 1701 1702 checkKeyfields($UserProblem); 1703 1704 croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1705 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1706 croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)" 1707 unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1708 croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1709 unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id); 1710 1711 return $self->{problem_user}->put($UserProblem); 1712 } 1713 1714 sub deleteUserProblem { 1715 my ($self, $userID, $setID, $problemID) = @_; 1716 1717 croak "getUserProblem: requires 3 arguments" 1718 unless @_ == 4; 1719 croak "getUserProblem: argument 1 must contain a user_id" 1720 unless defined $userID or caller eq __PACKAGE__; 1721 croak "getUserProblem: argument 2 must contain a set_id" 1722 unless defined $setID or caller eq __PACKAGE__; 1723 croak "getUserProblem: argument 3 must contain a problem_id" 1724 unless defined $problemID or caller eq __PACKAGE__; 1725 1726 return $self->{problem_user}->delete($userID, $setID, $problemID); 1727 } 1728 1729 =back 1730 1731 =cut 1732 1733 ################################################################################ 1734 # set+set_user functions 1735 ################################################################################ 1736 1737 =head2 Set Merging Methods 1738 1739 These functions combine a global set and a user set to create a merged set, 1740 which is returned. Any field that is not defined in the user set is taken from 1741 the global set. Merged sets have the same type as user sets. 1742 1743 =over 1744 1745 =cut 1746 1747 sub getGlobalUserSet { 1748 carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead"; 1749 return shift->getMergedSet(@_); 1750 } 1751 1752 =item getMergedSet($userID, $setID) 1753 1754 Returns a merged set record associated with the record IDs given. If there is no 1755 record associated with a given record ID, the undefined value is returned. 1756 1757 =cut 1758 1759 sub getMergedSet { 1760 my ($self, $userID, $setID) = @_; 1761 1762 croak "getMergedSet: requires 2 arguments" 1763 unless @_ == 3; 1764 croak "getMergedSet: argument 1 must contain a user_id" 1765 unless defined $userID; 1766 croak "getMergedSet: argument 2 must contain a set_id" 1767 unless defined $setID; 1768 1769 return ( $self->getMergedSets([$userID, $setID]) )[0]; 1770 } 1771 1772 =item getMegedSets(@userSetIDs) 1773 1774 Return a list of merged set records associated with the record IDs given. If 1775 there is no record associated with a given record ID, that element of the list 1776 will be undefined. @userSetIDs consists of references to arrays in which the 1777 first element is the user_id and the second element is the set_id. 1778 1779 =cut 1780 1781 sub getMergedSets { 1782 my ($self, @userSetIDs) = @_; 1783 1784 #croak "getMergedSets: requires 1 or more argument" 1785 # unless @_ >= 2; 1786 foreach my $i (0 .. $#userSetIDs) { 1787 croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair" 1788 unless defined $userSetIDs[$i] 1789 and ref $userSetIDs[$i] eq "ARRAY" 1790 and @{$userSetIDs[$i]} == 2 1791 and defined $userSetIDs[$i]->[0] 1792 and defined $userSetIDs[$i]->[1]; 1793 } 1794 1795 # a horrible, terrible hack ;) 1796 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash" 1797 and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") { 1798 #warn __PACKAGE__.": using a terrible hack.\n"; 1799 $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer); 1800 my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs); 1801 $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer); 1802 return @MergedSets; 1803 } 1804 1805 $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer); 1806 my @UserSets = $self->getUserSets(@userSetIDs); # checked 1807 1808 $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer); 1809 my @globalSetIDs = map { $_->[1] } @userSetIDs; 1810 $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer); 1811 my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked 1812 1813 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 1814 my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS; 1815 my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS; 1816 1817 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 1818 for (my $i = 0; $i < @UserSets; $i++) { 1819 my $UserSet = $UserSets[$i]; 1820 my $GlobalSet = $GlobalSets[$i]; 1821 next unless defined $UserSet and defined $GlobalSet; 1822 foreach my $field (@commonFields) { 1823 #next if defined $UserSet->$field; 1824 # ok, now we're testing for emptiness as well as definedness. 1825 next if defined $UserSet->$field and $UserSet->$field ne ""; 1826 $UserSet->$field($GlobalSet->$field); 1827 } 1828 } 1829 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 1830 1831 return @UserSets; 1832 } 1833 1834 =back 1835 1836 =cut 1837 1838 ################################################################################ 1839 # problem+problem_user functions 1840 ################################################################################ 1841 1842 =head2 Problem Merging Methods 1843 1844 These functions combine a global problem and a user problem to create a merged 1845 problem, which is returned. Any field that is not defined in the user problem is 1846 taken from the global problem. Merged problems have the same type as user 1847 problems. 1848 1849 =over 1850 1851 =cut 1852 1853 sub getGlobalUserProblem { 1854 carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead"; 1855 return shift->getMergedProblem(@_); 1856 } 1857 1858 =item getMergedProblem($userID, $setID, $problemID) 1859 1860 Returns a merged problem record associated with the record IDs given. If there 1861 is no record associated with a given record ID, the undefined value is returned. 1862 1863 =cut 1864 1865 sub getMergedProblem { 1866 my ($self, $userID, $setID, $problemID) = @_; 1867 1868 croak "getGlobalUserSet: requires 3 arguments" 1869 unless @_ == 4; 1870 croak "getGlobalUserSet: argument 1 must contain a user_id" 1871 unless defined $userID; 1872 croak "getGlobalUserSet: argument 2 must contain a set_id" 1873 unless defined $setID; 1874 croak "getGlobalUserSet: argument 3 must contain a problem_id" 1875 unless defined $problemID; 1876 1877 return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0]; 1878 } 1879 1880 =item getMergedProblems(@userProblemIDs) 1881 1882 Return a list of merged problem records associated with the record IDs given. If 1883 there is no record associated with a given record ID, that element of the list 1884 will be undefined. @userProblemIDs consists of references to arrays in which the 1885 first element is the user_id, the second element is the set_id, and the third 1886 element is the problem_id. 1887 1888 =cut 1889 1890 sub getMergedProblems { 1891 my ($self, @userProblemIDs) = @_; 1892 1893 #croak "getMergedProblems: requires 1 or more argument" 1894 # unless @_ >= 2; 1895 foreach my $i (0 .. $#userProblemIDs) { 1896 croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1897 unless defined $userProblemIDs[$i] 1898 and ref $userProblemIDs[$i] eq "ARRAY" 1899 and @{$userProblemIDs[$i]} == 3 1900 and defined $userProblemIDs[$i]->[0] 1901 and defined $userProblemIDs[$i]->[1] 1902 and defined $userProblemIDs[$i]->[2]; 1903 } 1904 1905 $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer); 1906 my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked 1907 1908 $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer); 1909 my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs; 1910 $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer); 1911 my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked 1912 1913 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 1914 my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS; 1915 my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS; 1916 1917 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 1918 for (my $i = 0; $i < @UserProblems; $i++) { 1919 my $UserProblem = $UserProblems[$i]; 1920 my $GlobalProblem = $GlobalProblems[$i]; 1921 next unless defined $UserProblem and defined $GlobalProblem; 1922 foreach my $field (@commonFields) { 1923 # FIXME: WW1Hash upgrades undefined fileds to "" when creating record objects 1924 # Shouldn't we be testing for emptiness rather than definedness? 1925 # I think the spec says that if a field is EMPTY the global value is used. 1926 #next if defined $UserProblem->$field; 1927 # ok, now we're testing for emptiness as well as definedness. 1928 next if defined $UserProblem->$field and $UserProblem->$field ne ""; 1929 $UserProblem->$field($GlobalProblem->$field); 1930 } 1931 } 1932 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 1933 1934 return @UserProblems; 1935 } 1936 1937 =back 1938 1939 =cut 1940 1941 ################################################################################ 1942 # debugging 1943 ################################################################################ 1944 1945 #sub dumpDB($$) { 1946 # my ($self, $table) = @_; 1947 # return $self->{$table}->dumpDB(); 1948 #} 1949 1950 ################################################################################ 1951 # utilities 1952 ################################################################################ 1953 1954 sub checkKeyfields($) { 1955 my ($Record) = @_; 1956 foreach my $keyfield ($Record->KEYFIELDS) { 1957 my $value = $Record->$keyfield; 1958 croak "checkKeyfields: $keyfield is empty" 1959 unless defined $value and $value ne ""; 1960 1961 if ($keyfield eq "problem_id") { 1962 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])" 1963 unless $value =~ m/^\d*$/; 1964 } else { 1965 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])" 1966 unless $value =~ m/^[\w-]*$/; 1967 } 1968 } 1969 } 1970 1971 =head1 AUTHOR 1972 1973 Written by Sam Hathaway, sh002i (at) math.rochester.edu. 1974 1975 =cut 1976 1977 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |