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