Parent Directory
| 
Revision Log
fixes to coloring of answer blanks. merging work of Grant He on GatewayQuiz Grades and problem set presentation
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System> 3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/WeBWorK/DB.pm,v 1.111 2010/05/19 01:44:05 gage 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. 71 72 The schema modules provide an API that matches the requirements of the DB 73 layer, on a per-table basis. Each schema module has a style that determines 74 which drivers it can interface with. For example, SQL is an "dbi" style 75 schema. 76 77 =head2 Bottom Layer: Drivers 78 79 Driver modules implement a style for a schema. They provide physical access to 80 a data source containing the data for a table. The style of a driver determines 81 what methods it provides. All drivers provide C<connect(MODE)> and 82 C<disconnect()> methods. A dbi style driver provides a C<handle()> method which 83 returns the DBI handle. 84 85 =head2 Record Types 86 87 In C<%dblayout>, each table is assigned a record class, used for passing 88 complete records to and from the database. The default record classes are 89 subclasses of the WeBWorK::DB::Record class, and are named as follows: User, 90 Password, PermissionLevel, Key, Set, UserSet, Problem, UserProblem. In the 91 following documentation, a reference the the record class for a table means the 92 record class currently defined for that table in C<%dbLayout>. 93 94 =cut 95 96 use strict; 97 use warnings; 98 use Carp; 99 use Data::Dumper; 100 use Scalar::Util qw/blessed/; 101 use WeBWorK::DB::Schema; 102 use WeBWorK::DB::Utils qw/make_vsetID grok_vsetID grok_setID_from_vsetID_sql 103 grok_versionID_from_vsetID_sql/; 104 use WeBWorK::Debug; 105 use WeBWorK::Utils qw(runtime_use); 106 107 =for comment 108 109 These exceptions will replace the ones in WeBWorK::DB::Schema and will be 110 allowed to propagate out to calling code. The following callers will have to be 111 changed to catch these exceptions instead of doing string matching: 112 113 lib/WebworkSOAP.pm: if ($@ =~ m/user set exists/) { 114 lib/WeBWorK/ContentGenerator/Instructor.pm: if ($@ =~ m/user set exists/) { 115 lib/WeBWorK/ContentGenerator/Instructor.pm: if ( $@ =~ m/user set exists/ ) { 116 lib/WeBWorK/ContentGenerator/Instructor.pm: if ($@ =~ m/user problem exists/) { 117 lib/WeBWorK/ContentGenerator/Instructor.pm: if ($@ =~ m/user problem exists/) { 118 lib/WeBWorK/ContentGenerator/Instructor.pm: next if $@ =~ m/user set exists/; 119 lib/WeBWorK/Utils/DBImportExport.pm: if ($@ =~ m/exists/) { 120 lib/WeBWorK/DB.pm: if ($@ and $@ !~ m/password exists/) { 121 lib/WeBWorK/DB.pm: if ($@ and $@ !~ m/permission level exists/) { 122 123 How these exceptions should be used: 124 125 * RecordExists is thrown by the DBI error handler (handle_error in 126 Schema::NewSQL::Std) when in INSERT fails because a record exists. Thus it can 127 be thrown via addUser, addPassword, etc. 128 129 * RecordNotFound should be thrown when we try to UPDATE and zero rows were 130 affected. Problem: Frank Wolfs (UofR PAS) may have a MySQL server that returns 0 131 when updating even when a record was modified. What's up with that? There's some 132 question as to where we should throw this: in this file's put* methods? In 133 Std.pm's put method? Or in update_fields and update_fields_i? 134 135 * DependencyNotFound should be throws when we check for a record that is needed 136 to insert another record (e.g. password depends on user). These checks are done 137 in this file, so we'll throw this exception from there. 138 139 =cut 140 141 use Exception::Class ( 142 'WeBWorK::DB::Ex' => { 143 description => 'unknown database error', 144 }, 145 'WeBWorK::DB::Ex::RecordExists' => { 146 isa => 'WeBWorK::DB::Ex', 147 fields => ['type', 'key'], 148 description =>"record exists" 149 }, 150 'WeBWorK::DB::Ex::RecordNotFound' => { 151 isa => 'WeBWorK::DB::Ex', 152 fields => ['type', 'key'], 153 description =>"record not found" 154 }, 155 'WeBWorK::DB::Ex::DependencyNotFound' => { 156 isa => 'WeBWorK::DB::Ex::RecordNotFound', 157 }, 158 'WeBWorK::DB::Ex::TableMissing' => { 159 isa => 'WeBWorK::DB::Ex', 160 description =>"missing table", 161 }, 162 ); 163 164 ################################################################################ 165 # constructor 166 ################################################################################ 167 168 =head1 CONSTRUCTOR 169 170 =over 171 172 =item new($dbLayout) 173 174 The C<new> method creates a DB object and brings up the underlying schema/driver 175 structure according to the hash referenced by C<$dbLayout>. 176 177 =back 178 179 =head2 C<$dbLayout> Format 180 181 C<$dbLayout> is a hash reference consisting of items keyed by table names. The 182 value of each item is a reference to a hash containing the following items: 183 184 =over 185 186 =item record 187 188 The name of a perl module to use for representing the data in a record. 189 190 =item schema 191 192 The name of a perl module to use for access to the table. 193 194 =item driver 195 196 The name of a perl module to use for access to the data source. 197 198 =item source 199 200 The location of the data source that should be used by the driver module. 201 Depending on the driver, this may be a path, a url, or a DBI spec. 202 203 =item params 204 205 A reference to a hash containing extra information needed by the schema. Some 206 schemas require parameters, some do not. Consult the documentation for the 207 schema in question. 208 209 =back 210 211 For each table defined in C<$dbLayout>, C<new> loads the record, schema, and 212 driver modules. It the schema module's C<tables> method lists the current table 213 (or contains the string "*") and the output of the schema and driver modules' 214 C<style> methods match, the table is installed. Otherwise, an exception is 215 thrown. 216 217 =cut 218 219 sub new { 220 my ($invocant, $dbLayout) = @_; 221 my $class = ref($invocant) || $invocant; 222 my $self = {}; 223 bless $self, $class; # bless this here so we can pass it to the schema 224 225 # load the modules required to handle each table, and create driver 226 foreach my $table (keys %$dbLayout) { 227 $self->init_table($dbLayout, $table); 228 } 229 230 return $self; 231 } 232 233 sub init_table { 234 my ($self, $dbLayout, $table) = @_; 235 236 if (exists $self->{$table}) { 237 if (defined $self->{$table}) { 238 return; 239 } else { 240 die "loop in dbLayout table dependencies involving table '$table'\n"; 241 } 242 } 243 244 my $layout = $dbLayout->{$table}; 245 my $record = $layout->{record}; 246 my $schema = $layout->{schema}; 247 my $driver = $layout->{driver}; 248 my $source = $layout->{source}; 249 my $depend = $layout->{depend}; 250 my $params = $layout->{params}; 251 252 # add a key for this table to the self hash, but don't define it yet 253 # this for loop detection 254 $self->{$table} = undef; 255 256 if ($depend) { 257 foreach my $dep (@$depend) { 258 $self->init_table($dbLayout, $dep); 259 } 260 } 261 262 runtime_use($record); 263 264 runtime_use($driver); 265 my $driverObject = eval { $driver->new($source, $params) }; 266 croak "error instantiating DB driver $driver for table $table: $@" 267 if $@; 268 269 runtime_use($schema); 270 my $schemaObject = eval { $schema->new( 271 $self, $driverObject, $table, $record, $params) }; 272 croak "error instantiating DB schema $schema for table $table: $@" 273 if $@; 274 275 $self->{$table} = $schemaObject; 276 } 277 278 ################################################################################ 279 # methods that can be autogenerated 280 ################################################################################ 281 282 sub gen_schema_accessor { 283 my $schema = shift; 284 return sub { shift->{$schema} }; 285 } 286 287 sub gen_new { 288 my $table = shift; 289 return sub { shift->{$table}{record}->new(@_) }; 290 } 291 292 sub gen_count_where { 293 my $table = shift; 294 return sub { 295 my ($self, $where) = @_; 296 return $self->{$table}->count_where($where); 297 }; 298 } 299 300 sub gen_exists_where { 301 my $table = shift; 302 return sub { 303 my ($self, $where) = @_; 304 return $self->{$table}->exists_where($where); 305 }; 306 } 307 308 sub gen_list_where { 309 my $table = shift; 310 return sub { 311 my ($self, $where, $order) = @_; 312 if (wantarray) { 313 return $self->{$table}->list_where($where, $order); 314 } else { 315 return $self->{$table}->list_where_i($where, $order); 316 } 317 }; 318 } 319 320 sub gen_get_records_where { 321 my $table = shift; 322 return sub { 323 my ($self, $where, $order) = @_; 324 if (wantarray) { 325 return $self->{$table}->get_records_where($where, $order); 326 } else { 327 return $self->{$table}->get_records_where_i($where, $order); 328 } 329 }; 330 } 331 332 sub gen_insert_records { 333 my $table = shift; 334 return sub { 335 my ($self, @records) = @_; 336 if (@records == 1 and blessed $records[0] and $records[0]->isa("Iterator")) { 337 return $self->{$table}->insert_records_i($records[0]); 338 } else { 339 return $self->{$table}->insert_records(@records); 340 } 341 }; 342 } 343 344 sub gen_update_records { 345 my $table = shift; 346 return sub { 347 my ($self, @records) = @_; 348 if (@records == 1 and blessed $records[0] and $records[0]->isa("Iterator")) { 349 return $self->{$table}->update_records_i($records[0]); 350 } else { 351 return $self->{$table}->update_records(@records); 352 } 353 }; 354 } 355 356 sub gen_delete_where { 357 my $table = shift; 358 return sub { 359 my ($self, $where) = @_; 360 return $self->{$table}->delete_where($where); 361 }; 362 } 363 364 ################################################################################ 365 # create/rename/delete/dump/restore tables 366 ################################################################################ 367 368 sub create_tables { 369 my ($self) = @_; 370 371 foreach my $table (keys %$self) { 372 next if $table =~ /^_/; # skip non-table self fields (none yet) 373 next if $self->{$table}{params}{non_native}; # skip non-native tables 374 my $schema_obj = $self->{$table}; 375 if ($schema_obj->can("create_table")) { 376 $schema_obj->create_table; 377 } else { 378 warn "skipping creation of '$table' table: no create_table method\n"; 379 } 380 } 381 382 return 1; 383 } 384 385 sub rename_tables { 386 my ($self, $new_dblayout) = @_; 387 388 foreach my $table (keys %$self) { 389 next if $table =~ /^_/; # skip non-table self fields (none yet) 390 next if $self->{$table}{params}{non_native}; # skip non-native tables 391 my $schema_obj = $self->{$table}; 392 if (exists $new_dblayout->{$table}) { 393 if ($schema_obj->can("rename_table")) { 394 # we look into the new dblayout to determine the new table names 395 my $new_sql_table_name = defined $new_dblayout->{$table}{params}{tableOverride} 396 ? $new_dblayout->{$table}{params}{tableOverride} 397 : $table; 398 $schema_obj->rename_table($new_sql_table_name); 399 } else { 400 warn "skipping renaming of '$table' table: no rename_table method\n"; 401 } 402 } else { 403 warn "skipping renaming of '$table' table: table doesn't exist in new dbLayout\n"; 404 } 405 } 406 407 return 1; 408 } 409 410 sub delete_tables { 411 my ($self) = @_; 412 413 foreach my $table (keys %$self) { 414 next if $table =~ /^_/; # skip non-table self fields (none yet) 415 next if $self->{$table}{params}{non_native}; # skip non-native tables 416 my $schema_obj = $self->{$table}; 417 if ($schema_obj->can("delete_table")) { 418 $schema_obj->delete_table; 419 } else { 420 warn "skipping deletion of '$table' table: no delete_table method\n"; 421 } 422 } 423 424 return 1; 425 } 426 427 sub dump_tables { 428 my ($self, $dump_dir) = @_; 429 430 foreach my $table (keys %$self) { 431 next if $table =~ /^_/; # skip non-table self fields (none yet) 432 next if $self->{$table}{params}{non_native}; # skip non-native tables 433 my $schema_obj = $self->{$table}; 434 if ($schema_obj->can("dump_table")) { 435 my $dump_file = "$dump_dir/$table.sql"; 436 $schema_obj->dump_table($dump_file); 437 } else { 438 warn "skipping dump of '$table' table: no dump_table method\n"; 439 } 440 } 441 442 return 1; 443 } 444 445 sub restore_tables { 446 my ($self, $dump_dir) = @_; 447 448 foreach my $table (keys %$self) { 449 next if $table =~ /^_/; # skip non-table self fields (none yet) 450 next if $self->{$table}{params}{non_native}; # skip non-native tables 451 my $schema_obj = $self->{$table}; 452 if ($schema_obj->can("restore_table")) { 453 my $dump_file = "$dump_dir/$table.sql"; 454 $schema_obj->restore_table($dump_file); 455 } else { 456 warn "skipping restore of '$table' table: no restore_table method\n"; 457 } 458 } 459 460 return 1; 461 } 462 463 ################################################################################ 464 # user functions 465 ################################################################################ 466 467 BEGIN { 468 *User = gen_schema_accessor("user"); 469 *newUser = gen_new("user"); 470 *countUsersWhere = gen_count_where("user"); 471 *existsUserWhere = gen_exists_where("user"); 472 *listUsersWhere = gen_list_where("user"); 473 *getUsersWhere = gen_get_records_where("user"); 474 } 475 476 sub countUsers { return scalar shift->listUsers(@_) } 477 478 sub listUsers { 479 my ($self) = shift->checkArgs(\@_); 480 if (wantarray) { 481 return map { @$_ } $self->{user}->get_fields_where(["user_id"]); 482 } else { 483 return $self->{user}->count_where; 484 } 485 } 486 487 sub existsUser { 488 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 489 return $self->{user}->exists($userID); 490 } 491 492 sub getUser { 493 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 494 return ( $self->getUsers($userID) )[0]; 495 } 496 497 sub getUsers { 498 my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/); 499 return $self->{user}->gets(map { [$_] } @userIDs); 500 } 501 502 sub addUser { 503 my ($self, $User) = shift->checkArgs(\@_, qw/REC:user/); 504 eval { 505 return $self->{user}->add($User); 506 }; 507 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 508 croak "addUser: user exists (perhaps you meant to use putUser?)"; 509 } elsif ($@) { 510 die $@; 511 } 512 # FIXME about these exceptions: eventually the exceptions should be part of 513 # WeBWorK::DB rather than WeBWorK::DB::Schema, and we should just let them 514 # through to the calling code. however, right now we have code that checks 515 # for the string "... exists" in the error message, so we need to convert 516 # here. 517 # 518 # WeBWorK::DB::Ex::RecordExists 519 # WeBWorK::DB::Ex::DependencyNotFound - i.e. inserting a password for a nonexistent user 520 # ? 521 } 522 523 sub putUser { 524 my ($self, $User) = shift->checkArgs(\@_, qw/REC:user/); 525 my $rows = $self->{user}->put($User); # DBI returns 0E0 for 0. 526 if ($rows == 0) { 527 croak "putUser: user not found (perhaps you meant to use addUser?)"; 528 } else { 529 return $rows; 530 } 531 } 532 533 sub deleteUser { 534 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 535 $self->deleteUserSet($userID, undef); 536 $self->deletePassword($userID); 537 $self->deletePermissionLevel($userID); 538 $self->deleteKey($userID); 539 return $self->{user}->delete($userID); 540 } 541 542 ################################################################################ 543 # password functions 544 ################################################################################ 545 546 BEGIN { 547 *Password = gen_schema_accessor("password"); 548 *newPassword = gen_new("password"); 549 *countPasswordsWhere = gen_count_where("password"); 550 *existsPasswordWhere = gen_exists_where("password"); 551 *listPasswordsWhere = gen_list_where("password"); 552 *getPasswordsWhere = gen_get_records_where("password"); 553 } 554 555 sub countPasswords { return scalar shift->countPasswords(@_) } 556 557 sub listPasswords { 558 my ($self) = shift->checkArgs(\@_); 559 if (wantarray) { 560 return map { @$_ } $self->{password}->get_fields_where(["user_id"]); 561 } else { 562 return $self->{password}->count_where; 563 } 564 } 565 566 sub existsPassword { 567 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 568 # FIXME should we claim that a password exists if the user exists, since 569 # password records are auto-created? 570 return $self->{password}->exists($userID); 571 } 572 573 sub getPassword { 574 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 575 return ( $self->getPasswords($userID) )[0]; 576 } 577 578 sub getPasswords { 579 my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/); 580 581 my @Passwords = $self->{password}->gets(map { [$_] } @userIDs); 582 583 # AUTO-CREATE missing password records 584 # (this code is duplicated in getPermissionLevels, below) 585 for (my $i = 0; $i < @Passwords; $i++) { 586 my $Password = $Passwords[$i]; 587 my $userID = $userIDs[$i]; 588 if (not defined $Password) { 589 if ($self->{user}->exists($userID)) { 590 $Password = $self->newPassword(user_id => $userID); 591 eval { $self->addPassword($Password) }; 592 if ($@ and $@ !~ m/password exists/) { 593 die "error while auto-creating password record for user $userID: $@"; 594 } 595 $Passwords[$i] = $Password; 596 } 597 } 598 } 599 600 return @Passwords; 601 } 602 603 sub addPassword { 604 my ($self, $Password) = shift->checkArgs(\@_, qw/REC:password/); 605 606 croak "addPassword: user ", $Password->user_id, " not found" 607 unless $self->{user}->exists($Password->user_id); 608 609 eval { 610 return $self->{password}->add($Password); 611 }; 612 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 613 croak "addPassword: password exists (perhaps you meant to use putPassword?)"; 614 } elsif ($@) { 615 die $@; 616 } 617 } 618 619 sub putPassword { 620 my ($self, $Password) = shift->checkArgs(\@_, qw/REC:password/); 621 my $rows = $self->{password}->put($Password); # DBI returns 0E0 for 0. 622 if ($rows == 0) { 623 # AUTO-CREATE permission level records 624 return $self->addPassword($Password); 625 } else { 626 return $rows; 627 } 628 } 629 630 sub deletePassword { 631 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 632 return $self->{password}->delete($userID); 633 } 634 635 ################################################################################ 636 # permission functions 637 ################################################################################ 638 639 BEGIN { 640 *PermissionLevel = gen_schema_accessor("permission"); 641 *newPermissionLevel = gen_new("permission"); 642 *countPermissionLevelsWhere = gen_count_where("permission"); 643 *existsPermissionLevelWhere = gen_exists_where("permission"); 644 *listPermissionLevelsWhere = gen_list_where("permission"); 645 *getPermissionLevelsWhere = gen_get_records_where("permission"); 646 } 647 648 sub countPermissionLevels { return scalar shift->listPermissionLevels(@_) } 649 650 sub listPermissionLevels { 651 my ($self) = shift->checkArgs(\@_); 652 if (wantarray) { 653 return map { @$_ } $self->{permission}->get_fields_where(["user_id"]); 654 } else { 655 return $self->{permission}->count_where; 656 } 657 } 658 659 sub existsPermissionLevel { 660 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 661 # FIXME should we claim that a permission level exists if the user exists, 662 # since password records are auto-created? 663 return $self->{permission}->exists($userID); 664 } 665 666 sub getPermissionLevel { 667 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 668 return ( $self->getPermissionLevels($userID) )[0]; 669 } 670 671 sub getPermissionLevels { 672 my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/); 673 674 my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs); 675 676 # AUTO-CREATE missing permission level records 677 # (this code is duplicated in getPasswords, above) 678 for (my $i = 0; $i < @PermissionLevels; $i++) { 679 my $PermissionLevel = $PermissionLevels[$i]; 680 my $userID = $userIDs[$i]; 681 if (not defined $PermissionLevel) { 682 if ($self->{user}->exists($userID)) { 683 $PermissionLevel = $self->newPermissionLevel(user_id => $userID); 684 eval { $self->addPermissionLevel($PermissionLevel) }; 685 if ($@ and $@ !~ m/permission level exists/) { 686 die "error while auto-creating permission level record for user $userID: $@"; 687 } 688 $PermissionLevels[$i] = $PermissionLevel; 689 } 690 } 691 } 692 693 return @PermissionLevels; 694 } 695 696 sub addPermissionLevel { 697 my ($self, $PermissionLevel) = shift->checkArgs(\@_, qw/REC:permission/); 698 699 croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found" 700 unless $self->{user}->exists($PermissionLevel->user_id); 701 702 eval { 703 return $self->{permission}->add($PermissionLevel); 704 }; 705 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 706 croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)"; 707 } elsif ($@) { 708 die $@; 709 } 710 } 711 712 sub putPermissionLevel { 713 my ($self, $PermissionLevel) = shift->checkArgs(\@_, qw/REC:permission/); 714 my $rows = $self->{permission}->put($PermissionLevel); # DBI returns 0E0 for 0. 715 if ($rows == 0) { 716 # AUTO-CREATE permission level records 717 return $self->addPermissionLevel($PermissionLevel); 718 } else { 719 return $rows; 720 } 721 } 722 723 sub deletePermissionLevel { 724 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 725 return $self->{permission}->delete($userID); 726 } 727 728 ################################################################################ 729 # key functions 730 ################################################################################ 731 732 BEGIN { 733 *Key = gen_schema_accessor("key"); 734 *newKey = gen_new("key"); 735 *countKeysWhere = gen_count_where("key"); 736 *existsKeyWhere = gen_exists_where("key"); 737 *listKeysWhere = gen_list_where("key"); 738 *getKeysWhere = gen_get_records_where("key"); 739 } 740 741 sub countKeys { return scalar shift->listKeys(@_) } 742 743 sub listKeys { 744 my ($self) = shift->checkArgs(\@_); 745 if (wantarray) { 746 return map { @$_ } $self->{key}->get_fields_where(["user_id"]); 747 } else { 748 return $self->{key}->count_where; 749 } 750 } 751 752 sub existsKey { 753 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 754 return $self->{key}->exists($userID); 755 } 756 757 sub getKey { 758 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 759 return ( $self->getKeys($userID) )[0]; 760 } 761 762 sub getKeys { 763 my ($self, @userIDs) = shift->checkArgs(\@_, qw/user_id*/); 764 return $self->{key}->gets(map { [$_] } @userIDs); 765 } 766 767 sub addKey { 768 # PROCTORING - allow comma in keyfields 769 my ($self, $Key) = shift->checkArgs(\@_, qw/VREC:key/); 770 771 # PROCTORING - check for both user and proctor 772 # we allow for two entries for proctor keys, one of the form 773 # userid,proctorid (which authorizes login), and the other 774 # of the form userid,proctorid,g (which authorizes grading) 775 # (having two of these means that a proctored test will require 776 # authorization for both login and grading). 777 if ($Key->user_id =~ /([^,]+)(?:,([^,]*))?(,g)?/) { 778 my ($userID, $proctorID) = ($1, $2); 779 croak "addKey: user $userID not found" 780 unless $self->{user}->exists($userID); 781 croak "addKey: proctor $proctorID not found" 782 unless $self->{user}->exists($proctorID); 783 } else { 784 croak "addKey: user ", $Key->user_id, " not found" 785 unless $self->{user}->exists($Key->user_id); 786 } 787 788 eval { 789 return $self->{key}->add($Key); 790 }; 791 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 792 croak "addKey: key exists (perhaps you meant to use putKey?)"; 793 } elsif ($@) { 794 die $@; 795 } 796 } 797 798 sub putKey { 799 # PROCTORING - allow comma in keyfields 800 my ($self, $Key) = shift->checkArgs(\@_, qw/VREC:key/); 801 my $rows = $self->{key}->put($Key); # DBI returns 0E0 for 0. 802 if ($rows == 0) { 803 croak "putKey: key not found (perhaps you meant to use addKey?)"; 804 } else { 805 return $rows; 806 } 807 } 808 809 sub deleteKey { 810 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 811 return $self->{key}->delete($userID); 812 } 813 814 sub deleteAllProctorKeys { 815 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 816 my $where = [user_id_like => "$userID,%"]; 817 818 return $self->{key}->delete_where($where); 819 } 820 821 ################################################################################ 822 # setting functions 823 ################################################################################ 824 825 BEGIN { 826 *Setting = gen_schema_accessor("setting"); 827 *newSetting = gen_new("setting"); 828 *countSettingsWhere = gen_count_where("setting"); 829 *existsSettingWhere = gen_exists_where("setting"); 830 *listSettingsWhere = gen_list_where("setting"); 831 *getSettingsWhere = gen_get_records_where("setting"); 832 *addSettings = gen_insert_records("setting"); 833 *putSettings = gen_update_records("setting"); 834 *deleteSettingsWhere = gen_delete_where("setting"); 835 } 836 837 # minimal set of routines for basic setting operation 838 # we don't need a full set, since the usage of settings is somewhat limited 839 # we also don't want to bother with records, since a setting is just a pair 840 841 sub settingExists { 842 my ($self, $name) = @_; 843 return $self->{setting}->exists_where([name_eq=>$name]); 844 } 845 846 sub getSettingValue { 847 my ($self, $name) = @_; 848 return map { @$_ } $self->{setting}->get_fields_where(['value'], [name_eq=>$name]); 849 } 850 851 # we totally don't care if a setting already exists (and in fact i find that 852 # whole distinction somewhat annoying lately) so we hide the fact that we're 853 # either calling insert or update. at some point we could stand to add a 854 # method to Std.pm that used REPLACE INTO and then we'd be able to not care 855 # at all whether a setting was already there 856 sub setSettingValue { 857 my ($self, $name, $value) = @_; 858 if ($self->settingExists($name)) { 859 return $self->{setting}->update_where({value=>$value}, [name_eq=>$name]); 860 } else { 861 return $self->{setting}->insert_fields(['name','value'], [[$name,$value]]); 862 } 863 } 864 865 sub deleteSetting { 866 my ($self, $name) = shift->checkArgs(\@_, qw/name/); 867 return $self->{setting}->delete_where([name_eq=>$name]); 868 } 869 870 ################################################################################ 871 # locations functions 872 ################################################################################ 873 # this database table is for ip restrictions by assignment 874 # the locations table defines names of locations consisting of 875 # lists of ip masks (found in the location_addresses table) 876 # to which assignments can be restricted to or denied from. 877 878 BEGIN { 879 *Location = gen_schema_accessor("locations"); 880 *newLocation = gen_new("locations"); 881 *countLocationsWhere = gen_count_where("locations"); 882 *existsLocationWhere = gen_exists_where("locations"); 883 *listLocationsWhere = gen_list_where("locations"); 884 *getLocationsWhere = gen_get_records_where("locations"); 885 } 886 887 sub countLocations { return scalar shift->listLocations(@_) } 888 889 sub listLocations { 890 my ( $self ) = shift->checkArgs(\@_); 891 if ( wantarray ) { 892 return map {@$_} $self->{locations}->get_fields_where(["location_id"]); 893 } else { 894 return $self->{locations}->count_where; 895 } 896 } 897 898 sub existsLocation { 899 my ( $self, $locationID ) = shift->checkArgs(\@_, qw/location_id/); 900 return $self->{locations}->exists($locationID); 901 } 902 903 sub getLocation { 904 my ( $self, $locationID ) = shift->checkArgs(\@_, qw/location_id/); 905 return ( $self->getLocations($locationID) )[0]; 906 } 907 908 sub getLocations { 909 my ( $self, @locationIDs ) = shift->checkArgs(\@_, qw/location_id*/); 910 return $self->{locations}->gets(map {[$_]} @locationIDs); 911 } 912 913 sub getAllLocations { 914 my ( $self ) = shift->checkArgs(\@_); 915 return $self->{locations}->get_records_where(); 916 } 917 918 sub addLocation { 919 my ( $self, $Location ) = shift->checkArgs(\@_, qw/REC:locations/); 920 921 eval { 922 return $self->{locations}->add($Location); 923 }; 924 if ( my $ex = caught WeBWorK::DB::Ex::RecordExists ) { 925 croak "addLocation: location exists (perhaps you meant to use putLocation?)"; 926 } elsif ($@) { 927 die $@; 928 } 929 } 930 931 sub putLocation { 932 my ($self, $Location) = shift->checkArgs(\@_, qw/REC:locations/); 933 my $rows = $self->{locations}->put($Location); 934 if ( $rows == 0 ) { 935 croak "putLocation: location not found (perhaps you meant to use addLocation?)"; 936 } else { 937 return $rows; 938 } 939 } 940 941 sub deleteLocation { 942 # do we need to allow calls from this package? I can't think of 943 # any case where that would happen, but we include it for other 944 # deletions, so I'll keep it here. 945 my $U = caller eq __PACKAGE__ ? "!" : ""; 946 my ( $self, $locationID ) = shift->checkArgs(\@_, "location_id$U"); 947 $self->deleteGlobalSetLocation(undef, $locationID); 948 $self->deleteUserSetLocation(undef, undef, $locationID); 949 950 # NOTE: the one piece of this that we don't address is if this 951 # results in all of the locations in a set's restriction being 952 # cleared; in this case, we should probably also reset the 953 # set->restrict_ip setting as well. but that requires going 954 # out and doing a bunch of manipulations that well exceed what 955 # we want to do in this routine, so we'll assume that the user 956 # is smart enough to deal with that on her own. 957 958 # addresses in the location_addresses table also need to be cleared 959 $self->deleteLocationAddress($locationID, undef); 960 961 return $self->{locations}->delete($locationID); 962 } 963 964 ################################################################################ 965 # location_addresses functions 966 ################################################################################ 967 # this database table is for ip restrictions by assignment 968 # the location_addresses table defines the ipmasks associate 969 # with the locations that are used for restrictions. 970 971 BEGIN { 972 *LocationAddress = gen_schema_accessor("location_addresses"); 973 *newLocationAddress = gen_new("location_addresses"); 974 *countLocationAddressesWhere = gen_count_where("location_addresses"); 975 *existsLocationAddressWhere = gen_exists_where("location_addresses"); 976 *listLocationAddressesWhere = gen_list_where("location_addresses"); 977 *getLocationAddressesWhere = gen_get_records_where("location_addresses"); 978 } 979 980 sub countAddressLocations { return scalar shift->listAddressLocations(@_) } 981 982 sub listAddressLocations { 983 my ($self, $ipmask) = shift->checkArgs(\@_, qw/ip_mask/); 984 my $where = [ip_mask_eq => $ipmask]; 985 if ( wantarray ) { 986 return map {@$_} $self->{location_addresses}->get_fields_where(["location_id"],$where); 987 } else { 988 return $self->{location_addresses}->count_where($where); 989 } 990 } 991 992 sub countLocationAddresses { return scalar shift->listLocationAddresses(@_) } 993 994 sub listLocationAddresses { 995 my ($self, $locationID) = shift->checkArgs(\@_, qw/location_id/); 996 my $where = [location_id_eq => $locationID]; 997 if ( wantarray ) { 998 return map {@$_} $self->{location_addresses}->get_fields_where(["ip_mask"],$where); 999 } else { 1000 return $self->{location_addresses}->count_where($where); 1001 } 1002 } 1003 1004 sub existsLocationAddress { 1005 my ($self, $locationID, $ipmask) = shift->checkArgs(\@_, qw/location_id ip_mask/); 1006 return $self->{location_addresses}->exists($locationID, $ipmask); 1007 } 1008 1009 # we wouldn't ever getLocationAddress or getLocationAddresses; to use those 1010 # we would have to know all of the information that we're getting 1011 1012 sub getAllLocationAddresses { 1013 my ($self, $locationID) = shift->checkArgs(\@_, qw/location_id/); 1014 my $where = [location_id_eq => $locationID]; 1015 return $self->{location_addresses}->get_records_where($where); 1016 } 1017 1018 sub addLocationAddress { 1019 my ($self, $LocationAddress) = shift->checkArgs(\@_, qw/REC:location_addresses/); 1020 croak "addLocationAddress: location ", $LocationAddress->location_id, " not found" 1021 unless $self->{locations}->exists($LocationAddress->location_id); 1022 eval { 1023 return $self->{location_addresses}->add($LocationAddress); 1024 }; 1025 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1026 croak "addLocationAddress: location address exists (perhaps you meant to use putLocationAddress?)"; 1027 } elsif ($@) { 1028 die $@; 1029 } 1030 } 1031 1032 sub putLocationAddress { 1033 my ($self, $LocationAddress) = shift->checkArgs(\@_, qw/REC:location_addresses/); 1034 my $rows = $self->{location_addresses}->put($LocationAddress); 1035 if ( $rows == 0 ) { 1036 croak "putLocationAddress: location address not found (perhaps you meant to use addLocationAddress?)"; 1037 } else { 1038 return $rows; 1039 } 1040 } 1041 1042 sub deleteLocationAddress { 1043 # allow for undef values 1044 my $U = caller eq __PACKAGE__ ? "!" : ""; 1045 my ($self, $locationID, $ipmask) = shift->checkArgs(\@_, "location_id$U", "ip_mask$U"); 1046 return $self->{location_addresses}->delete($locationID, $ipmask); 1047 } 1048 1049 1050 ################################################################################ 1051 # set functions 1052 ################################################################################ 1053 1054 BEGIN { 1055 *GlobalSet = gen_schema_accessor("set"); 1056 *newGlobalSet = gen_new("set"); 1057 *countGlobalSetsWhere = gen_count_where("set"); 1058 *existsGlobalSetWhere = gen_exists_where("set"); 1059 *listGlobalSetsWhere = gen_list_where("set"); 1060 *getGlobalSetsWhere = gen_get_records_where("set"); 1061 } 1062 1063 sub countGlobalSets { return scalar shift->listGlobalSets(@_) } 1064 1065 sub listGlobalSets { 1066 my ($self) = shift->checkArgs(\@_); 1067 if (wantarray) { 1068 return map { @$_ } $self->{set}->get_fields_where(["set_id"]); 1069 } else { 1070 return $self->{set}->count_where; 1071 } 1072 } 1073 1074 sub existsGlobalSet { 1075 my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/); 1076 return $self->{set}->exists($setID); 1077 } 1078 1079 sub getGlobalSet { 1080 my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/); 1081 return ( $self->getGlobalSets($setID) )[0]; 1082 } 1083 1084 sub getGlobalSets { 1085 my ($self, @setIDs) = shift->checkArgs(\@_, qw/set_id*/); 1086 return $self->{set}->gets(map { [$_] } @setIDs); 1087 } 1088 1089 sub addGlobalSet { 1090 my ($self, $GlobalSet) = shift->checkArgs(\@_, qw/REC:set/); 1091 1092 eval { 1093 1094 return $self->{set}->add($GlobalSet); 1095 }; 1096 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1097 croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)"; 1098 } elsif ($@) { 1099 die $@; 1100 } 1101 } 1102 1103 sub putGlobalSet { 1104 my ($self, $GlobalSet) = shift->checkArgs(\@_, qw/REC:set/); 1105 my $rows = $self->{set}->put($GlobalSet); # DBI returns 0E0 for 0. 1106 if ($rows == 0) { 1107 croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)"; 1108 } else { 1109 return $rows; 1110 } 1111 } 1112 1113 sub deleteGlobalSet { 1114 # setID can be undefined if being called from this package 1115 my $U = caller eq __PACKAGE__ ? "!" : ""; 1116 my ($self, $setID) = shift->checkArgs(\@_, "set_id$U"); 1117 $self->deleteUserSet(undef, $setID); 1118 $self->deleteGlobalProblem($setID, undef); 1119 $self->deleteGlobalSetLocation($setID, undef); 1120 return $self->{set}->delete($setID); 1121 } 1122 1123 ################################################################################ 1124 # set_user functions 1125 ################################################################################ 1126 1127 BEGIN { 1128 *UserSet = gen_schema_accessor("set_user"); 1129 *newUserSet = gen_new("set_user"); 1130 *countUserSetsWhere = gen_count_where("set_user"); 1131 *existsUserSetWhere = gen_exists_where("set_user"); 1132 *listUserSetsWhere = gen_list_where("set_user"); 1133 *getUserSetsWhere = gen_get_records_where("set_user"); 1134 } 1135 1136 sub countSetUsers { return scalar shift->listSetUsers(@_) } 1137 1138 sub listSetUsers { 1139 my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/); 1140 my $where = [set_id_eq => $setID]; 1141 if (wantarray) { 1142 return map { @$_ } $self->{set_user}->get_fields_where(["user_id"], $where); 1143 } else { 1144 return $self->{set_user}->count_where($where); 1145 } 1146 } 1147 1148 sub countUserSets { return scalar shift->listUserSets(@_) } 1149 1150 sub listUserSets { 1151 my ($self, $userID) = shift->checkArgs(\@_, qw/user_id/); 1152 my $where = [user_id_eq => $userID]; 1153 if (wantarray) { 1154 return map { @$_ } $self->{set_user}->get_fields_where(["set_id"], $where); 1155 } else { 1156 return $self->{set_user}->count_where($where); 1157 } 1158 } 1159 1160 sub existsUserSet { 1161 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1162 return $self->{set_user}->exists($userID, $setID); 1163 } 1164 1165 sub getUserSet { 1166 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1167 return ( $self->getUserSets([$userID, $setID]) )[0]; 1168 } 1169 1170 sub getUserSets { 1171 my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id/); 1172 return $self->{set_user}->gets(@userSetIDs); 1173 } 1174 1175 # the code from addUserSet() is duplicated in large part following in 1176 # addVersionedUserSet; changes here should accordingly be propagated down there 1177 sub addUserSet { 1178 my ($self, $UserSet) = shift->checkArgs(\@_, qw/REC:set_user/); 1179 1180 croak "addUserSet: user ", $UserSet->user_id, " not found" 1181 unless $self->{user}->exists($UserSet->user_id); 1182 croak "addUserSet: set ", $UserSet->set_id, " not found" 1183 unless $self->{set}->exists($UserSet->set_id); 1184 1185 eval { 1186 return $self->{set_user}->add($UserSet); 1187 }; 1188 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1189 croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"; 1190 } elsif ($@) { 1191 die $@; 1192 } 1193 } 1194 1195 # the code from putUserSet() is duplicated in large part in the following 1196 # putVersionedUserSet; c.f. that routine 1197 sub putUserSet { 1198 my ($self, $UserSet) = shift->checkArgs(\@_, qw/REC:set_user/); 1199 my $rows = $self->{set_user}->put($UserSet); # DBI returns 0E0 for 0. 1200 if ($rows == 0) { 1201 croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)"; 1202 } else { 1203 return $rows; 1204 } 1205 } 1206 1207 sub deleteUserSet { 1208 # userID and setID can be undefined if being called from this package 1209 my $U = caller eq __PACKAGE__ ? "!" : ""; 1210 my ($self, $userID, $setID) = shift->checkArgs(\@_, "user_id$U", "set_id$U"); 1211 $self->deleteSetVersion($userID, $setID, undef); 1212 $self->deleteUserProblem($userID, $setID, undef); 1213 return $self->{set_user}->delete($userID, $setID); 1214 } 1215 1216 ################################################################################ 1217 # set_merged functions 1218 ################################################################################ 1219 1220 BEGIN { 1221 *MergedSet = gen_schema_accessor("set_merged"); 1222 #*newMergedSet = gen_new("set_merged"); 1223 #*countMergedSetsWhere = gen_count_where("set_merged"); 1224 *existsMergedSetWhere = gen_exists_where("set_merged"); 1225 #*listMergedSetsWhere = gen_list_where("set_merged"); 1226 *getMergedSetsWhere = gen_get_records_where("set_merged"); 1227 } 1228 1229 sub existsMergedSet { 1230 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1231 return $self->{set_merged}->exists($userID, $setID); 1232 } 1233 1234 sub getMergedSet { 1235 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1236 return ( $self->getMergedSets([$userID, $setID]) )[0]; 1237 } 1238 1239 sub getMergedSets { 1240 my ($self, @userSetIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id/); 1241 return $self->{set_merged}->gets(@userSetIDs); 1242 } 1243 1244 ################################################################################ 1245 # set_version functions (NEW) 1246 ################################################################################ 1247 1248 BEGIN { 1249 *SetVersion = gen_schema_accessor("set_version"); 1250 *newSetVersion = gen_new("set_version"); 1251 *countSetVersionsWhere = gen_count_where("set_version"); 1252 *existsSetVersionWhere = gen_exists_where("set_version"); 1253 *listSetVersionsWhere = gen_list_where("set_version"); 1254 *getSetVersionsWhere = gen_get_records_where("set_version"); 1255 } 1256 1257 # versioned analog of countUserSets 1258 sub countSetVersions { return scalar shift->listSetVersions(@_) } 1259 1260 # versioned analog of listUserSets 1261 sub listSetVersions { 1262 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1263 my $where = [user_id_eq_set_id_eq => $userID,$setID]; 1264 my $order = [ 'version_id' ]; 1265 if (wantarray) { 1266 return map { @$_ } $self->{set_version}->get_fields_where(["version_id"], $where, $order); 1267 } else { 1268 return $self->{set_version}->count_where($where); 1269 } 1270 } 1271 1272 # versioned analog of existsUserSet 1273 sub existsSetVersion { 1274 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1275 return $self->{set_version}->exists($userID, $setID, $versionID); 1276 } 1277 1278 # versioned analog of getUserSet 1279 sub getSetVersion { 1280 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1281 return ( $self->getSetVersions([$userID, $setID, $versionID]) )[0]; 1282 } 1283 1284 # versioned analog of getUserSets 1285 sub getSetVersions { 1286 my ($self, @setVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id/); 1287 return $self->{set_version}->gets(@setVersionIDs); 1288 } 1289 1290 # versioned analog of addUserSet 1291 sub addSetVersion { 1292 my ($self, $SetVersion) = shift->checkArgs(\@_, qw/REC:set_version/); 1293 1294 croak "addSetVersion: set ", $SetVersion->set_id, " not found for user ", $SetVersion->user_id 1295 unless $self->{set_user}->exists($SetVersion->user_id, $SetVersion->set_id); 1296 1297 eval { 1298 return $self->{set_version}->add($SetVersion); 1299 }; 1300 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1301 croak "addSetVersion: set version exists (perhaps you meant to use putSetVersion?)"; 1302 } elsif ($@) { 1303 die $@; 1304 } 1305 } 1306 1307 # versioned analog of putUserSet 1308 sub putSetVersion { 1309 my ($self, $SetVersion) = shift->checkArgs(\@_, qw/REC:set_version/); 1310 my $rows = $self->{set_version}->put($SetVersion); # DBI returns 0E0 for 0. 1311 if ($rows == 0) { 1312 croak "putSetVersion: set version not found (perhaps you meant to use addSetVersion?)"; 1313 } else { 1314 return $rows; 1315 } 1316 } 1317 1318 # versioned analog of deleteUserSet 1319 sub deleteSetVersion { 1320 # userID, setID, and versionID can be undefined if being called from this package 1321 my $U = caller eq __PACKAGE__ ? "!" : ""; 1322 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "version_id$U"); 1323 $self->deleteProblemVersion($userID, $setID, $versionID, undef); 1324 return $self->{set_version}->delete($userID, $setID, $versionID); 1325 } 1326 1327 ################################################################################ 1328 # set_version_merged functions (NEW) 1329 ################################################################################ 1330 1331 BEGIN { 1332 *MergedSetVersion = gen_schema_accessor("set_version_merged"); 1333 #*newMergedSetVersion = gen_new("set_version_merged"); 1334 #*countMergedSetVersionsWhere = gen_count_where("set_version_merged"); 1335 *existsMergedSetVersionWhere = gen_exists_where("set_version_merged"); 1336 #*listMergedSetVersionsWhere = gen_list_where("set_version_merged"); 1337 *getMergedSetVersionsWhere = gen_get_records_where("set_version_merged"); 1338 } 1339 1340 sub existsMergedSetVersion { 1341 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1342 return $self->{set_version_merged}->exists($userID, $setID, $versionID); 1343 } 1344 1345 sub getMergedSetVersion { 1346 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1347 return ( $self->getMergedSetVersions([$userID, $setID, $versionID]) )[0]; 1348 } 1349 1350 sub getMergedSetVersions { 1351 my ($self, @setVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id/); 1352 return $self->{set_version_merged}->gets(@setVersionIDs); 1353 } 1354 1355 ################################################################################ 1356 # set_locations functions 1357 ################################################################################ 1358 # this database table is for ip restrictions by assignment 1359 # the set_locations table defines the association between a 1360 # global set and the locations to which the set may be 1361 # restricted or denied. 1362 1363 BEGIN { 1364 *GlobalSetLocation = gen_schema_accessor("set_locations"); 1365 *newGlobalSetLocation = gen_new("set_locations"); 1366 *countGlobalSetLocationsWhere = gen_count_where("set_locations"); 1367 *existsGlobalSetLocationWhere = gen_exists_where("set_locations"); 1368 *listGlobalSetLocationsWhere = gen_list_where("set_locations"); 1369 *getGlobalSetLocationsWhere = gen_get_records_where("set_locations"); 1370 } 1371 1372 sub countGlobalSetLocations { return scalar shift->listGlobalSetLocations(@_) } 1373 1374 sub listGlobalSetLocations { 1375 my ( $self, $setID ) = shift->checkArgs(\@_, qw/set_id/); 1376 my $where = [set_id_eq => $setID]; 1377 if ( wantarray ) { 1378 my $order = ['location_id']; 1379 return map { @$_ } $self->{set_locations}->get_fields_where(["location_id"], $where, $order); 1380 } else { 1381 return $self->{set_user}->count_where( $where ); 1382 } 1383 } 1384 1385 sub existsGlobalSetLocation { 1386 my ( $self, $setID, $locationID ) = shift->checkArgs(\@_, qw/set_id location_id/); 1387 return $self->{set_locations}->exists( $setID, $locationID ); 1388 } 1389 1390 sub getGlobalSetLocation { 1391 my ( $self, $setID, $locationID ) = shift->checkArgs(\@_, qw/set_id location_id/); 1392 return ( $self->getGlobalSetLocations([$setID, $locationID]) )[0]; 1393 } 1394 1395 sub getGlobalSetLocations { 1396 my ( $self, @locationIDs ) = shift->checkArgsRefList(\@_, qw/set_id location_id/); 1397 return $self->{set_locations}->gets(@locationIDs); 1398 } 1399 1400 sub getAllGlobalSetLocations { 1401 my ( $self, $setID ) = shift->checkArgs(\@_, qw/set_id/); 1402 my $where = [set_id_eq => $setID]; 1403 return $self->{set_locations}->get_records_where( $where ); 1404 } 1405 1406 sub addGlobalSetLocation { 1407 my ( $self, $GlobalSetLocation ) = shift->checkArgs(\@_, qw/REC:set_locations/); 1408 croak "addGlobalSetLocation: set ", $GlobalSetLocation->set_id, " not found" 1409 unless $self->{set}->exists($GlobalSetLocation->set_id); 1410 1411 eval { 1412 return $self->{set_locations}->add($GlobalSetLocation); 1413 }; 1414 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1415 croak "addGlobalSetLocation: global set_location exists (perhaps you meant to use putGlobalSetLocation?)"; 1416 } elsif ($@) { 1417 die $@; 1418 } 1419 } 1420 1421 sub putGlobalSetLocation { 1422 my ($self, $GlobalSetLocation) = shift->checkArgs(\@_, qw/REC:set_locations/); 1423 my $rows = $self->{set_locations}->put($GlobalSetLocation); # DBI returns 0E0 for 0. 1424 if ($rows == 0) { 1425 croak "putGlobalSetLocation: global problem not found (perhaps you meant to use addGlobalSetLocation?)"; 1426 } else { 1427 return $rows; 1428 } 1429 } 1430 1431 sub deleteGlobalSetLocation { 1432 # setID and locationID can be undefined if being called from this package 1433 my $U = caller eq __PACKAGE__ ? "!" : ""; 1434 my ($self, $setID, $locationID) = shift->checkArgs(\@_, "set_id$U", "location_id$U"); 1435 $self->deleteUserSetLocation(undef, $setID, $locationID); 1436 return $self->{set_locations}->delete($setID, $locationID); 1437 } 1438 1439 ################################################################################ 1440 # set_locations_user functions 1441 ################################################################################ 1442 # this database table is for ip restrictions by assignment 1443 # the set_locations_user table defines the set_user level 1444 # modifications to the set_locations defined for the 1445 # global set 1446 1447 BEGIN { 1448 *UserSetLocation = gen_schema_accessor("set_locations_user"); 1449 *newUserSetLocation = gen_new("set_locations_user"); 1450 *countUserSetLocationWhere = gen_count_where("set_locations_user"); 1451 *existsUserSetLocationWhere = gen_exists_where("set_locations_user"); 1452 *listUserSetLocationsWhere = gen_list_where("set_locations_user"); 1453 *getUserSetLocationsWhere = gen_get_records_where("set_locations_user"); 1454 } 1455 1456 sub countSetLocationUsers { return scalar shift->listSetLocationUsers(@_) } 1457 1458 sub listSetLocationUsers { 1459 my ($self, $setID, $locationID) = shift->checkArgs(\@_, qw/set_id location_id/); 1460 my $where = [set_id_eq_location_id_eq => $setID,$locationID]; 1461 if (wantarray) { 1462 return map { @$_ } $self->{set_locations_user}->get_fields_where(["user_id"], $where); 1463 } else { 1464 return $self->{set_locations_user}->count_where($where); 1465 } 1466 } 1467 1468 sub countUserSetLocations { return scalar shift->listUserSetLocations(@_) } 1469 1470 sub listUserSetLocations { 1471 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1472 my $where = [user_id_eq_set_id_eq => $userID,$setID]; 1473 if (wantarray) { 1474 return map { @$_ } $self->{set_locations_user}->get_fields_where(["location_id"], $where); 1475 } else { 1476 return $self->{set_locations_user}->count_where($where); 1477 } 1478 } 1479 1480 sub existsUserSetLocation { 1481 my ($self, $userID, $setID, $locationID) = shift->checkArgs(\@_, qw/user_id set_id location_id/); 1482 return $self->{set_locations_user}->exists($userID,$setID,$locationID); 1483 } 1484 1485 # FIXME: we won't ever use this because all fields are key fields 1486 sub getUserSetLocation { 1487 my ($self, $userID, $setID, $locationID) = shift->checkArgs(\@_, qw/user_id set_id location_id/); 1488 return( $self->getUserSetLocations([$userID, $setID, $locationID]) )[0]; 1489 } 1490 1491 # FIXME: we won't ever use this because all fields are key fields 1492 sub getUserSetLocations { 1493 my ($self, @userSetLocationIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id location_id/); 1494 return $self->{set_locations_user}->gets(@userSetLocationIDs); 1495 } 1496 1497 sub getAllUserSetLocations { 1498 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1499 my $where = [user_id_eq_set_id_eq => $userID,$setID]; 1500 return $self->{set_locations_user}->get_records_where($where); 1501 } 1502 1503 sub addUserSetLocation { 1504 # VERSIONING - accept versioned ID fields 1505 my ($self, $UserSetLocation) = shift->checkArgs(\@_, qw/VREC:set_locations_user/); 1506 1507 croak "addUserSetLocation: user set ", $UserSetLocation->set_id, " for user ", $UserSetLocation->user_id, " not found" 1508 unless $self->{set_user}->exists($UserSetLocation->user_id, $UserSetLocation->set_id); 1509 1510 eval { 1511 return $self->{set_locations_user}->add($UserSetLocation); 1512 }; 1513 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1514 croak "addUserSetLocation: user set_location exists (perhaps you meant to use putUserSetLocation?)"; 1515 } elsif ($@) { 1516 die $@; 1517 } 1518 } 1519 1520 # FIXME: we won't ever use this because all fields are key fields 1521 # versioned_ok is an optional argument which lets us slip versioned setIDs through checkArgs. 1522 sub putUserSetLocation { 1523 my $V = $_[2] ? "V" : ""; 1524 my ($self, $UserSetLocation, undef) = shift->checkArgs(\@_, "${V}REC:set_locations_user", "versioned_ok!?"); 1525 1526 my $rows = $self->{set_locations_user}->put($UserSetLocation); # DBI returns 0E0 for 0. 1527 if ($rows == 0) { 1528 croak "putUserSetLocation: user set location not found (perhaps you meant to use addUserSetLocation?)"; 1529 } else { 1530 return $rows; 1531 } 1532 } 1533 1534 sub deleteUserSetLocation { 1535 # userID, setID, and locationID can be undefined if being called from this package 1536 my $U = caller eq __PACKAGE__ ? "!" : ""; 1537 my ($self, $userID, $setID, $locationID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "set_locations_id$U"); 1538 return $self->{set_locations_user}->delete($userID,$setID,$locationID); 1539 } 1540 1541 ################################################################################ 1542 # set_locations_merged functions 1543 ################################################################################ 1544 # this is different from other set_merged functions, because 1545 # in this case the only data that we have are the set_id, 1546 # location_id, and user_id, and we want to replace all 1547 # locations from GlobalSetLocations with those from 1548 # UserSetLocations if the latter exist. 1549 1550 sub getAllMergedSetLocations { 1551 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1552 1553 if ( $self->countUserSetLocations($userID, $setID) ) { 1554 return $self->getAllUserSetLocations( $userID, $setID ); 1555 } else { 1556 return $self->getAllGlobalSetLocations( $setID ); 1557 } 1558 } 1559 1560 1561 ################################################################################ 1562 # problem functions 1563 ################################################################################ 1564 1565 BEGIN { 1566 *GlobalProblem = gen_schema_accessor("problem"); 1567 *newGlobalProblem = gen_new("problem"); 1568 *countGlobalProblemsWhere = gen_count_where("problem"); 1569 *existsGlobalProblemWhere = gen_exists_where("problem"); 1570 *listGlobalProblemsWhere = gen_list_where("problem"); 1571 *getGlobalProblemsWhere = gen_get_records_where("problem"); 1572 } 1573 1574 sub countGlobalProblems { return scalar shift->listGlobalProblems(@_) } 1575 1576 sub listGlobalProblems { 1577 my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/); 1578 my $where = [set_id_eq => $setID]; 1579 if (wantarray) { 1580 return map { @$_ } $self->{problem}->get_fields_where(["problem_id"], $where); 1581 } else { 1582 return $self->{problem}->count_where($where); 1583 } 1584 } 1585 1586 sub existsGlobalProblem { 1587 my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/); 1588 return $self->{problem}->exists($setID, $problemID); 1589 } 1590 1591 sub getGlobalProblem { 1592 my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/); 1593 return ( $self->getGlobalProblems([$setID, $problemID]) )[0]; 1594 } 1595 1596 sub getGlobalProblems { 1597 my ($self, @problemIDs) = shift->checkArgsRefList(\@_, qw/set_id problem_id/); 1598 return $self->{problem}->gets(@problemIDs); 1599 } 1600 1601 sub getAllGlobalProblems { 1602 my ($self, $setID) = shift->checkArgs(\@_, qw/set_id/); 1603 my $where = [set_id_eq => $setID]; 1604 return $self->{problem}->get_records_where($where); 1605 } 1606 1607 sub addGlobalProblem { my ($self, $GlobalProblem) = shift->checkArgs(\@_, qw/REC:problem/); 1608 1609 croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found" 1610 unless $self->{set}->exists($GlobalProblem->set_id); 1611 1612 eval { 1613 return $self->{problem}->add($GlobalProblem); 1614 }; 1615 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1616 croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)"; 1617 } elsif ($@) { 1618 die $@; 1619 } 1620 } 1621 1622 sub putGlobalProblem { 1623 my ($self, $GlobalProblem) = shift->checkArgs(\@_, qw/REC:problem/); 1624 my $rows = $self->{problem}->put($GlobalProblem); # DBI returns 0E0 for 0. 1625 if ($rows == 0) { 1626 croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)"; 1627 } else { 1628 return $rows; 1629 } 1630 } 1631 1632 sub deleteGlobalProblem { 1633 # userID and setID can be undefined if being called from this package 1634 my $U = caller eq __PACKAGE__ ? "!" : ""; 1635 my ($self, $setID, $problemID) = shift->checkArgs(\@_, "set_id$U", "problem_id$U"); 1636 $self->deleteUserProblem(undef, $setID, $problemID); 1637 return $self->{problem}->delete($setID, $problemID); 1638 } 1639 1640 ################################################################################ 1641 # problem_user functions 1642 ################################################################################ 1643 1644 BEGIN { 1645 *UserProblem = gen_schema_accessor("problem_user"); 1646 *newUserProblem = gen_new("problem_user"); 1647 *countUserProblemsWhere = gen_count_where("problem_user"); 1648 *existsUserProblemWhere = gen_exists_where("problem_user"); 1649 *listUserProblemsWhere = gen_list_where("problem_user"); 1650 *getUserProblemsWhere = gen_get_records_where("problem_user"); 1651 } 1652 1653 sub countProblemUsers { return scalar shift->listProblemUsers(@_) } 1654 1655 sub listProblemUsers { 1656 my ($self, $setID, $problemID) = shift->checkArgs(\@_, qw/set_id problem_id/); 1657 my $where = [set_id_eq_problem_id_eq => $setID,$problemID]; 1658 if (wantarray) { 1659 return map { @$_ } $self->{problem_user}->get_fields_where(["user_id"], $where); 1660 } else { 1661 return $self->{problem_user}->count_where($where); 1662 } 1663 } 1664 1665 sub countUserProblems { return scalar shift->listUserProblems(@_) } 1666 1667 sub listUserProblems { 1668 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1669 my $where = [user_id_eq_set_id_eq => $userID,$setID]; 1670 if (wantarray) { 1671 return map { @$_ } $self->{problem_user}->get_fields_where(["problem_id"], $where); 1672 } else { 1673 return $self->{problem_user}->count_where($where); 1674 } 1675 } 1676 1677 sub existsUserProblem { 1678 my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/); 1679 return $self->{problem_user}->exists($userID, $setID, $problemID); 1680 } 1681 1682 sub getUserProblem { 1683 my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/); 1684 return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0]; 1685 } 1686 1687 sub getUserProblems { 1688 my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id problem_id/); 1689 return $self->{problem_user}->gets(@userProblemIDs); 1690 } 1691 1692 sub getAllUserProblems { 1693 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1694 my $where = [user_id_eq_set_id_eq => $userID,$setID]; 1695 return $self->{problem_user}->get_records_where($where); 1696 } 1697 1698 sub addUserProblem { 1699 # VERSIONING - accept versioned ID fields 1700 my ($self, $UserProblem) = shift->checkArgs(\@_, qw/VREC:problem_user/); 1701 1702 croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found" 1703 unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id); 1704 1705 my ( $nv_set_id, $versionNum ) = grok_vsetID( $UserProblem->set_id ); 1706 1707 croak "addUserProblem: problem ", $UserProblem->problem_id, " in set $nv_set_id not found" 1708 unless $self->{problem}->exists($nv_set_id, $UserProblem->problem_id); 1709 1710 eval { 1711 return $self->{problem_user}->add($UserProblem); 1712 }; 1713 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1714 croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)"; 1715 } elsif ($@) { 1716 die $@; 1717 } 1718 } 1719 1720 # versioned_ok is an optional argument which lets us slip versioned setIDs through checkArgs. 1721 sub putUserProblem { 1722 my $V = $_[2] ? "V" : ""; 1723 my ($self, $UserProblem, undef) = shift->checkArgs(\@_, "${V}REC:problem_user", "versioned_ok!?"); 1724 1725 my $rows = $self->{problem_user}->put($UserProblem); # DBI returns 0E0 for 0. 1726 if ($rows == 0) { 1727 croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)"; 1728 } else { 1729 return $rows; 1730 } 1731 } 1732 1733 sub deleteUserProblem { 1734 # userID, setID, and problemID can be undefined if being called from this package 1735 my $U = caller eq __PACKAGE__ ? "!" : ""; 1736 my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "problem_id$U"); 1737 return $self->{problem_user}->delete($userID, $setID, $problemID); 1738 } 1739 1740 ################################################################################ 1741 # problem_merged functions 1742 ################################################################################ 1743 1744 BEGIN { 1745 *MergedProblem = gen_schema_accessor("problem_merged"); 1746 #*newMergedProblem = gen_new("problem_merged"); 1747 #*countMergedProblemsWhere = gen_count_where("problem_merged"); 1748 *existsMergedProblemWhere = gen_exists_where("problem_merged"); 1749 #*listMergedProblemsWhere = gen_list_where("problem_merged"); 1750 *getMergedProblemsWhere = gen_get_records_where("problem_merged"); 1751 } 1752 1753 sub existsMergedProblem { 1754 my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/); 1755 return $self->{problem_merged}->exists($userID, $setID, $problemID); 1756 } 1757 1758 sub getMergedProblem { 1759 my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/); 1760 return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0]; 1761 } 1762 1763 sub getMergedProblems { 1764 my ($self, @userProblemIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id problem_id/); 1765 return $self->{problem_merged}->gets(@userProblemIDs); 1766 } 1767 1768 sub getAllMergedUserProblems { 1769 my ($self, $userID, $setID) = shift->checkArgs(\@_, qw/user_id set_id/); 1770 my $where = [user_id_eq_set_id_eq => $userID,$setID]; 1771 return $self->{problem_merged}->get_records_where($where); 1772 } 1773 1774 ################################################################################ 1775 # problem_version functions (NEW) 1776 ################################################################################ 1777 1778 BEGIN { 1779 *ProblemVersion = gen_schema_accessor("problem_version"); 1780 *newProblemVersion = gen_new("problem_version"); 1781 *countProblemVersionsWhere = gen_count_where("problem_version"); 1782 *existsProblemVersionWhere = gen_exists_where("problem_version"); 1783 *listProblemVersionsWhere = gen_list_where("problem_version"); 1784 *getProblemVersionsWhere = gen_get_records_where("problem_version"); 1785 } 1786 1787 # versioned analog of countUserProblems 1788 sub countProblemVersions { return scalar shift->listProblemVersions(@_) } 1789 1790 # versioned analog of listUserProblems 1791 sub listProblemVersions { 1792 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1793 my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID]; 1794 if (wantarray) { 1795 return map { @$_ } $self->{problem_version}->get_fields_where(["problem_id"], $where); 1796 } else { 1797 return $self->{problem_version}->count_where($where); 1798 } 1799 } 1800 1801 # this code returns a list of all problem versions with the given userID, 1802 # setID, and problemID, but that is (darn well ought to be) the same as 1803 # listSetVersions, so it's not so useful as all that; c.f. above. 1804 # sub listProblemVersions { 1805 # my ($self, $userID, $setID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id problem_id/); 1806 # my $where = [user_id_eq_set_id_eq_problem_id_eq => $userID,$setID,$problemID]; 1807 # if (wantarray) { 1808 # return grep { @$_ } $self->{problem_version}->get_fields_where(["version_id"], $where); 1809 # } else { 1810 # return $self->{problem_version}->count_where($where); 1811 # } 1812 # } 1813 1814 # versioned analog of existsUserProblem 1815 sub existsProblemVersion { 1816 my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/); 1817 return $self->{problem_version}->exists($userID, $setID, $versionID, $problemID); 1818 } 1819 1820 # versioned analog of getUserProblem 1821 sub getProblemVersion { 1822 my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/); 1823 return ( $self->getProblemVersions([$userID, $setID, $versionID, $problemID]) )[0]; 1824 } 1825 1826 # versioned analog of getUserProblems 1827 sub getProblemVersions { 1828 my ($self, @problemVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id problem_id/); 1829 return $self->{problem_version}->gets(@problemVersionIDs); 1830 } 1831 1832 # versioned analog of getAllUserProblems 1833 sub getAllProblemVersions { 1834 my ( $self, $userID, $setID, $versionID ) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1835 my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID]; 1836 my $order = ["problem_id"]; 1837 return $self->{problem_version_merged}->get_records_where($where,$order); 1838 } 1839 1840 1841 # versioned analog of addUserProblem 1842 sub addProblemVersion { 1843 my ($self, $ProblemVersion) = shift->checkArgs(\@_, qw/REC:problem_version/); 1844 1845 croak "addProblemVersion: set version ", $ProblemVersion->version_id, " of set ", $ProblemVersion->set_id, " not found for user ", $ProblemVersion->user_id 1846 unless $self->{set_version}->exists($ProblemVersion->user_id, $ProblemVersion->set_id, $ProblemVersion->version_id); 1847 croak "addProblemVersion: problem ", $ProblemVersion->problem_id, " of set ", $ProblemVersion->set_id, " not found for user ", $ProblemVersion->user_id 1848 unless $self->{problem_user}->exists($ProblemVersion->user_id, $ProblemVersion->set_id, $ProblemVersion->problem_id); 1849 1850 eval { 1851 return $self->{problem_version}->add($ProblemVersion); 1852 }; 1853 if (my $ex = caught WeBWorK::DB::Ex::RecordExists) { 1854 croak "addProblemVersion: problem version exists (perhaps you meant to use putProblemVersion?)"; 1855 } elsif ($@) { 1856 die $@; 1857 } 1858 } 1859 1860 # versioned analog of putUserProblem 1861 sub putProblemVersion { 1862 my ($self, $ProblemVersion) = shift->checkArgs(\@_, qw/REC:problem_version/); 1863 my $rows = $self->{problem_version}->put($ProblemVersion); # DBI returns 0E0 for 0. 1864 if ($rows == 0) { 1865 croak "putProblemVersion: problem version not found (perhaps you meant to use addProblemVersion?)"; 1866 } else { 1867 return $rows; 1868 } 1869 } 1870 1871 # versioned analog of deleteUserProblem 1872 sub deleteProblemVersion { 1873 # userID, setID, versionID, and problemID can be undefined if being called from this package 1874 my $U = caller eq __PACKAGE__ ? "!" : ""; 1875 my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, "user_id$U", "set_id$U", "version_id$U", "problem_id$U"); 1876 return $self->{problem_version}->delete($userID, $setID, $versionID, $problemID); 1877 } 1878 1879 ################################################################################ 1880 # problem_version_merged functions (NEW) 1881 ################################################################################ 1882 1883 BEGIN { 1884 *MergedProblemVersion = gen_schema_accessor("problem_version_merged"); 1885 #*newMergedProblemVersion = gen_new("problem_version_merged"); 1886 #*countMergedProblemVersionsWhere = gen_count_where("problem_version_merged"); 1887 *existsMergedProblemVersionWhere = gen_exists_where("problem_version_merged"); 1888 #*listMergedProblemVersionsWhere = gen_list_where("problem_version_merged"); 1889 *getMergedProblemVersionsWhere = gen_get_records_where("problem_version_merged"); 1890 } 1891 1892 sub existsMergedProblemVersion { 1893 my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/); 1894 return $self->{problem_version_merged}->exists($userID, $setID, $versionID, $problemID); 1895 } 1896 1897 sub getMergedProblemVersion { 1898 my ($self, $userID, $setID, $versionID, $problemID) = shift->checkArgs(\@_, qw/user_id set_id version_id problem_id/); 1899 return ( $self->getMergedProblemVersions([$userID, $setID, $versionID, $problemID]) )[0]; 1900 } 1901 1902 sub getMergedProblemVersions { 1903 my ($self, @problemVersionIDs) = shift->checkArgsRefList(\@_, qw/user_id set_id version_id problem_id/); 1904 return $self->{problem_version_merged}->gets(@problemVersionIDs); 1905 } 1906 1907 sub getAllMergedProblemVersions { 1908 my ($self, $userID, $setID, $versionID) = shift->checkArgs(\@_, qw/user_id set_id version_id/); 1909 my $where = [user_id_eq_set_id_eq_version_id_eq => $userID,$setID,$versionID]; 1910 my $order = ["problem_id"]; 1911 return $self->{problem_version_merged}->get_records_where($where,$order); 1912 } 1913 1914 ################################################################################ 1915 # utilities 1916 ################################################################################ 1917 1918 sub check_user_id { # (valid characters are [-a-zA-Z0-9_.,@]) 1919 my $value = shift; 1920 if ($value =~ m/^[-a-zA-Z0-9_.@]*,?(set_id:)?[-a-zA-Z0-9_.@]*(,g)?$/ ) { 1921 return 1; 1922 } else { 1923 croak "invalid characters in user_id field: '$value' (valid characters are [-a-zA-Z0-9_.,@])"; 1924 return 0; 1925 } 1926 } 1927 # the (optional) second argument to checkKeyfields is to support versioned 1928 # (gateway) sets, which may include commas in certain fields (in particular, 1929 # set names (e.g., setDerivativeGateway,v1) and user names (e.g., 1930 # username,proctorname) 1931 1932 sub checkKeyfields($;$) { 1933 my ($Record, $versioned) = @_; 1934 foreach my $keyfield ($Record->KEYFIELDS) { 1935 my $value = $Record->$keyfield; 1936 1937 croak "undefined '$keyfield' field" 1938 unless defined $value; 1939 croak "empty '$keyfield' field" 1940 unless $value ne ""; 1941 1942 if ($keyfield eq "problem_id") { 1943 croak "invalid characters in '$keyfield' field: '$value' (valid characters are [0-9])" 1944 unless $value =~ m/^[0-9]*$/; 1945 } elsif ($versioned and $keyfield eq "set_id") { 1946 croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-zA-Z0-9_.,])" 1947 unless $value =~ m/^[-a-zA-Z0-9_.,]*$/; 1948 # } elsif ($versioned and $keyfield eq "user_id") { 1949 } elsif ($keyfield eq "user_id") { 1950 check_user_id($value); # (valid characters are [-a-zA-Z0-9_.,]) see above. 1951 } elsif ($keyfield eq "ip_mask") { 1952 croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-fA-F0-9_.:/])" 1953 unless $value =~ m/^[-a-fA-F0-9_.:\/]*$/; 1954 1955 } else { 1956 croak "invalid characters in '$keyfield' field: '$value' (valid characters are [-a-zA-Z0-9_.])" 1957 unless $value =~ m/^[-a-zA-Z0-9_.]*$/; 1958 } 1959 } 1960 } 1961 1962 1963 # checkArgs spec syntax: 1964 # 1965 # spec = list_item | item* 1966 # list_item = item is_list 1967 # is_list = "*" 1968 # item = item_name undef_ok? optional? 1969 # item_name = record_item | bare_item 1970 # record_item = is_versioned? "REC:" table 1971 # is_versioned = "V" 1972 # table = \w+ 1973 # bare_item = \w+ 1974 # undef_ok = "!" 1975 # optional = "?" 1976 # 1977 # [[V]REC:]foo[!][?][*] 1978 1979 sub checkArgs { 1980 my ($self, $args, @spec) = @_; 1981 1982 my $is_list = @spec == 1 && $spec[0] =~ s/\*$//; 1983 my ($min_args, $max_args); 1984 if ($is_list) { 1985 $min_args = 0; 1986 } else { 1987 foreach my $i (0..$#spec) { 1988 #print "$i - $spec[$i]\n"; 1989 if ($spec[$i] =~ s/\?$//) { 1990 #print "$i - matched\n"; 1991 $min_args = $i unless defined $min_args; 1992 } 1993 } 1994 $min_args = @spec unless defined $min_args; 1995 $max_args = @spec; 1996 } 1997 1998 if (@$args < $min_args or defined $max_args and @$args > $max_args) { 1999 if ($min_args == $max_args) { 2000 my $s = $min_args == 1 ? "" : "s"; 2001 croak "requires $min_args argument$s"; 2002 } elsif (defined $max_args) { 2003 croak "requires between $min_args and $max_args arguments"; 2004 } else { 2005 my $s = $min_args == 1 ? "" : "s"; 2006 croak "requires at least $min_args argument$s"; 2007 } 2008 } 2009 2010 my ($name, $versioned, $table); 2011 if ($is_list) { 2012 $name = $spec[0]; 2013 ($versioned, $table) = $name =~ /^(V?)REC:(.*)/; 2014 } 2015 2016 foreach my $i (0..@$args-1) { 2017 my $arg = $args->[$i]; 2018 my $pos = $i+1; 2019 2020 unless ($is_list) { 2021 $name = $spec[$i]; 2022 ($versioned, $table) = $name =~ /^(V?)REC:(.*)/; 2023 } 2024 2025 if (defined $table) { 2026 my $class = $self->{$table}{record}; 2027 #print "arg=$arg class=$class\n"; 2028 croak "argument $pos must be of type $class" 2029 unless defined $arg and ref $arg and $arg->isa($class); 2030 eval { checkKeyfields($arg, $versioned) }; 2031 croak "argument $pos contains $@" if $@; 2032 } else { 2033 if ($name !~ /!$/) { 2034 croak "argument $pos must contain a $name" 2035 unless defined $arg; 2036 } 2037 } 2038 } 2039 2040 return $self, @$args; 2041 } 2042 2043 sub checkArgsRefList { 2044 my ($self, $items, @spec) = @_; 2045 foreach my $i (0..@$items-1) { 2046 my $item = $items->[$i]; 2047 my $pos = $i+1; 2048 croak "item $pos must be a reference to an array" 2049 unless UNIVERSAL::isa($item, "ARRAY"); 2050 eval { $self->checkArgs($item, @spec) }; 2051 croak "item $pos $@" if $@; 2052 } 2053 2054 return $self, @$items; 2055 } 2056 2057 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |