Annotation of /trunk/webwork-modperl/lib/WeBWorK/DB.pm

Revision 6288 - (view) (download) (as text)

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

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9