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