Parent Directory
| 
Revision Log
removed debugging statements
1 ################################################################################ 2 # WeBWorK mod_perl (c) 2000-2002 WeBWorK Project 3 # $Id$ 4 ################################################################################ 5 6 package WeBWorK::DB; 7 8 =head1 NAME 9 10 WeBWorK::DB - interface with the WeBWorK databases. 11 12 =head1 SYNOPSIS 13 14 my $db = WeBWorK::DB->new($courseEnvironment); 15 16 my @userIDs = $db->listUsers(); 17 my $Sam = $db->{user}->{record}->new(); 18 19 $Sam->user_id("sammy"); 20 $Sam->first_name("Sam"); 21 $Sam->last_name("Hathaway"); 22 # etc. 23 24 $db->addUser($User); 25 my $Dennis = $db->getUser("dennis"); 26 $Dennis->status("C"); 27 $db->putUser->($Dennis); 28 29 $db->deleteUser("sammy"); 30 31 =head1 DESCRIPTION 32 33 WeBWorK::DB provides a consistent interface to a number of database backends. 34 Access and modification functions are provided for each logical table used by 35 the webwork system. The particular backend ("schema" and "driver"), record 36 class, data source, and additional parameters are specified by the C<%dbLayout> 37 hash in the course environment. 38 39 =head1 ARCHITECTURE 40 41 The new database system uses a three-tier architecture to insulate each layer 42 from the adjacent layers. 43 44 =head2 Top Layer: DB 45 46 The top layer of the architecture is the DB module. It provides the methods 47 listed below, and uses schema modules (via tables) to implement those methods. 48 49 / new* list* exists* add* get* get*s put* delete* \ <- api 50 +------------------------------------------------------------------+ 51 | DB | 52 +------------------------------------------------------------------+ 53 \ password permission key user set set_user problem problem_user / <- tables 54 55 =head2 Middle Layer: Schemas 56 57 The middle layer of the architecture is provided by one or more schema modules. 58 They are called "schema" modules because they control the structure of the data 59 for a table. This includes odd things like the way multiple tables are encoded 60 in a single hash in the WW1Hash schema, and the encoding scheme used. 61 62 The schema modules provide an API that matches the requirements of the DB 63 layer, on a per-table basis. Each schema module has a style that determines 64 which drivers it can interface with. For example, WW1Hash is a "hash" style 65 schema. SQL is a "dbi" style schema. 66 67 =head3 Examples 68 69 Both WeBWorK 1.x and 2.x courses use: 70 71 / password permission key \ / user \ <- tables provided 72 +-----------------------------+ +----------------+ 73 | Auth1Hash | | Classlist1Hash | 74 +-----------------------------+ +----------------+ 75 \ hash / \ hash / <- driver style required 76 77 WeBWorK 1.x courses also use: 78 79 / set_user problem_user \ / set problem \ 80 +-------------------------+ +---------------------+ 81 | WW1Hash | | GlobalTableEmulator | 82 +-------------------------+ +---------------------+ 83 \ hash / \ null / 84 85 The GlobalTableEmulator schema emulates the global set and problem tables using 86 data from the set_user and problem_user tables. 87 88 WeBWorK 2.x courses also use: 89 90 / set set_user problem problem_user \ 91 +-------------------------------------+ 92 | WW2Hash | 93 +-------------------------------------+ 94 \ hash / 95 96 =head2 Bottom Layer: Drivers 97 98 Driver modules implement a style for a schema. They provide physical access to 99 a data source containing the data for a table. The style of a driver determines 100 what methods it provides. All drivers provide C<connect(MODE)> and 101 C<disconnect()> methods. A hash style driver provides a C<hash()> method which 102 returns the tied hash. A dbi style driver provides a C<handle()> method which 103 returns the DBI handle. 104 105 =head3 Examples 106 107 / hash \ / hash \ / hash \ <- style 108 +--------+ +--------+ +--------+ 109 | DB | | GDBM | | DB3 | 110 +--------+ +--------+ +--------+ 111 112 / dbi \ / ldap \ 113 +-------+ +--------+ 114 | SQL | | LDAP | 115 +-------+ +--------+ 116 117 =head2 Record Types 118 119 In C<%dblayout>, each table is assigned a record class, used for passing 120 complete records to and from the database. The default record classes are 121 subclasses of the WeBWorK::DB::Record class, and are named as follows: User, 122 Password, PermissionLevel, Key, Set, UserSet, Problem, UserProblem. In the 123 following documentation, a reference the the record class for a table means the 124 record class currently defined for that table in C<%dbLayout>. 125 126 =cut 127 128 use strict; 129 use warnings; 130 use Carp; 131 use Data::Dumper; 132 use WeBWorK::Timing; 133 use WeBWorK::Utils qw(runtime_use); 134 135 ################################################################################ 136 # constructor 137 ################################################################################ 138 139 =head1 CONSTRUCTOR 140 141 =over 142 143 =item new($ce) 144 145 The C<new> method creates a DB object and brings up the underlying 146 schema/driver structure according to the C<%dbLayout> hash in C<$ce>, a 147 WeBWorK::CourseEnvironment object. 148 149 =back 150 151 =head2 C<%dbLayout> Format 152 153 The C<%dbLayout> hash consists of items keyed by table names. The value of each 154 item is a reference to a hash containing the following items: 155 156 =over 157 158 =item record 159 160 The name of a perl module to use for representing the data in a record. 161 162 =item schema 163 164 The name of a perl module to use for access to the table. 165 166 =item driver 167 168 The name of a perl module to use for access to the data source. 169 170 =item source 171 172 The location of the data source that should be used by the driver module. 173 Depending on the driver, this may be a path, a url, or a DBI spec. 174 175 =item params 176 177 A reference to a hash containing extra information needed by the schema. Some 178 schemas require parameters, some do not. Consult the documentation for the 179 schema in question. 180 181 =back 182 183 For each table defined in C<%dbLayout>, C<new> loads the record, schema, and 184 driver modules. It the schema module's C<tables> method lists the current table 185 (or contains the string "*") and the output of the schema and driver modules' 186 C<style> methods match, the table is installed. Otherwise, an exception is 187 thrown. 188 189 =cut 190 191 sub new($$) { 192 my ($invocant, $ce) = @_; 193 my $class = ref($invocant) || $invocant; 194 my $self = {}; 195 bless $self, $class; # bless this here so we can pass it to the schema 196 197 # load the modules required to handle each table, and create driver 198 my %dbLayout = %{$ce->{dbLayout}}; 199 foreach my $table (keys %dbLayout) { 200 my $layout = $dbLayout{$table}; 201 my $record = $layout->{record}; 202 my $schema = $layout->{schema}; 203 my $driver = $layout->{driver}; 204 my $source = $layout->{source}; 205 my $params = $layout->{params}; 206 207 runtime_use($record); 208 209 runtime_use($driver); 210 my $driverObject = eval { $driver->new($source, $params) }; 211 croak "error instantiating DB driver $driver for table $table: $@" 212 if $@; 213 214 runtime_use($schema); 215 my $schemaObject = eval { $schema->new( 216 $self, $driver->new($source, $params), 217 $table, $record, $params) }; 218 croak "error instantiating DB schema $schema for table $table: $@" 219 if $@; 220 221 $self->{$table} = $schemaObject; 222 } 223 224 return $self; 225 } 226 227 =head1 METHODS 228 229 =cut 230 231 ################################################################################ 232 # password functions 233 ################################################################################ 234 235 =head2 Password Methods 236 237 =over 238 239 =item newPassword() 240 241 Returns a new, empty password object. 242 243 =cut 244 245 sub newPassword { 246 my ($self, @prototype) = @_; 247 return $self->{password}->{record}->new(@prototype); 248 } 249 250 =item listPasswords() 251 252 Returns a list of user IDs representing the records in the password table. 253 254 =cut 255 256 sub listPasswords { 257 my ($self) = @_; 258 259 croak "listPasswords: requires 0 arguments" 260 unless @_ == 1; 261 262 return map { $_->[0] } 263 $self->{password}->list(undef); 264 } 265 266 =item addPassword($Password) 267 268 $Password is a record object. The password will be added to the password table 269 if a password with the same user ID does not already exist. If one does exist, 270 an exception is thrown. To add a password, a user with a matching user ID must 271 exist in the user table. 272 273 =cut 274 275 sub addPassword { 276 my ($self, $Password) = @_; 277 278 croak "addPassword: requires 1 argument" 279 unless @_ == 2; 280 croak "addPassword: argument 1 must be of type ", $self->{password}->{record} 281 unless ref $Password eq $self->{password}->{record}; 282 283 checkKeyfields($Password); 284 285 croak "addPassword: password exists (perhaps you meant to use putPassword?)" 286 if $self->{password}->exists($Password->user_id); 287 croak "addPassword: user ", $Password->user_id, " not found" 288 unless $self->{user}->exists($Password->user_id); 289 290 return $self->{password}->add($Password); 291 } 292 293 =item getPassword($userID) 294 295 If a record with a matching user ID exists, a record object containting that 296 record's data will be returned. If no such record exists, one will be created. 297 298 =cut 299 300 sub getPassword { 301 my ($self, $userID) = @_; 302 303 croak "getPassword: requires 1 argument" 304 unless @_ == 2; 305 croak "getPassword: argument 1 must contain a user_id" 306 unless defined $userID; 307 308 #return $self->{password}->get($userID); 309 return ( $self->getPasswords($userID) )[0]; 310 } 311 312 =item getPasswords(@uesrIDs) 313 314 Return a list of password records associated with the user IDs given. If there 315 is no record associated with a given user ID, one will be created. 316 317 =cut 318 319 sub getPasswords { 320 my ($self, @userIDs) = @_; 321 322 #croak "getPasswords: requires 1 or more argument" 323 # unless @_ >= 2; 324 foreach my $i (0 .. $#userIDs) { 325 croak "getPasswords: element $i of argument list must contain a user_id" 326 unless defined $userIDs[$i]; 327 } 328 329 my @Passwords = $self->{password}->gets(map { [$_] } @userIDs); 330 331 for (my $i = 0; $i < @Passwords; $i++) { 332 my $Password = $Passwords[$i]; 333 my $userID = $userIDs[$i]; 334 if (not defined $Password) { 335 #warn "not defined\n"; 336 if ($self->{user}->exists($userID)) { 337 #warn "user exists\n"; 338 $Password = $self->newPassword(user_id => $userID); 339 eval { $self->addPassword($Password) }; 340 if ($@ and $@ !~ m/password exists/) { 341 die "error while auto-creating password record for user $userID: \"$@\""; 342 } 343 } 344 } 345 } 346 347 return @Passwords; 348 } 349 350 =item putPassword($Password) 351 352 $Password is a record object. If a password record with the same user ID exists 353 in the password table, the data in the record is replaced with the data in 354 $Password. If a matching password record does not exist, an exception is 355 thrown. 356 357 =cut 358 359 sub putPassword($$) { 360 my ($self, $Password) = @_; 361 362 croak "putPassword: requires 1 argument" 363 unless @_ == 2; 364 croak "putPassword: argument 1 must be of type ", $self->{password}->{record} 365 unless ref $Password eq $self->{password}->{record}; 366 367 checkKeyfields($Password); 368 369 croak "putPassword: password not found (perhaps you meant to use addPassword?)" 370 unless $self->{password}->exists($Password->user_id); 371 372 return $self->{password}->put($Password); 373 } 374 375 =item deletePassword($userID) 376 377 If a password record with a user ID matching $userID exists in the password 378 table, it is removed and the method returns a true value. If one does exist, 379 a false value is returned. 380 381 =cut 382 383 sub deletePassword($$) { 384 my ($self, $userID) = @_; 385 386 croak "putPassword: requires 1 argument" 387 unless @_ == 2; 388 croak "deletePassword: argument 1 must contain a user_id" 389 unless defined $userID; 390 391 return $self->{password}->delete($userID); 392 } 393 394 =back 395 396 =cut 397 398 ################################################################################ 399 # permission functions 400 ################################################################################ 401 402 =head2 Permission Level Methods 403 404 =over 405 406 =item newPermissionLevel() 407 408 Returns a new, empty permission level object. 409 410 =cut 411 412 sub newPermissionLevel { 413 my ($self, @prototype) = @_; 414 return $self->{permission}->{record}->new(@prototype); 415 } 416 417 =item listPermissionLevels() 418 419 Returns a list of user IDs representing the records in the permission table. 420 421 =cut 422 423 sub listPermissionLevels($) { 424 my ($self) = @_; 425 426 croak "listPermissionLevels: requires 0 arguments" 427 unless @_ == 1; 428 429 return map { $_->[0] } 430 $self->{permission}->list(undef); 431 } 432 433 =item addPermissionLevel($PermissionLevel) 434 435 $PermissionLevel is a record object. The permission level will be added to the 436 permission table if a permission level with the same user ID does not already 437 exist. If one does exist, an exception is thrown. To add a permission level, a 438 user with a matching user ID must exist in the user table. 439 440 =cut 441 442 sub addPermissionLevel($$) { 443 my ($self, $PermissionLevel) = @_; 444 445 croak "addPermissionLevel: requires 1 argument" 446 unless @_ == 2; 447 croak "addPermissionLevel: argument 1 must be of type ", $self->{permission}->{record} 448 unless ref $PermissionLevel eq $self->{permission}->{record}; 449 450 checkKeyfields($PermissionLevel); 451 452 croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)" 453 if $self->{permission}->exists($PermissionLevel->user_id); 454 croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found" 455 unless $self->{user}->exists($PermissionLevel->user_id); 456 457 return $self->{permission}->add($PermissionLevel); 458 } 459 460 =item getPermissionLevel($userID) 461 462 If a record with a matching user ID exists, a record object containting that 463 record's data will be returned. If no such record exists, one will be created. 464 465 =cut 466 467 sub getPermissionLevel($$) { 468 my ($self, $userID) = @_; 469 470 croak "getPermissionLevel: requires 1 argument" 471 unless @_ == 2; 472 croak "getPermissionLevel: argument 1 must contain a user_id" 473 unless defined $userID; 474 475 #return $self->{permission}->get($userID); 476 return ( $self->getPermissionLevels($userID) )[0]; 477 } 478 479 =item getPermissionLevels(@uesrIDs) 480 481 Return a list of permission level records associated with the user IDs given. If 482 there is no record associated with a given user ID, one will be created. 483 484 =cut 485 486 sub getPermissionLevels { 487 my ($self, @userIDs) = @_; 488 489 #croak "getPermissionLevels: requires 1 or more argument" 490 # unless @_ >= 2; 491 foreach my $i (0 .. $#userIDs) { 492 croak "getPermissionLevels: element $i of argument list must contain a user_id" 493 unless defined $userIDs[$i]; 494 } 495 496 my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs); 497 498 for (my $i = 0; $i < @PermissionLevels; $i++) { 499 my $PermissionLevel = $PermissionLevels[$i]; 500 my $userID = $userIDs[$i]; 501 if (not defined $PermissionLevel) { 502 #warn "not defined\n"; 503 if ($self->{user}->exists($userID)) { 504 #warn "user exists\n"; 505 $PermissionLevel = $self->newPermissionLevel(user_id => $userID); 506 warn $PermissionLevel->toString, "\n"; 507 eval { $self->addPermissionLevel($PermissionLevel) }; 508 if ($@ and $@ !~ m/permission level exists/) { 509 die "error while auto-creating permission level record for user $userID: \"$@\""; 510 } 511 } 512 } 513 } 514 515 return @PermissionLevels; 516 } 517 518 =item putPermissionLevel($PermissionLevel) 519 520 $PermissionLevel is a record object. If a permission level record with the same 521 user ID exists in the permission table, the data in the record is replaced with 522 the data in $PermissionLevel. If a matching permission level record does not 523 exist, an exception is thrown. 524 525 =cut 526 527 sub putPermissionLevel($$) { 528 my ($self, $PermissionLevel) = @_; 529 530 croak "putPermissionLevel: requires 1 argument" 531 unless @_ == 2; 532 croak "putPermissionLevel: argument 1 must be of type ", $self->{permission}->{record} 533 unless ref $PermissionLevel eq $self->{permission}->{record}; 534 535 checkKeyfields($PermissionLevel); 536 537 croak "putPermissionLevel: permission level not found (perhaps you meant to use addPermissionLevel?)" 538 unless $self->{permission}->exists($PermissionLevel->user_id); 539 540 return $self->{permission}->put($PermissionLevel); 541 } 542 543 =item deletePermissionLevel($userID) 544 545 If a permission level record with a user ID matching $userID exists in the 546 permission table, it is removed and the method returns a true value. If one 547 does exist, a false value is returned. 548 549 =cut 550 551 sub deletePermissionLevel($$) { 552 my ($self, $userID) = @_; 553 554 croak "deletePermissionLevel: requires 1 argument" 555 unless @_ == 2; 556 croak "deletePermissionLevel: argument 1 must contain a user_id" 557 unless defined $userID; 558 559 return $self->{permission}->delete($userID); 560 } 561 562 ################################################################################ 563 # key functions 564 ################################################################################ 565 566 =head2 Key Methods 567 568 =over 569 570 =item newKey() 571 572 Returns a new, empty key object. 573 574 =cut 575 576 sub newKey { 577 my ($self, @prototype) = @_; 578 return $self->{key}->{record}->new(@prototype); 579 } 580 581 =item listKeys() 582 583 Returns a list of user IDs representing the records in the key table. 584 585 =cut 586 587 sub listKeys($) { 588 my ($self) = @_; 589 590 croak "listKeys: requires 0 arguments" 591 unless @_ == 1; 592 593 return map { $_->[0] } 594 $self->{key}->list(undef); 595 } 596 597 =item addKey($Key) 598 599 $Key is a record object. The key will be added to the key table if a key with 600 the same user ID does not already exist. If one does exist, an exception is 601 thrown. To add a key, a user with a matching user ID must exist in the user 602 table. 603 604 =cut 605 606 sub addKey($$) { 607 my ($self, $Key) = @_; 608 609 croak "addKey: requires 1 argument" 610 unless @_ == 2; 611 croak "addKey: argument 1 must be of type ", $self->{key}->{record} 612 unless ref $Key eq $self->{key}->{record}; 613 614 checkKeyfields($Key); 615 616 croak "addKey: key exists (perhaps you meant to use putKey?)" 617 if $self->{key}->exists($Key->user_id); 618 croak "addKey: user ", $Key->user_id, " not found" 619 unless $self->{user}->exists($Key->user_id); 620 621 return $self->{key}->add($Key); 622 } 623 624 =item getKey($userID) 625 626 If a record with a matching user ID exists, a record object containting that 627 record's data will be returned. If no such record exists, an undefined value 628 will be returned. 629 630 =cut 631 632 sub getKey($$) { 633 my ($self, $userID) = @_; 634 635 croak "getKey: requires 1 argument" 636 unless @_ == 2; 637 croak "getKey: argument 1 must contain a user_id" 638 unless defined $userID; 639 640 return $self->{key}->get($userID); 641 } 642 643 =item getKeys(@uesrIDs) 644 645 Return a list of key records associated with the user IDs given. If there is no 646 record associated with a given user ID, that element of the list will be 647 undefined. 648 649 =cut 650 651 sub getKeys { 652 my ($self, @userIDs) = @_; 653 654 #croak "getKeys: requires 1 or more argument" 655 # unless @_ >= 2; 656 foreach my $i (0 .. $#userIDs) { 657 croak "getKeys: element $i of argument list must contain a user_id" 658 unless defined $userIDs[$i]; 659 } 660 661 return $self->{key}->gets(map { [$_] } @userIDs); 662 } 663 664 =item putKey($Key) 665 666 $Key is a record object. If a key record with the same user ID exists in the 667 key table, the data in the record is replaced with the data in $Key. If a 668 matching key record does not exist, an exception is thrown. 669 670 =cut 671 672 sub putKey($$) { 673 my ($self, $Key) = @_; 674 675 croak "putKey: requires 1 argument" 676 unless @_ == 2; 677 croak "putKey: argument 1 must be of type ", $self->{key}->{record} 678 unless ref $Key eq $self->{key}->{record}; 679 680 checkKeyfields($Key); 681 682 croak "putKey: key not found (perhaps you meant to use addKey?)" 683 unless $self->{key}->exists($Key->user_id); 684 685 return $self->{key}->put($Key); 686 } 687 688 =item deleteKey($userID) 689 690 If a key record with a user ID matching $userID exists in the key table, it is 691 removed and the method returns a true value. If one does exist, a false value 692 is returned. 693 694 =cut 695 696 sub deleteKey($$) { 697 my ($self, $userID) = @_; 698 699 croak "deleteKey: requires 1 argument" 700 unless @_ == 2; 701 croak "deleteKey: argument 1 must contain a user_id" 702 unless defined $userID; 703 704 return $self->{key}->delete($userID); 705 } 706 707 ################################################################################ 708 # user functions 709 ################################################################################ 710 711 =head2 User Methods 712 713 =over 714 715 =item newUser() 716 717 Returns a new, empty user object. 718 719 =cut 720 721 sub newUser { 722 my ($self, @prototype) = @_; 723 return $self->{user}->{record}->new(@prototype); 724 } 725 726 =item listUsers() 727 728 Returns a list of user IDs representing the records in the user table. 729 730 =cut 731 732 sub listUsers { 733 my ($self) = @_; 734 735 croak "listUsers: requires 0 arguments" 736 unless @_ == 1; 737 738 return map { $_->[0] } 739 $self->{user}->list(undef); 740 } 741 742 =item addUser($User) 743 744 $User is a record object. The user will be added to the user table if a user 745 with the same user ID does not already exist. If one does exist, an exception 746 is thrown. 747 748 =cut 749 750 sub addUser { 751 my ($self, $User) = @_; 752 753 croak "addUser: requires 1 argument" 754 unless @_ == 2; 755 croak "addUser: argument 1 must be of type ", $self->{user}->{record} 756 unless ref $User eq $self->{user}->{record}; 757 758 checkKeyfields($User); 759 760 croak "addUser: user exists (perhaps you meant to use putUser?)" 761 if $self->{user}->exists($User->user_id); 762 763 return $self->{user}->add($User); 764 } 765 766 =item getUser($userID) 767 768 If a record with a matching user ID exists, a record object containting that 769 record's data will be returned. If no such record exists, an undefined value 770 will be returned. 771 772 =cut 773 774 sub getUser { 775 my ($self, $userID) = @_; 776 777 croak "getUser: requires 1 argument" 778 unless @_ == 2; 779 croak "getUser: argument 1 must contain a user_id" 780 unless defined $userID; 781 782 return $self->{user}->get($userID); 783 } 784 785 =item getUsers(@uesrIDs) 786 787 Return a list of user records associated with the user IDs given. If there is no 788 record associated with a given user ID, that element of the list will be 789 undefined. 790 791 =cut 792 793 sub getUsers { 794 my ($self, @userIDs) = @_; 795 796 #croak "getUsers: requires 1 or more argument" 797 # unless @_ >= 2; 798 foreach my $i (0 .. $#userIDs) { 799 croak "getUsers: element $i of argument list must contain a user_id" 800 unless defined $userIDs[$i]; 801 } 802 803 return $self->{user}->gets(map { [$_] } @userIDs); 804 } 805 806 =item putUser($User) 807 808 $User is a record object. If a user record with the same user ID exists in the 809 user table, the data in the record is replaced with the data in $User. If a 810 matching user record does not exist, an exception is thrown. 811 812 =cut 813 814 sub putUser { 815 my ($self, $User) = @_; 816 817 croak "putUser: requires 1 argument" 818 unless @_ == 2; 819 croak "putUser: argument 1 must be of type ", $self->{user}->{record} 820 unless ref $User eq $self->{user}->{record}; 821 822 checkKeyfields($User); 823 824 croak "putUser: user not found (perhaps you meant to use addUser?)" 825 unless $self->{user}->exists($User->user_id); 826 827 return $self->{user}->put($User); 828 } 829 830 =item deleteUser($userID) 831 832 If a user record with a user ID matching $userID exists in the user table, it 833 is removed and the method returns a true value. If one does exist, a false 834 value is returned. When a user record is deleted, all records associated with 835 that user are also deleted. This includes the password, permission, and key 836 records, and all user set records for that user. 837 838 =cut 839 840 sub deleteUser { 841 my ($self, $userID) = @_; 842 843 croak "deleteUser: requires 1 argument" 844 unless @_ == 2; 845 croak "deleteUser: argument 1 must contain a user_id" 846 unless defined $userID; 847 848 $self->deleteUserSet($userID, undef); 849 $self->deletePassword($userID); 850 $self->deletePermissionLevel($userID); 851 $self->deleteKey($userID); 852 return $self->{user}->delete($userID); 853 } 854 855 =back 856 857 =cut 858 859 ################################################################################ 860 # set functions 861 ################################################################################ 862 863 =head2 Global Set Methods 864 865 FIXME: write this 866 867 =over 868 869 =cut 870 871 sub newGlobalSet { 872 my ($self, @prototype) = @_; 873 return $self->{set}->{record}->new(@prototype); 874 } 875 876 sub listGlobalSets { 877 my ($self) = @_; 878 879 croak "listGlobalSets: requires 0 arguments" 880 unless @_ == 1; 881 882 return map { $_->[0] } 883 $self->{set}->list(undef); 884 } 885 886 sub addGlobalSet { 887 my ($self, $GlobalSet) = @_; 888 889 croak "addGlobalSet: requires 1 argument" 890 unless @_ == 2; 891 croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record} 892 unless ref $GlobalSet eq $self->{set}->{record}; 893 894 checkKeyfields($GlobalSet); 895 896 croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)" 897 if $self->{set}->exists($GlobalSet->set_id); 898 899 return $self->{set}->add($GlobalSet); 900 } 901 902 sub getGlobalSet { 903 my ($self, $setID) = @_; 904 905 croak "getGlobalSet: requires 1 argument" 906 unless @_ == 2; 907 croak "getGlobalSet: argument 1 must contain a set_id" 908 unless defined $setID; 909 910 return $self->{set}->get($setID); 911 } 912 913 =item getGlobalSets(@setIDs) 914 915 Return a list of global set records associated with the record IDs given. If 916 there is no record associated with a given record ID, that element of the list 917 will be undefined. 918 919 =cut 920 921 sub getGlobalSets { 922 my ($self, @setIDs) = @_; 923 924 #croak "getGlobalSets: requires 1 or more argument" 925 # unless @_ >= 2; 926 foreach my $i (0 .. $#setIDs) { 927 croak "getGlobalSets: element $i of argument list must contain a set_id" 928 unless defined $setIDs[$i]; 929 } 930 931 return $self->{set}->gets(map { [$_] } @setIDs); 932 } 933 934 sub putGlobalSet { 935 my ($self, $GlobalSet) = @_; 936 937 croak "putGlobalSet: requires 1 argument" 938 unless @_ == 2; 939 croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record} 940 unless ref $GlobalSet eq $self->{set}->{record}; 941 942 checkKeyfields($GlobalSet); 943 944 croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)" 945 unless $self->{set}->exists($GlobalSet->set_id); 946 947 return $self->{set}->put($GlobalSet); 948 } 949 950 sub deleteGlobalSet { 951 my ($self, $setID) = @_; 952 953 croak "deleteGlobalSet: requires 1 argument" 954 unless @_ == 2; 955 croak "deleteGlobalSet: argument 1 must contain a set_id" 956 unless defined $setID or caller eq __PACKAGE__; 957 958 $self->deleteUserSet(undef, $setID); 959 $self->deleteGlobalProblem($setID, undef); 960 return $self->{set}->delete($setID); 961 } 962 963 =back 964 965 =cut 966 967 ################################################################################ 968 # set_user functions 969 ################################################################################ 970 971 =head2 User-Specific Set Methods 972 973 FIXME: write this 974 975 =over 976 977 =cut 978 979 sub newUserSet { 980 my ($self, @prototype) = @_; 981 return $self->{set_user}->{record}->new(@prototype); 982 } 983 984 sub listSetUsers { 985 my ($self, $setID) = @_; 986 987 croak "listSetUsers: requires 1 argument" 988 unless @_ == 2; 989 croak "listSetUsers: argument 1 must contain a set_id" 990 unless defined $setID; 991 992 return map { $_->[0] } # extract user_id 993 $self->{set_user}->list(undef, $setID); 994 } 995 996 sub listUserSets { 997 my ($self, $userID) = @_; 998 999 croak "listUserSets: requires 1 argument" 1000 unless @_ == 2; 1001 croak "listUserSets: argument 1 must contain a user_id" 1002 unless defined $userID; 1003 1004 return map { $_->[1] } # extract set_id 1005 $self->{set_user}->list($userID, undef); 1006 } 1007 1008 sub addUserSet { 1009 my ($self, $UserSet) = @_; 1010 1011 croak "addUserSet: requires 1 argument" 1012 unless @_ == 2; 1013 croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1014 unless ref $UserSet eq $self->{set_user}->{record}; 1015 1016 checkKeyfields($UserSet); 1017 1018 croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)" 1019 if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1020 croak "addUserSet: user ", $UserSet->user_id, " not found" 1021 unless $self->{user}->exists($UserSet->user_id); 1022 croak "addUserSet: set ", $UserSet->set_id, " not found" 1023 unless $self->{set}->exists($UserSet->set_id); 1024 1025 return $self->{set_user}->add($UserSet); 1026 } 1027 1028 sub getUserSet { 1029 my ($self, $userID, $setID) = @_; 1030 1031 croak "getUserSet: requires 2 arguments" 1032 unless @_ == 3; 1033 croak "getUserSet: argument 1 must contain a user_id" 1034 unless defined $userID; 1035 croak "getUserSet: argument 2 must contain a set_id" 1036 unless defined $setID; 1037 1038 #return $self->{set_user}->get($userID, $setID); 1039 return ( $self->getUserSets([$userID, $setID]) )[0]; 1040 } 1041 1042 =item getUserSets(@userSetIDs) 1043 1044 Return a list of user set records associated with the record IDs given. If there 1045 is no record associated with a given record ID, that element of the list will be 1046 undefined. @userProblemIDs consists of references to arrays in which the first 1047 element is the user_id and the second element is the set_id. 1048 1049 =cut 1050 1051 sub getUserSets { 1052 my ($self, @userSetIDs) = @_; 1053 1054 #croak "getUserSets: requires 1 or more argument" 1055 # unless @_ >= 2; 1056 foreach my $i (0 .. $#userSetIDs) { 1057 croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair" 1058 unless defined $userSetIDs[$i] 1059 and ref $userSetIDs[$i] eq "ARRAY" 1060 and @{$userSetIDs[$i]} == 2 1061 and defined $userSetIDs[$i]->[0] 1062 and defined $userSetIDs[$i]->[1]; 1063 } 1064 1065 return $self->{set_user}->gets(@userSetIDs); 1066 } 1067 1068 sub putUserSet { 1069 my ($self, $UserSet) = @_; 1070 1071 croak "putUserSet: requires 1 argument" 1072 unless @_ == 2; 1073 croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record} 1074 unless ref $UserSet eq $self->{set_user}->{record}; 1075 1076 checkKeyfields($UserSet); 1077 1078 croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)" 1079 unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id); 1080 croak "putUserSet: user ", $UserSet->user_id, " not found" 1081 unless $self->{user}->exists($UserSet->user_id); 1082 croak "putUserSet: set ", $UserSet->set_id, " not found" 1083 unless $self->{set}->exists($UserSet->set_id); 1084 1085 return $self->{set_user}->put($UserSet); 1086 } 1087 1088 sub deleteUserSet { 1089 my ($self, $userID, $setID) = @_; 1090 1091 croak "getUserSet: requires 2 arguments" 1092 unless @_ == 3; 1093 croak "getUserSet: argument 1 must contain a user_id" 1094 unless defined $userID or caller eq __PACKAGE__; 1095 croak "getUserSet: argument 2 must contain a set_id" 1096 unless defined $userID or caller eq __PACKAGE__; 1097 1098 $self->deleteUserProblem($userID, $setID, undef); 1099 return $self->{set_user}->delete($userID, $setID); 1100 } 1101 1102 =back 1103 1104 =cut 1105 1106 ################################################################################ 1107 # problem functions 1108 ################################################################################ 1109 1110 =head2 Global Problem Methods 1111 1112 FIXME: write this 1113 1114 =over 1115 1116 =cut 1117 1118 sub newGlobalProblem { 1119 my ($self, @prototype) = @_; 1120 return $self->{problem}->{record}->new(@prototype); 1121 } 1122 1123 sub listGlobalProblems { 1124 my ($self, $setID) = @_; 1125 1126 croak "listGlobalProblems: requires 1 arguments" 1127 unless @_ == 2; 1128 croak "listGlobalProblems: argument 1 must contain a set_id" 1129 unless defined $setID; 1130 1131 return map { $_->[1] } 1132 $self->{problem}->list($setID, undef); 1133 } 1134 1135 sub addGlobalProblem { 1136 my ($self, $GlobalProblem) = @_; 1137 1138 croak "addGlobalProblem: requires 1 argument" 1139 unless @_ == 2; 1140 croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1141 unless ref $GlobalProblem eq $self->{problem}->{record}; 1142 1143 checkKeyfields($GlobalProblem); 1144 1145 croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)" 1146 if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1147 croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1148 unless $self->{set}->exists($GlobalProblem->set_id); 1149 1150 return $self->{problem}->add($GlobalProblem); 1151 } 1152 1153 sub getGlobalProblem { 1154 my ($self, $setID, $problemID) = @_; 1155 1156 croak "getGlobalProblem: requires 2 arguments" 1157 unless @_ == 3; 1158 croak "getGlobalProblem: argument 1 must contain a set_id" 1159 unless defined $setID; 1160 croak "getGlobalProblem: argument 2 must contain a problem_id" 1161 unless defined $problemID; 1162 1163 return $self->{problem}->get($setID, $problemID); 1164 } 1165 1166 =item getGlobalProblems(@problemIDs) 1167 1168 Return a list of global set records associated with the record IDs given. If 1169 there is no record associated with a given record ID, that element of the list 1170 will be undefined. @problemIDs consists of references to arrays in which the 1171 first element is the set_id, and the second element is the problem_id. 1172 1173 =cut 1174 1175 sub getGlobalProblems { 1176 my ($self, @problemIDs) = @_; 1177 1178 #croak "getGlobalProblems: requires 1 or more argument" 1179 # unless @_ >= 2; 1180 foreach my $i (0 .. $#problemIDs) { 1181 croak "getUserSets: element $i of argument list must contain a <set_id, problem_id> pair" 1182 unless defined $problemIDs[$i] 1183 and ref $problemIDs[$i] eq "ARRAY" 1184 and @{$problemIDs[$i]} == 2 1185 and defined $problemIDs[$i]->[0] 1186 and defined $problemIDs[$i]->[1]; 1187 } 1188 1189 return $self->{problem}->gets(@problemIDs); 1190 } 1191 1192 sub putGlobalProblem { 1193 my ($self, $GlobalProblem) = @_; 1194 1195 croak "putGlobalProblem: requires 1 argument" 1196 unless @_ == 2; 1197 croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record} 1198 unless ref $GlobalProblem eq $self->{problem}->{record}; 1199 1200 checkKeyfields($GlobalProblem); 1201 1202 croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)" 1203 unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id); 1204 croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1205 unless $self->{set}->exists($GlobalProblem->set_id); 1206 1207 return $self->{problem}->put($GlobalProblem); 1208 } 1209 1210 sub deleteGlobalProblem { 1211 my ($self, $setID, $problemID) = @_; 1212 1213 croak "deleteGlobalProblem: requires 2 arguments" 1214 unless @_ == 3; 1215 croak "deleteGlobalProblem: argument 1 must contain a set_id" 1216 unless defined $setID or caller eq __PACKAGE__; 1217 croak "deleteGlobalProblem: argument 2 must contain a problem_id" 1218 unless defined $problemID or caller eq __PACKAGE__; 1219 1220 $self->deleteUserProblem(undef, $setID, $problemID); 1221 return $self->{problem}->delete($setID, $problemID); 1222 } 1223 1224 =back 1225 1226 =cut 1227 1228 ################################################################################ 1229 # problem_user functions 1230 ################################################################################ 1231 1232 =head2 User-Specific Problem Methods 1233 1234 FIXME: write this 1235 1236 =over 1237 1238 =cut 1239 1240 sub newUserProblem { 1241 my ($self, @prototype) = @_; 1242 return $self->{problem_user}->{record}->new(@prototype); 1243 } 1244 1245 sub listProblemUsers { 1246 my ($self, $setID, $problemID) = @_; 1247 1248 croak "listProblemUsers: requires 2 arguments" 1249 unless @_ == 3; 1250 croak "listProblemUsers: argument 1 must contain a set_id" 1251 unless defined $setID; 1252 croak "listProblemUsers: argument 2 must contain a problem_id" 1253 unless defined $problemID; 1254 1255 return map { $_->[0] } # extract user_id 1256 $self->{problem_user}->list(undef, $setID, $problemID); 1257 } 1258 1259 sub listUserProblems { 1260 my ($self, $userID, $setID) = @_; 1261 1262 croak "listUserProblems: requires 2 arguments" 1263 unless @_ == 3; 1264 croak "listUserProblems: argument 1 must contain a user_id" 1265 unless defined $userID; 1266 croak "listUserProblems: argument 2 must contain a set_id" 1267 unless defined $setID; 1268 1269 return map { $_->[2] } # extract problem_id 1270 $self->{problem_user}->list($userID, $setID, undef); 1271 } 1272 1273 sub addUserProblem { 1274 my ($self, $UserProblem) = @_; 1275 1276 croak "addUserProblem: requires 1 argument" 1277 unless @_ == 2; 1278 croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1279 unless ref $UserProblem eq $self->{problem_user}->{record}; 1280 1281 checkKeyfields($UserProblem); 1282 1283 croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)" 1284 if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1285 croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1286 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1287 croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1288 unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id); 1289 1290 return $self->{problem_user}->add($UserProblem); 1291 } 1292 1293 sub getUserProblem { 1294 my ($self, $userID, $setID, $problemID) = @_; 1295 1296 croak "getUserProblem: requires 3 arguments" 1297 unless @_ == 4; 1298 croak "getUserProblem: argument 1 must contain a user_id" 1299 unless defined $userID; 1300 croak "getUserProblem: argument 2 must contain a set_id" 1301 unless defined $setID; 1302 croak "getUserProblem: argument 3 must contain a problem_id" 1303 unless defined $problemID; 1304 1305 return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0]; 1306 } 1307 1308 =item getUserProblems(@userProblemIDs) 1309 1310 Return a list of user set records associated with the user IDs given. If there 1311 is no record associated with a given user ID, that element of the list will be 1312 undefined. @userProblemIDs consists of references to arrays in which the first 1313 element is the user_id, the second element is the set_id, and the third element 1314 is the problem_id. 1315 1316 =cut 1317 1318 sub getUserProblems { 1319 my ($self, @userProblemIDs) = @_; 1320 1321 #croak "getUserProblems: requires 1 or more argument" 1322 # unless @_ >= 2; 1323 foreach my $i (0 .. $#userProblemIDs) { 1324 croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1325 unless defined $userProblemIDs[$i] 1326 and ref $userProblemIDs[$i] eq "ARRAY" 1327 and @{$userProblemIDs[$i]} == 3 1328 and defined $userProblemIDs[$i]->[0] 1329 and defined $userProblemIDs[$i]->[1] 1330 and defined $userProblemIDs[$i]->[2]; 1331 } 1332 1333 return $self->{problem_user}->gets(@userProblemIDs); 1334 } 1335 1336 sub putUserProblem { 1337 my ($self, $UserProblem) = @_; 1338 1339 croak "putUserProblem: requires 1 argument" 1340 unless @_ == 2; 1341 croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record} 1342 unless ref $UserProblem eq $self->{problem_user}->{record}; 1343 1344 checkKeyfields($UserProblem); 1345 1346 croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1347 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1348 croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)" 1349 unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id); 1350 croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found" 1351 unless $self->{problem}->exists($UserProblem->set_id, $UserProblem->problem_id); 1352 1353 return $self->{problem_user}->put($UserProblem); 1354 } 1355 1356 sub deleteUserProblem { 1357 my ($self, $userID, $setID, $problemID) = @_; 1358 1359 croak "getUserProblem: requires 3 arguments" 1360 unless @_ == 4; 1361 croak "getUserProblem: argument 1 must contain a user_id" 1362 unless defined $userID or caller eq __PACKAGE__; 1363 croak "getUserProblem: argument 2 must contain a set_id" 1364 unless defined $setID or caller eq __PACKAGE__; 1365 croak "getUserProblem: argument 3 must contain a problem_id" 1366 unless defined $problemID or caller eq __PACKAGE__; 1367 1368 return $self->{problem_user}->delete($userID, $setID, $problemID); 1369 } 1370 1371 =back 1372 1373 =cut 1374 1375 ################################################################################ 1376 # set+set_user functions 1377 ################################################################################ 1378 1379 =head2 Set Merging Methods 1380 1381 These functions combine a global set and a user set to create a merged set, 1382 which is returned. Any field that is not defined in the user set is taken from 1383 the global set. Merged sets have the same type as user sets. 1384 1385 =over 1386 1387 =cut 1388 1389 sub getGlobalUserSet { 1390 carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead"; 1391 return shift->getMergedSet(@_); 1392 } 1393 1394 =item getMergedSet($userID, $setID) 1395 1396 Returns a merged set record associated with the record IDs given. If there is no 1397 record associated with a given record ID, the undefined value is returned. 1398 1399 =cut 1400 1401 sub getMergedSet { 1402 my ($self, $userID, $setID) = @_; 1403 1404 croak "getMergedSet: requires 2 arguments" 1405 unless @_ == 3; 1406 croak "getMergedSet: argument 1 must contain a user_id" 1407 unless defined $userID; 1408 croak "getMergedSet: argument 2 must contain a set_id" 1409 unless defined $setID; 1410 1411 return ( $self->getMergedSets([$userID, $setID]) )[0]; 1412 } 1413 1414 =item getMegedSets(@userSetIDs) 1415 1416 Return a list of merged set records associated with the record IDs given. If 1417 there is no record associated with a given record ID, that element of the list 1418 will be undefined. @userSetIDs consists of references to arrays in which the 1419 first element is the user_id and the second element is the set_id. 1420 1421 =cut 1422 1423 sub getMergedSets { 1424 my ($self, @userSetIDs) = @_; 1425 1426 #croak "getMergedSets: requires 1 or more argument" 1427 # unless @_ >= 2; 1428 foreach my $i (0 .. $#userSetIDs) { 1429 croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair" 1430 unless defined $userSetIDs[$i] 1431 and ref $userSetIDs[$i] eq "ARRAY" 1432 and @{$userSetIDs[$i]} == 2 1433 and defined $userSetIDs[$i]->[0] 1434 and defined $userSetIDs[$i]->[1]; 1435 } 1436 1437 # a horrible, terrible hack ;) 1438 if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash" 1439 and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") { 1440 #warn __PACKAGE__.": using a terrible hack.\n"; 1441 $WeBWorK::timer->continue("DB: getsNoFilter start") if defined($WeBWorK::timer); 1442 my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs); 1443 $WeBWorK::timer->continue("DB: getsNoFilter end") if defined($WeBWorK::timer); 1444 return @MergedSets; 1445 } 1446 1447 $WeBWorK::timer->continue("DB: getUserSets start") if defined($WeBWorK::timer); 1448 my @UserSets = $self->getUserSets(@userSetIDs); # checked 1449 1450 $WeBWorK::timer->continue("DB: pull out set IDs start") if defined($WeBWorK::timer); 1451 my @globalSetIDs = map { $_->[1] } @userSetIDs; 1452 $WeBWorK::timer->continue("DB: getGlobalSets start") if defined($WeBWorK::timer); 1453 my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked 1454 1455 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 1456 my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS; 1457 my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS; 1458 1459 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 1460 for (my $i = 0; $i < @UserSets; $i++) { 1461 my $UserSet = $UserSets[$i]; 1462 my $GlobalSet = $GlobalSets[$i]; 1463 next unless defined $UserSet and defined $GlobalSet; 1464 foreach my $field (@commonFields) { 1465 next if defined $UserSet->$field; 1466 $UserSet->$field($GlobalSet->$field); 1467 } 1468 } 1469 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 1470 1471 return @UserSets; 1472 } 1473 1474 =back 1475 1476 =cut 1477 1478 ################################################################################ 1479 # problem+problem_user functions 1480 ################################################################################ 1481 1482 =head2 Problem Merging Methods 1483 1484 These functions combine a global problem and a user problem to create a merged 1485 problem, which is returned. Any field that is not defined in the user problem is 1486 taken from the global problem. Merged problems have the same type as user 1487 problems. 1488 1489 =over 1490 1491 =cut 1492 1493 sub getGlobalUserProblem { 1494 carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead"; 1495 return shift->getMergedProblem(@_); 1496 } 1497 1498 =item getMergedProblem($userID, $setID, $problemID) 1499 1500 Returns a merged problem record associated with the record IDs given. If there 1501 is no record associated with a given record ID, the undefined value is returned. 1502 1503 =cut 1504 1505 sub getMergedProblem { 1506 my ($self, $userID, $setID, $problemID) = @_; 1507 1508 croak "getGlobalUserSet: requires 3 arguments" 1509 unless @_ == 4; 1510 croak "getGlobalUserSet: argument 1 must contain a user_id" 1511 unless defined $userID; 1512 croak "getGlobalUserSet: argument 2 must contain a set_id" 1513 unless defined $setID; 1514 croak "getGlobalUserSet: argument 3 must contain a problem_id" 1515 unless defined $problemID; 1516 1517 return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0]; 1518 } 1519 1520 =item getMergedProblems(@userProblemIDs) 1521 1522 Return a list of merged problem records associated with the record IDs given. If 1523 there is no record associated with a given record ID, that element of the list 1524 will be undefined. @userProblemIDs consists of references to arrays in which the 1525 first element is the user_id, the second element is the set_id, and the third 1526 element is the problem_id. 1527 1528 =cut 1529 1530 sub getMergedProblems { 1531 my ($self, @userProblemIDs) = @_; 1532 1533 #croak "getMergedProblems: requires 1 or more argument" 1534 # unless @_ >= 2; 1535 foreach my $i (0 .. $#userProblemIDs) { 1536 croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple" 1537 unless defined $userProblemIDs[$i] 1538 and ref $userProblemIDs[$i] eq "ARRAY" 1539 and @{$userProblemIDs[$i]} == 3 1540 and defined $userProblemIDs[$i]->[0] 1541 and defined $userProblemIDs[$i]->[1] 1542 and defined $userProblemIDs[$i]->[2]; 1543 } 1544 1545 $WeBWorK::timer->continue("DB: getUserProblems start") if defined($WeBWorK::timer); 1546 my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked 1547 1548 $WeBWorK::timer->continue("DB: pull out set/problem IDs start") if defined($WeBWorK::timer); 1549 my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs; 1550 $WeBWorK::timer->continue("DB: getGlobalProblems start") if defined($WeBWorK::timer); 1551 my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked 1552 1553 $WeBWorK::timer->continue("DB: calc common fields start") if defined($WeBWorK::timer); 1554 my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS; 1555 my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS; 1556 1557 $WeBWorK::timer->continue("DB: merge start") if defined($WeBWorK::timer); 1558 for (my $i = 0; $i < @UserProblems; $i++) { 1559 my $UserProblem = $UserProblems[$i]; 1560 my $GlobalProblem = $GlobalProblems[$i]; 1561 next unless defined $UserProblem and defined $GlobalProblem; 1562 foreach my $field (@commonFields) { 1563 next if defined $UserProblem->$field; 1564 $UserProblem->$field($GlobalProblem->$field); 1565 } 1566 } 1567 $WeBWorK::timer->continue("DB: merge done!") if defined($WeBWorK::timer); 1568 1569 return @UserProblems; 1570 } 1571 1572 =back 1573 1574 =cut 1575 1576 ################################################################################ 1577 # debugging 1578 ################################################################################ 1579 1580 #sub dumpDB($$) { 1581 # my ($self, $table) = @_; 1582 # return $self->{$table}->dumpDB(); 1583 #} 1584 1585 ################################################################################ 1586 # utilities 1587 ################################################################################ 1588 1589 sub checkKeyfields($) { 1590 my ($Record) = @_; 1591 foreach my $keyfield ($Record->KEYFIELDS) { 1592 my $value = $Record->$keyfield; 1593 croak "checkKeyfields: $keyfield is empty" 1594 unless defined $value and $value ne ""; 1595 1596 if ($keyfield eq "problem_id") { 1597 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])" 1598 unless $value =~ m/^\d*$/; 1599 } else { 1600 croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_])" 1601 unless $value =~ m/^[\w-]*$/; 1602 } 1603 } 1604 } 1605 1606 =head1 AUTHOR 1607 1608 Written by Sam Hathaway, sh002i (at) math.rochester.edu. 1609 1610 =cut 1611 1612 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |