Annotation of /branches/rel-2-2-dev/webwork2/lib/WeBWorK/DB.pm

Revision 3485 - (view) (download) (as text)
Original Path: trunk/webwork2/lib/WeBWorK/DB.pm

1 :	sh002i	775	################################################################################
2 :	sh002i	1663	# WeBWorK Online Homework Delivery System
3 :			# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/
4 :	sh002i	3485	# $CVSHeader: webwork2/lib/WeBWorK/DB.pm,v 1.65 2005/07/22 22:48:28 jj 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 :			for a table. This includes odd things like the way multiple tables are encoded
71 :	sh002i	1012	in a single hash in the WW1Hash schema, and the encoding scheme used.
72 :	sh002i	956
73 :			The schema modules provide an API that matches the requirements of the DB
74 :			layer, on a per-table basis. Each schema module has a style that determines
75 :			which drivers it can interface with. For example, WW1Hash is a "hash" style
76 :			schema. SQL is a "dbi" style schema.
77 :
78 :			=head3 Examples
79 :
80 :			Both WeBWorK 1.x and 2.x courses use:
81 :
82 :			/ password permission key \ / user \ <- tables provided
83 :			+-----------------------------+ +----------------+
84 :			\| Auth1Hash \| \| Classlist1Hash \|
85 :			+-----------------------------+ +----------------+
86 :			\ hash / \ hash / <- driver style required
87 :
88 :			WeBWorK 1.x courses also use:
89 :
90 :			/ set_user problem_user \ / set problem \
91 :			+-------------------------+ +---------------------+
92 :			\| WW1Hash \| \| GlobalTableEmulator \|
93 :			+-------------------------+ +---------------------+
94 :			\ hash / \ null /
95 :
96 :			The GlobalTableEmulator schema emulates the global set and problem tables using
97 :			data from the set_user and problem_user tables.
98 :
99 :			WeBWorK 2.x courses also use:
100 :
101 :			/ set set_user problem problem_user \
102 :			+-------------------------------------+
103 :			\| WW2Hash \|
104 :			+-------------------------------------+
105 :			\ hash /
106 :
107 :			=head2 Bottom Layer: Drivers
108 :
109 :			Driver modules implement a style for a schema. They provide physical access to
110 :			a data source containing the data for a table. The style of a driver determines
111 :	sh002i	1012	what methods it provides. All drivers provide C<connect(MODE)> and
112 :			C<disconnect()> methods. A hash style driver provides a C<hash()> method which
113 :			returns the tied hash. A dbi style driver provides a C<handle()> method which
114 :			returns the DBI handle.
115 :	sh002i	956
116 :			=head3 Examples
117 :
118 :			/ hash \ / hash \ / hash \ <- style
119 :			+--------+ +--------+ +--------+
120 :			\| DB \| \| GDBM \| \| DB3 \|
121 :			+--------+ +--------+ +--------+
122 :
123 :			/ dbi \ / ldap \
124 :			+-------+ +--------+
125 :			\| SQL \| \| LDAP \|
126 :			+-------+ +--------+
127 :
128 :	sh002i	1012	=head2 Record Types
129 :
130 :			In C<%dblayout>, each table is assigned a record class, used for passing
131 :			complete records to and from the database. The default record classes are
132 :			subclasses of the WeBWorK::DB::Record class, and are named as follows: User,
133 :			Password, PermissionLevel, Key, Set, UserSet, Problem, UserProblem. In the
134 :			following documentation, a reference the the record class for a table means the
135 :			record class currently defined for that table in C<%dbLayout>.
136 :
137 :	sh002i	775	=cut
138 :
139 :			use strict;
140 :			use warnings;
141 :	sh002i	1096	use Carp;
142 :	sh002i	904	use Data::Dumper;
143 :	sh002i	3485	use WeBWorK::Debug;
144 :	sh002i	775	use WeBWorK::Utils qw(runtime_use);
145 :
146 :			################################################################################
147 :			# constructor
148 :			################################################################################
149 :
150 :	sh002i	956	=head1 CONSTRUCTOR
151 :	sh002i	1012
152 :	sh002i	956	=over
153 :
154 :	sh002i	2821	=item new($dbLayout)
155 :	sh002i	956
156 :	sh002i	2821	The C<new> method creates a DB object and brings up the underlying schema/driver
157 :			structure according to the hash referenced by C<$dbLayout>.
158 :	sh002i	1012
159 :			=back
160 :
161 :	sh002i	1696	=head2 C<$dbLayout> Format
162 :	sh002i	1108
163 :	sh002i	1696	C<$dbLayout> is a hash reference consisting of items keyed by table names. The
164 :			value of each item is a reference to a hash containing the following items:
165 :	sh002i	1108
166 :			=over
167 :
168 :			=item record
169 :
170 :			The name of a perl module to use for representing the data in a record.
171 :
172 :			=item schema
173 :
174 :			The name of a perl module to use for access to the table.
175 :
176 :			=item driver
177 :
178 :			The name of a perl module to use for access to the data source.
179 :
180 :			=item source
181 :
182 :			The location of the data source that should be used by the driver module.
183 :			Depending on the driver, this may be a path, a url, or a DBI spec.
184 :
185 :			=item params
186 :
187 :			A reference to a hash containing extra information needed by the schema. Some
188 :			schemas require parameters, some do not. Consult the documentation for the
189 :			schema in question.
190 :
191 :			=back
192 :
193 :	sh002i	1696	For each table defined in C<$dbLayout>, C<new> loads the record, schema, and
194 :	sh002i	1167	driver modules. It the schema module's C<tables> method lists the current table
195 :			(or contains the string "*") and the output of the schema and driver modules'
196 :			C<style> methods match, the table is installed. Otherwise, an exception is
197 :			thrown.
198 :
199 :	sh002i	956	=cut
200 :
201 :	sh002i	775	sub new($$) {
202 :	sh002i	1696	my ($invocant, $dbLayout) = @_;
203 :	sh002i	775	my $class = ref($invocant) \|\| $invocant;
204 :	sh002i	798	my $self = {};
205 :	sh002i	931	bless $self, $class; # bless this here so we can pass it to the schema
206 :	sh002i	775
207 :			# load the modules required to handle each table, and create driver
208 :	sh002i	1696	my %dbLayout = %$dbLayout;
209 :	sh002i	1167	foreach my $table (keys %dbLayout) {
210 :			my $layout = $dbLayout{$table};
211 :	sh002i	798	my $record = $layout->{record};
212 :	sh002i	775	my $schema = $layout->{schema};
213 :			my $driver = $layout->{driver};
214 :			my $source = $layout->{source};
215 :	sh002i	808	my $params = $layout->{params};
216 :	sh002i	775
217 :	sh002i	798	runtime_use($record);
218 :	sh002i	1096
219 :			runtime_use($driver);
220 :			my $driverObject = eval { $driver->new($source, $params) };
221 :	sh002i	1167	croak "error instantiating DB driver $driver for table $table: $@"
222 :	sh002i	1096	if $@;
223 :
224 :	sh002i	798	runtime_use($schema);
225 :	sh002i	1096	my $schemaObject = eval { $schema->new(
226 :	sh002i	1681	$self, $driverObject, $table, $record, $params) };
227 :	sh002i	1167	croak "error instantiating DB schema $schema for table $table: $@"
228 :	sh002i	1096	if $@;
229 :
230 :			$self->{$table} = $schemaObject;
231 :	sh002i	775	}
232 :
233 :			return $self;
234 :			}
235 :
236 :	sh002i	1012	=head1 METHODS
237 :
238 :			=cut
239 :
240 :	sh002i	775	################################################################################
241 :	sh002i	2312	# general functions
242 :			################################################################################
243 :
244 :			=head2 General Methods
245 :
246 :			=over
247 :
248 :			=cut
249 :
250 :			=item hashDatabaseOK($fix)
251 :
252 :			If the schema module in use for the C<set> and C<problem> tables is
253 :			WeBWorK::DB::Schema::GlobalTableEmulator, the database is checked to make sure
254 :			that the "global user" exists and all sets and problems are assigned to it. If
255 :			$fix is true, problems found will be fixed: A global user will be created and
256 :			all sets/problems assigned to it.
257 :
258 :			A list of values is returned. The first value is a boolean value indicating
259 :			whether problems remain in the database after hashDatabaseOK() is called. The
260 :			remaining values are a list of strings indicating the particular ways in which
261 :			the database is (or was) broken.
262 :
263 :			=cut
264 :
265 :			sub hashDatabaseOK {
266 :			my ($self, $fix) = @_;
267 :
268 :			my $errorsExist;
269 :			my @results;
270 :
271 :			##### do we need to run? #####
272 :
273 :			unless (ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
274 :			#warn "hashDatabaseOK($fix): no checks necessary, set table does not use GlobalTableEmulator.\n";
275 :			return 1;
276 :			}
277 :
278 :			##### is globalUserID defined? #####
279 :
280 :			my $globalUserID = $self->{set}->{params}->{globalUserID};
281 :			if ($globalUserID eq "") {
282 :			return 0, "globalUserID not specified (fix this in %dbLayout.)";
283 :			} else {
284 :			#warn "hashDatabaseOK($fix): globalUserID not empty ($globalUserID) -- good.\n";
285 :			}
286 :
287 :			##### does a user with ID globalUserID exist? #####
288 :
289 :			my $GlobalUser = $self->getUser($globalUserID);
290 :			if (defined $GlobalUser) {
291 :			#warn "hashDatabaseOK($fix): user with ID '$globalUserID' exists -- good.\n";
292 :			} else {
293 :			#warn "hashDatabaseOK($fix): user with ID '$globalUserID' not found -- bad!\n";
294 :			if ($fix) {
295 :			$self->addUser($self->newUser(
296 :			user_id => $globalUserID,
297 :			first_name => "Global",
298 :			last_name => "User",
299 :			email_address => "",
300 :			student_id => $globalUserID,
301 :			status => "D",
302 :			section => "",
303 :			recitation => "",
304 :			comment => "This user is used to store data about global set and problem records when using a hash-style database.",
305 :			));
306 :			push @results, "User $globalUserID does not exist -- FIXED.";
307 :			#warn "hashDatabaseOK($fix): created user with ID '$globalUserID' -- good.\n";
308 :			} else {
309 :			# at this point, we don't go on. no global user means everything below is going to fail.
310 :			return 0, "User $globalUserID does not exist.";
311 :			}
312 :			}
313 :
314 :			##### are all sets assigned to the user with ID globalUserID? #####
315 :
316 :	sh002i	2348	# FIXME: this is way too slow!
317 :			#my @userSetIDs = $self->{set_user}->list(undef, undef);
318 :	sh002i	2312
319 :	sh002i	2348	# Timing Data
320 :			#
321 :			# old method:
322 :			# TIMING 36119 1 1087502726.923311 (0.139117) mth143: WeBWorK::DB::hashDatabaseOK: about to get orphaned UserSets
323 :			# TIMING 36119 1 1087502768.074221 (41.290027) mth143: WeBWorK::DB::hashDatabaseOK: done getting orphaned UserSets
324 :			#
325 :			# new method:
326 :			# TIMING 36134 0 1087502854.579133 (0.141437) mth143: WeBWorK::DB::hashDatabaseOK: about to get orphaned UserSets
327 :			# TIMING 36134 0 1087502856.852504 (2.414808) mth143: WeBWorK::DB::hashDatabaseOK: done getting orphaned UserSets
328 :			#
329 :			# yay!
330 :	sh002i	2312
331 :	sh002i	3485	debug(__PACKAGE__ . "::hashDatabaseOK: about to get orphaned UserSets");
332 :	sh002i	2348
333 :			# ... so instead, we're going to do things manually
334 :
335 :			# key: setID, value: hash of userIDs of users to whom this set is assigned
336 :			my %orphanUserSets;
337 :
338 :			if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash") {
339 :			# we can only do this with WW1Hash
340 :			#warn "the fast way!\n";
341 :
342 :			# connect
343 :			$self->{set_user}->{driver}->connect("ro")
344 :			or return 0, @results, "Failed to connect to set_user database.";
345 :
346 :	gage	3284
347 :	sh002i	3485	# get PSVNs for global user (ÔN)
348 :	sh002i	2864	# this reads from "login<>global_user"
349 :	sh002i	2348	my @globalUserPSVNs = $self->{set_user}->getPSVNsForUser($globalUserID);
350 :			#warn "found ", scalar @globalUserPSVNs, " PSVNs for the global user.\n";
351 :
352 :			# get setIDs for PSVNs (M)
353 :			my @globalUserSetIDs;
354 :			foreach my $PSVN (@globalUserPSVNs) {
355 :			#warn "getting setID for PSVN '$PSVN'...\n";
356 :			my $string = $self->{set_user}->fetchString($PSVN);
357 :			my (undef, $setID) = $self->{set_user}->string2IDs($string); # discard userID, problemIDs
358 :			push @globalUserSetIDs, $setID;
359 :			#warn "got setID '$setID'\n";
360 :			}
361 :
362 :	gage	3284
363 :	sh002i	3485	# get PSVNs for each setID (ÔN*M)
364 :	sh002i	2864	# this reads from "set<>$_"
365 :	sh002i	2348	my @okPSVNs = map { $self->{set_user}->getPSVNsForSet($_) } @globalUserSetIDs;
366 :			#warn "found ", scalar @okPSVNs, " PSVNs for sets assigned to the global user.\n";
367 :
368 :			# get all PSVNs (N*M)
369 :	sh002i	2864	# uses: grep { m/^\d+$/ } keys %{ $self->{driver}->hash() }
370 :	sh002i	2348	my @allPSVNs = $self->{set_user}->getAllPSVNs;
371 :			#warn "found ", scalar @allPSVNs, " PSVNs total.\n";
372 :
373 :			# eliminate PSVNs of sets that are assigned to the global user
374 :			my %allPSVNs;
375 :			@allPSVNs{@allPSVNs} = ();
376 :
377 :			foreach my $PSVN (@okPSVNs) {
378 :			delete $allPSVNs{$PSVN};
379 :			}
380 :
381 :	sh002i	2864	#warn "the orphan PSVNs are: ", join(", ", keys %allPSVNs), "\n";
382 :
383 :	sh002i	2348	# get setIDs for orphan PSVNs
384 :			foreach my $PSVN (keys %allPSVNs) {
385 :			#warn "getting userID and setID for PSVN '$PSVN'...\n";
386 :			my $string = $self->{set_user}->fetchString($PSVN);
387 :			my ($userID, $setID) = $self->{set_user}->string2IDs($string);
388 :			$orphanUserSets{$setID}->{$userID} = 1;
389 :			#warn "got setID '$setID' for userID '$userID'\n";
390 :			}
391 :
392 :			# disconnect
393 :			$self->{set_user}->{driver}->disconnect;
394 :			} else {
395 :			# otherwise, do it the slow way (maybe it's not slow with some other schema?)
396 :			#warn "oddly enough, set_user isn't using WW1Hash, so we have to use the slow list() method";
397 :			my @userSetIDs = $self->{set_user}->list(undef, undef);
398 :
399 :			foreach my $userSetID (@userSetIDs) {
400 :			my ($userID, $setID) = @$userSetID;
401 :			$orphanUserSets{$setID}->{$userID} = 1;
402 :			}
403 :
404 :			foreach my $setID (keys %orphanUserSets) {
405 :			delete $orphanUserSets{$setID}
406 :			if exists $orphanUserSets{$setID}->{$globalUserID};
407 :			}
408 :	sh002i	2312	}
409 :
410 :	sh002i	3485	debug(__PACKAGE__ . "::hashDatabaseOK: done getting orphaned UserSets");
411 :	sh002i	2348
412 :			if (keys %orphanUserSets) {
413 :	sh002i	2864	foreach my $setID (keys %orphanUserSets) {
414 :			# detect "false positives" -- sets that are assigned to the global user
415 :			# but for some reason don't appear in any set index.
416 :			if ($self->{set_user}->exists($globalUserID, $setID)) {
417 :			my @userIDs = keys %{$orphanUserSets{$setID}};
418 :			warn "Set ID '$setID' for users '@userIDs' do not appear in any set index. Index re-build recommended.\n";
419 :			push @results, "Set ID '$setID' for users '@userIDs' do not appear in any set index. Index re-build recommended.\n";
420 :			} else {
421 :			if ($fix) {
422 :			my ($userID) = keys %{$orphanUserSets{$setID}};
423 :
424 :			# grab the first UserSet of this set (connect and disconnect required for get1*)
425 :			$self->{set_user}->{driver}->connect("ro")
426 :			or return 0, @results, "Failed to connect to set_user database.";
427 :			my $RawUserSet = $self->{set_user}->get1NoFilter($userID, $setID);
428 :			my @RawUserProblems = $self->{problem_user}->getAllNoFilter($userID, $setID);
429 :			$self->{set_user}->{driver}->disconnect();
430 :			unless ($RawUserSet) {
431 :			warn "failed to fetch UserSet '$setID' for user '$userID'!\n";
432 :			next;
433 :			}
434 :
435 :			# change user ID to globalUserID and add to database
436 :			$RawUserSet->user_id($globalUserID);
437 :			$self->{set_user}->add($RawUserSet);
438 :			foreach my $RawUserProblem (@RawUserProblems) {
439 :			$RawUserProblem->user_id($globalUserID);
440 :			$self->{problem_user}->add($RawUserProblem);
441 :			#warn "hashDatabaseOK($fix): assigned problem '", $RawUserProblem->problem_id, "' from set '$setID' to global user '$globalUserID' -- good.\n";
442 :			}
443 :
444 :			#warn "hashDatabaseOK($fix): assigned set '$setID' to global user '$globalUserID' -- good.\n";
445 :			push @results, "Set '$setID' not assigned to global user '$globalUserID' -- FIXED.";
446 :			} else {
447 :			#warn "hashDatabaseOK($fix): set '$setID' not assigned to global user '$globalUserID' -- bad!\n";
448 :			push @results, "Set '$setID' not assigned to global user '$globalUserID'.";
449 :	sh002i	2348	}
450 :	sh002i	2312	}
451 :			}
452 :			} else {
453 :			#warn "hashDatabaseOK($fix): all sets assigned to global user '$globalUserID' -- good.\n";
454 :			}
455 :
456 :			##### done! #####
457 :
458 :			my $status = not $errorsExist;
459 :			return $status, @results;
460 :			}
461 :
462 :			=back
463 :
464 :			=cut
465 :
466 :			################################################################################
467 :	sh002i	775	# password functions
468 :			################################################################################
469 :
470 :	sh002i	1012	=head2 Password Methods
471 :
472 :			=over
473 :
474 :	sh002i	1201	=item newPassword()
475 :
476 :			Returns a new, empty password object.
477 :
478 :			=cut
479 :
480 :			sub newPassword {
481 :	sh002i	1635	my ($self, @prototype) = @_;
482 :			return $self->{password}->{record}->new(@prototype);
483 :	sh002i	1201	}
484 :
485 :	sh002i	1012	=item listPasswords()
486 :
487 :			Returns a list of user IDs representing the records in the password table.
488 :
489 :			=cut
490 :
491 :	sh002i	1096	sub listPasswords {
492 :	sh002i	775	my ($self) = @_;
493 :	sh002i	1096
494 :			croak "listPasswords: requires 0 arguments"
495 :			unless @_ == 1;
496 :
497 :	sh002i	808	return map { $_->[0] }
498 :			$self->{password}->list(undef);
499 :	sh002i	775	}
500 :
501 :	sh002i	1012	=item addPassword($Password)
502 :
503 :			$Password is a record object. The password will be added to the password table
504 :			if a password with the same user ID does not already exist. If one does exist,
505 :			an exception is thrown. To add a password, a user with a matching user ID must
506 :			exist in the user table.
507 :
508 :			=cut
509 :
510 :	sh002i	1512	sub addPassword {
511 :	sh002i	775	my ($self, $Password) = @_;
512 :	sh002i	1096
513 :			croak "addPassword: requires 1 argument"
514 :			unless @_ == 2;
515 :			croak "addPassword: argument 1 must be of type ", $self->{password}->{record}
516 :			unless ref $Password eq $self->{password}->{record};
517 :	sh002i	1635
518 :			checkKeyfields($Password);
519 :
520 :	sh002i	1096	croak "addPassword: password exists (perhaps you meant to use putPassword?)"
521 :			if $self->{password}->exists($Password->user_id);
522 :			croak "addPassword: user ", $Password->user_id, " not found"
523 :	sh002i	775	unless $self->{user}->exists($Password->user_id);
524 :	sh002i	1096
525 :	sh002i	775	return $self->{password}->add($Password);
526 :			}
527 :
528 :	sh002i	1012	=item getPassword($userID)
529 :
530 :			If a record with a matching user ID exists, a record object containting that
531 :	sh002i	1635	record's data will be returned. If no such record exists, one will be created.
532 :	sh002i	1012
533 :			=cut
534 :
535 :	sh002i	1512	sub getPassword {
536 :	sh002i	775	my ($self, $userID) = @_;
537 :	sh002i	1096
538 :			croak "getPassword: requires 1 argument"
539 :			unless @_ == 2;
540 :			croak "getPassword: argument 1 must contain a user_id"
541 :			unless defined $userID;
542 :
543 :	sh002i	1635	#return $self->{password}->get($userID);
544 :			return ( $self->getPasswords($userID) )[0];
545 :	sh002i	775	}
546 :
547 :	sh002i	1512	=item getPasswords(@uesrIDs)
548 :
549 :			Return a list of password records associated with the user IDs given. If there
550 :	sh002i	1635	is no record associated with a given user ID, one will be created.
551 :	sh002i	1512
552 :			=cut
553 :
554 :			sub getPasswords {
555 :			my ($self, @userIDs) = @_;
556 :
557 :	sh002i	1641	#croak "getPasswords: requires 1 or more argument"
558 :			# unless @_ >= 2;
559 :	sh002i	1512	foreach my $i (0 .. $#userIDs) {
560 :			croak "getPasswords: element $i of argument list must contain a user_id"
561 :			unless defined $userIDs[$i];
562 :			}
563 :
564 :	sh002i	1635	my @Passwords = $self->{password}->gets(map { [$_] } @userIDs);
565 :
566 :			for (my $i = 0; $i < @Passwords; $i++) {
567 :			my $Password = $Passwords[$i];
568 :			my $userID = $userIDs[$i];
569 :			if (not defined $Password) {
570 :			if ($self->{user}->exists($userID)) {
571 :			$Password = $self->newPassword(user_id => $userID);
572 :			eval { $self->addPassword($Password) };
573 :			if ($@ and $@ !~ m/password exists/) {
574 :			die "error while auto-creating password record for user $userID: \"$@\"";
575 :			}
576 :			}
577 :			}
578 :			}
579 :
580 :			return @Passwords;
581 :	sh002i	1512	}
582 :
583 :	sh002i	1012	=item putPassword($Password)
584 :
585 :			$Password is a record object. If a password record with the same user ID exists
586 :			in the password table, the data in the record is replaced with the data in
587 :	sh002i	2747	$Password. If a matching password record does not exist, one will be created.
588 :			(This is different from most other "put" methods.)
589 :	sh002i	1012
590 :			=cut
591 :
592 :	sh002i	775	sub putPassword($$) {
593 :			my ($self, $Password) = @_;
594 :	sh002i	1096
595 :			croak "putPassword: requires 1 argument"
596 :			unless @_ == 2;
597 :			croak "putPassword: argument 1 must be of type ", $self->{password}->{record}
598 :			unless ref $Password eq $self->{password}->{record};
599 :	sh002i	1635
600 :			checkKeyfields($Password);
601 :
602 :	sh002i	2747	# For Passwords and PermissionLevels, auto-create a record when it doesn't
603 :			# already exist. This should be safe.
604 :			if ($self->{password}->exists($Password->user_id)) {
605 :			return $self->{password}->put($Password);
606 :			} else {
607 :			return $self->addPassword($Password);
608 :			}
609 :	sh002i	775	}
610 :
611 :	sh002i	1012	=item deletePassword($userID)
612 :
613 :			If a password record with a user ID matching $userID exists in the password
614 :			table, it is removed and the method returns a true value. If one does exist,
615 :			a false value is returned.
616 :
617 :			=cut
618 :
619 :	sh002i	775	sub deletePassword($$) {
620 :			my ($self, $userID) = @_;
621 :	sh002i	1096
622 :			croak "putPassword: requires 1 argument"
623 :			unless @_ == 2;
624 :			croak "deletePassword: argument 1 must contain a user_id"
625 :			unless defined $userID;
626 :
627 :	sh002i	775	return $self->{password}->delete($userID);
628 :			}
629 :
630 :	sh002i	1012	=back
631 :
632 :			=cut
633 :
634 :	sh002i	775	################################################################################
635 :			# permission functions
636 :			################################################################################
637 :
638 :	sh002i	1108	=head2 Permission Level Methods
639 :
640 :			=over
641 :
642 :	sh002i	1201	=item newPermissionLevel()
643 :
644 :			Returns a new, empty permission level object.
645 :
646 :			=cut
647 :
648 :			sub newPermissionLevel {
649 :	sh002i	1635	my ($self, @prototype) = @_;
650 :			return $self->{permission}->{record}->new(@prototype);
651 :	sh002i	1201	}
652 :
653 :	sh002i	1108	=item listPermissionLevels()
654 :
655 :			Returns a list of user IDs representing the records in the permission table.
656 :
657 :			=cut
658 :
659 :	sh002i	775	sub listPermissionLevels($) {
660 :			my ($self) = @_;
661 :	sh002i	1096
662 :			croak "listPermissionLevels: requires 0 arguments"
663 :			unless @_ == 1;
664 :
665 :	sh002i	808	return map { $_->[0] }
666 :			$self->{permission}->list(undef);
667 :	sh002i	775	}
668 :
669 :	sh002i	1108	=item addPermissionLevel($PermissionLevel)
670 :
671 :			$PermissionLevel is a record object. The permission level will be added to the
672 :			permission table if a permission level with the same user ID does not already
673 :			exist. If one does exist, an exception is thrown. To add a permission level, a
674 :			user with a matching user ID must exist in the user table.
675 :
676 :			=cut
677 :
678 :	sh002i	808	sub addPermissionLevel($$) {
679 :	sh002i	775	my ($self, $PermissionLevel) = @_;
680 :	sh002i	1096
681 :			croak "addPermissionLevel: requires 1 argument"
682 :			unless @_ == 2;
683 :			croak "addPermissionLevel: argument 1 must be of type ", $self->{permission}->{record}
684 :			unless ref $PermissionLevel eq $self->{permission}->{record};
685 :	sh002i	1635
686 :			checkKeyfields($PermissionLevel);
687 :
688 :	sh002i	1096	croak "addPermissionLevel: permission level exists (perhaps you meant to use putPermissionLevel?)"
689 :			if $self->{permission}->exists($PermissionLevel->user_id);
690 :			croak "addPermissionLevel: user ", $PermissionLevel->user_id, " not found"
691 :	sh002i	775	unless $self->{user}->exists($PermissionLevel->user_id);
692 :	sh002i	1096
693 :	sh002i	775	return $self->{permission}->add($PermissionLevel);
694 :			}
695 :
696 :	sh002i	1108	=item getPermissionLevel($userID)
697 :
698 :			If a record with a matching user ID exists, a record object containting that
699 :	sh002i	1635	record's data will be returned. If no such record exists, one will be created.
700 :	sh002i	1108
701 :			=cut
702 :
703 :	sh002i	775	sub getPermissionLevel($$) {
704 :			my ($self, $userID) = @_;
705 :	sh002i	1096
706 :			croak "getPermissionLevel: requires 1 argument"
707 :			unless @_ == 2;
708 :			croak "getPermissionLevel: argument 1 must contain a user_id"
709 :			unless defined $userID;
710 :
711 :	sh002i	1635	#return $self->{permission}->get($userID);
712 :			return ( $self->getPermissionLevels($userID) )[0];
713 :	sh002i	775	}
714 :
715 :	sh002i	1512	=item getPermissionLevels(@uesrIDs)
716 :
717 :			Return a list of permission level records associated with the user IDs given. If
718 :	sh002i	1635	there is no record associated with a given user ID, one will be created.
719 :	sh002i	1512
720 :			=cut
721 :
722 :			sub getPermissionLevels {
723 :			my ($self, @userIDs) = @_;
724 :
725 :	sh002i	1641	#croak "getPermissionLevels: requires 1 or more argument"
726 :			# unless @_ >= 2;
727 :	sh002i	1512	foreach my $i (0 .. $#userIDs) {
728 :			croak "getPermissionLevels: element $i of argument list must contain a user_id"
729 :			unless defined $userIDs[$i];
730 :			}
731 :
732 :	sh002i	1635	my @PermissionLevels = $self->{permission}->gets(map { [$_] } @userIDs);
733 :
734 :			for (my $i = 0; $i < @PermissionLevels; $i++) {
735 :			my $PermissionLevel = $PermissionLevels[$i];
736 :			my $userID = $userIDs[$i];
737 :			if (not defined $PermissionLevel) {
738 :			if ($self->{user}->exists($userID)) {
739 :			$PermissionLevel = $self->newPermissionLevel(user_id => $userID);
740 :			eval { $self->addPermissionLevel($PermissionLevel) };
741 :			if ($@ and $@ !~ m/permission level exists/) {
742 :			die "error while auto-creating permission level record for user $userID: \"$@\"";
743 :			}
744 :	sh002i	1976	$PermissionLevels[$i] = $PermissionLevel;
745 :	sh002i	1635	}
746 :			}
747 :			}
748 :
749 :			return @PermissionLevels;
750 :	sh002i	1512	}
751 :
752 :	sh002i	1108	=item putPermissionLevel($PermissionLevel)
753 :
754 :			$PermissionLevel is a record object. If a permission level record with the same
755 :			user ID exists in the permission table, the data in the record is replaced with
756 :			the data in $PermissionLevel. If a matching permission level record does not
757 :	sh002i	2747	exist, one will be created. (This is different from most other "put" methods.)
758 :	sh002i	1108
759 :			=cut
760 :
761 :	sh002i	775	sub putPermissionLevel($$) {
762 :			my ($self, $PermissionLevel) = @_;
763 :	sh002i	1096
764 :			croak "putPermissionLevel: requires 1 argument"
765 :			unless @_ == 2;
766 :			croak "putPermissionLevel: argument 1 must be of type ", $self->{permission}->{record}
767 :			unless ref $PermissionLevel eq $self->{permission}->{record};
768 :	sh002i	1635
769 :			checkKeyfields($PermissionLevel);
770 :
771 :	sh002i	2747	# For Passwords and PermissionLevels, auto-create a record when it doesn't
772 :			# already exist. This should be safe.
773 :			if ($self->{permission}->exists($PermissionLevel->user_id)) {
774 :			return $self->{permission}->put($PermissionLevel);
775 :			} else {
776 :			return $self->{permission}->add($PermissionLevel);
777 :			}
778 :	sh002i	775	}
779 :
780 :	sh002i	1108	=item deletePermissionLevel($userID)
781 :
782 :			If a permission level record with a user ID matching $userID exists in the
783 :			permission table, it is removed and the method returns a true value. If one
784 :			does exist, a false value is returned.
785 :
786 :			=cut
787 :
788 :	sh002i	775	sub deletePermissionLevel($$) {
789 :			my ($self, $userID) = @_;
790 :	sh002i	1096
791 :			croak "deletePermissionLevel: requires 1 argument"
792 :			unless @_ == 2;
793 :			croak "deletePermissionLevel: argument 1 must contain a user_id"
794 :			unless defined $userID;
795 :
796 :	sh002i	775	return $self->{permission}->delete($userID);
797 :			}
798 :
799 :	sh002i	2955	=back
800 :
801 :			=cut
802 :
803 :	sh002i	775	################################################################################
804 :			# key functions
805 :			################################################################################
806 :
807 :	sh002i	1108	=head2 Key Methods
808 :
809 :			=over
810 :
811 :	sh002i	1201	=item newKey()
812 :
813 :			Returns a new, empty key object.
814 :
815 :			=cut
816 :
817 :			sub newKey {
818 :	sh002i	1635	my ($self, @prototype) = @_;
819 :			return $self->{key}->{record}->new(@prototype);
820 :	sh002i	1201	}
821 :
822 :	sh002i	1108	=item listKeys()
823 :
824 :			Returns a list of user IDs representing the records in the key table.
825 :
826 :			=cut
827 :
828 :	sh002i	775	sub listKeys($) {
829 :			my ($self) = @_;
830 :	sh002i	1096
831 :			croak "listKeys: requires 0 arguments"
832 :			unless @_ == 1;
833 :
834 :	sh002i	808	return map { $_->[0] }
835 :			$self->{key}->list(undef);
836 :	sh002i	775	}
837 :
838 :	sh002i	1108	=item addKey($Key)
839 :
840 :			$Key is a record object. The key will be added to the key table if a key with
841 :			the same user ID does not already exist. If one does exist, an exception is
842 :			thrown. To add a key, a user with a matching user ID must exist in the user
843 :			table.
844 :
845 :	glarose	3377	We also allow user IDs to match userID1,userID2 where both userIDs are valid,
846 :			to allow for proctored tests, where the second userID is the ID of the
847 :			proctor.
848 :
849 :	sh002i	1108	=cut
850 :
851 :	sh002i	808	sub addKey($$) {
852 :	sh002i	775	my ($self, $Key) = @_;
853 :	sh002i	1096
854 :			croak "addKey: requires 1 argument"
855 :			unless @_ == 2;
856 :			croak "addKey: argument 1 must be of type ", $self->{key}->{record}
857 :			unless ref $Key eq $self->{key}->{record};
858 :	sh002i	1635
859 :	glarose	3377	checkKeyfields($Key, 1); # 1 flags that we can have a comma
860 :	sh002i	1635
861 :	sh002i	1096	croak "addKey: key exists (perhaps you meant to use putKey?)"
862 :			if $self->{key}->exists($Key->user_id);
863 :	glarose	3377	if ( $Key->user_id !~ /,/ ) {
864 :			croak "addKey: user ", $Key->user_id, " not found"
865 :	sh002i	775	unless $self->{user}->exists($Key->user_id);
866 :	glarose	3377	} else {
867 :			my ( $userID, $proctorID ) = split(/,/, $Key->user_id);
868 :			croak "addKey: user $userID not found"
869 :			unless $self->{user}->exists($userID);
870 :			croak "addKey: proctor $proctorID not found"
871 :			unless $self->{user}->exists($proctorID);
872 :			}
873 :	sh002i	1096
874 :	sh002i	775	return $self->{key}->add($Key);
875 :			}
876 :
877 :	sh002i	1108	=item getKey($userID)
878 :
879 :			If a record with a matching user ID exists, a record object containting that
880 :			record's data will be returned. If no such record exists, an undefined value
881 :			will be returned.
882 :
883 :			=cut
884 :
885 :	sh002i	775	sub getKey($$) {
886 :			my ($self, $userID) = @_;
887 :	sh002i	1096
888 :			croak "getKey: requires 1 argument"
889 :			unless @_ == 2;
890 :			croak "getKey: argument 1 must contain a user_id"
891 :			unless defined $userID;
892 :
893 :	sh002i	775	return $self->{key}->get($userID);
894 :			}
895 :
896 :	sh002i	1512	=item getKeys(@uesrIDs)
897 :
898 :			Return a list of key records associated with the user IDs given. If there is no
899 :			record associated with a given user ID, that element of the list will be
900 :			undefined.
901 :
902 :			=cut
903 :
904 :			sub getKeys {
905 :			my ($self, @userIDs) = @_;
906 :
907 :	sh002i	1641	#croak "getKeys: requires 1 or more argument"
908 :			# unless @_ >= 2;
909 :	sh002i	1512	foreach my $i (0 .. $#userIDs) {
910 :			croak "getKeys: element $i of argument list must contain a user_id"
911 :			unless defined $userIDs[$i];
912 :			}
913 :
914 :	sh002i	1587	return $self->{key}->gets(map { [$_] } @userIDs);
915 :	sh002i	1512	}
916 :
917 :	sh002i	1108	=item putKey($Key)
918 :
919 :			$Key is a record object. If a key record with the same user ID exists in the
920 :			key table, the data in the record is replaced with the data in $Key. If a
921 :			matching key record does not exist, an exception is thrown.
922 :
923 :			=cut
924 :
925 :	sh002i	775	sub putKey($$) {
926 :			my ($self, $Key) = @_;
927 :	sh002i	1096
928 :			croak "putKey: requires 1 argument"
929 :			unless @_ == 2;
930 :			croak "putKey: argument 1 must be of type ", $self->{key}->{record}
931 :			unless ref $Key eq $self->{key}->{record};
932 :	sh002i	1635
933 :	glarose	3377	checkKeyfields($Key, 1); # 1 allows commas for versioned sets
934 :	sh002i	1635
935 :	sh002i	1096	croak "putKey: key not found (perhaps you meant to use addKey?)"
936 :			unless $self->{key}->exists($Key->user_id);
937 :
938 :	sh002i	775	return $self->{key}->put($Key);
939 :			}
940 :
941 :	sh002i	1108	=item deleteKey($userID)
942 :
943 :			If a key record with a user ID matching $userID exists in the key table, it is
944 :			removed and the method returns a true value. If one does exist, a false value
945 :			is returned.
946 :
947 :			=cut
948 :
949 :	sh002i	775	sub deleteKey($$) {
950 :			my ($self, $userID) = @_;
951 :	sh002i	1096
952 :			croak "deleteKey: requires 1 argument"
953 :			unless @_ == 2;
954 :			croak "deleteKey: argument 1 must contain a user_id"
955 :			unless defined $userID;
956 :
957 :	sh002i	775	return $self->{key}->delete($userID);
958 :			}
959 :
960 :	sh002i	2955	=back
961 :
962 :			=cut
963 :
964 :	sh002i	775	################################################################################
965 :			# user functions
966 :			################################################################################
967 :
968 :	sh002i	1108	=head2 User Methods
969 :
970 :			=over
971 :
972 :	sh002i	1201	=item newUser()
973 :
974 :			Returns a new, empty user object.
975 :
976 :			=cut
977 :
978 :			sub newUser {
979 :	sh002i	1635	my ($self, @prototype) = @_;
980 :			return $self->{user}->{record}->new(@prototype);
981 :	sh002i	1201	}
982 :
983 :	sh002i	1108	=item listUsers()
984 :
985 :			Returns a list of user IDs representing the records in the user table.
986 :
987 :			=cut
988 :
989 :	sh002i	1568	sub listUsers {
990 :	sh002i	775	my ($self) = @_;
991 :	sh002i	1096
992 :			croak "listUsers: requires 0 arguments"
993 :			unless @_ == 1;
994 :
995 :	sh002i	808	return map { $_->[0] }
996 :			$self->{user}->list(undef);
997 :	sh002i	775	}
998 :
999 :	sh002i	1108	=item addUser($User)
1000 :
1001 :			$User is a record object. The user will be added to the user table if a user
1002 :			with the same user ID does not already exist. If one does exist, an exception
1003 :			is thrown.
1004 :
1005 :			=cut
1006 :
1007 :	sh002i	1568	sub addUser {
1008 :	sh002i	775	my ($self, $User) = @_;
1009 :	sh002i	1096
1010 :			croak "addUser: requires 1 argument"
1011 :			unless @_ == 2;
1012 :			croak "addUser: argument 1 must be of type ", $self->{user}->{record}
1013 :			unless ref $User eq $self->{user}->{record};
1014 :	sh002i	1635
1015 :			checkKeyfields($User);
1016 :
1017 :	sh002i	1096	croak "addUser: user exists (perhaps you meant to use putUser?)"
1018 :			if $self->{user}->exists($User->user_id);
1019 :
1020 :	sh002i	775	return $self->{user}->add($User);
1021 :			}
1022 :
1023 :	sh002i	1108	=item getUser($userID)
1024 :
1025 :			If a record with a matching user ID exists, a record object containting that
1026 :			record's data will be returned. If no such record exists, an undefined value
1027 :			will be returned.
1028 :
1029 :			=cut
1030 :
1031 :	sh002i	1568	sub getUser {
1032 :	sh002i	775	my ($self, $userID) = @_;
1033 :	sh002i	1096
1034 :			croak "getUser: requires 1 argument"
1035 :			unless @_ == 2;
1036 :			croak "getUser: argument 1 must contain a user_id"
1037 :			unless defined $userID;
1038 :
1039 :	sh002i	775	return $self->{user}->get($userID);
1040 :			}
1041 :
1042 :	sh002i	1512	=item getUsers(@uesrIDs)
1043 :
1044 :			Return a list of user records associated with the user IDs given. If there is no
1045 :			record associated with a given user ID, that element of the list will be
1046 :			undefined.
1047 :
1048 :			=cut
1049 :
1050 :			sub getUsers {
1051 :			my ($self, @userIDs) = @_;
1052 :
1053 :	sh002i	1641	#croak "getUsers: requires 1 or more argument"
1054 :			# unless @_ >= 2;
1055 :	sh002i	1512	foreach my $i (0 .. $#userIDs) {
1056 :			croak "getUsers: element $i of argument list must contain a user_id"
1057 :			unless defined $userIDs[$i];
1058 :			}
1059 :
1060 :	sh002i	1587	return $self->{user}->gets(map { [$_] } @userIDs);
1061 :	sh002i	1512	}
1062 :
1063 :	sh002i	1108	=item putUser($User)
1064 :
1065 :			$User is a record object. If a user record with the same user ID exists in the
1066 :			user table, the data in the record is replaced with the data in $User. If a
1067 :			matching user record does not exist, an exception is thrown.
1068 :
1069 :			=cut
1070 :
1071 :	sh002i	1568	sub putUser {
1072 :	sh002i	775	my ($self, $User) = @_;
1073 :	sh002i	1096
1074 :			croak "putUser: requires 1 argument"
1075 :			unless @_ == 2;
1076 :			croak "putUser: argument 1 must be of type ", $self->{user}->{record}
1077 :			unless ref $User eq $self->{user}->{record};
1078 :	sh002i	1635
1079 :			checkKeyfields($User);
1080 :
1081 :	sh002i	1096	croak "putUser: user not found (perhaps you meant to use addUser?)"
1082 :			unless $self->{user}->exists($User->user_id);
1083 :
1084 :	sh002i	775	return $self->{user}->put($User);
1085 :			}
1086 :
1087 :	sh002i	1108	=item deleteUser($userID)
1088 :
1089 :			If a user record with a user ID matching $userID exists in the user table, it
1090 :			is removed and the method returns a true value. If one does exist, a false
1091 :			value is returned. When a user record is deleted, all records associated with
1092 :			that user are also deleted. This includes the password, permission, and key
1093 :			records, and all user set records for that user.
1094 :
1095 :			=cut
1096 :
1097 :	sh002i	1568	sub deleteUser {
1098 :	sh002i	775	my ($self, $userID) = @_;
1099 :	sh002i	1096
1100 :			croak "deleteUser: requires 1 argument"
1101 :			unless @_ == 2;
1102 :			croak "deleteUser: argument 1 must contain a user_id"
1103 :			unless defined $userID;
1104 :
1105 :	sh002i	1167	$self->deleteUserSet($userID, undef);
1106 :	sh002i	775	$self->deletePassword($userID);
1107 :			$self->deletePermissionLevel($userID);
1108 :			$self->deleteKey($userID);
1109 :			return $self->{user}->delete($userID);
1110 :			}
1111 :
1112 :	sh002i	1583	=back
1113 :
1114 :			=cut
1115 :
1116 :	sh002i	775	################################################################################
1117 :			# set functions
1118 :			################################################################################
1119 :
1120 :	sh002i	1583	=head2 Global Set Methods
1121 :
1122 :			FIXME: write this
1123 :
1124 :			=over
1125 :
1126 :			=cut
1127 :
1128 :	sh002i	1696	=item newGlobalSet()
1129 :
1130 :			=cut
1131 :
1132 :	sh002i	1201	sub newGlobalSet {
1133 :	sh002i	1635	my ($self, @prototype) = @_;
1134 :			return $self->{set}->{record}->new(@prototype);
1135 :	sh002i	1201	}
1136 :
1137 :	sh002i	1696	=item listGlobalSets()
1138 :
1139 :			=cut
1140 :
1141 :	sh002i	1641	sub listGlobalSets {
1142 :	sh002i	775	my ($self) = @_;
1143 :	sh002i	1096
1144 :			croak "listGlobalSets: requires 0 arguments"
1145 :			unless @_ == 1;
1146 :
1147 :	sh002i	808	return map { $_->[0] }
1148 :			$self->{set}->list(undef);
1149 :	sh002i	775	}
1150 :
1151 :	sh002i	1696	=item addGlobalSet($GlobalSet)
1152 :
1153 :			=cut
1154 :
1155 :	sh002i	1641	sub addGlobalSet {
1156 :	sh002i	775	my ($self, $GlobalSet) = @_;
1157 :	sh002i	1096
1158 :			croak "addGlobalSet: requires 1 argument"
1159 :			unless @_ == 2;
1160 :			croak "addGlobalSet: argument 1 must be of type ", $self->{set}->{record}
1161 :			unless ref $GlobalSet eq $self->{set}->{record};
1162 :	sh002i	1635
1163 :			checkKeyfields($GlobalSet);
1164 :
1165 :	sh002i	1096	croak "addGlobalSet: global set exists (perhaps you meant to use putGlobalSet?)"
1166 :			if $self->{set}->exists($GlobalSet->set_id);
1167 :
1168 :	sh002i	775	return $self->{set}->add($GlobalSet);
1169 :			}
1170 :
1171 :	sh002i	1696	=item addGlobalSet($setID)
1172 :
1173 :			=cut
1174 :
1175 :	sh002i	1641	sub getGlobalSet {
1176 :	sh002i	775	my ($self, $setID) = @_;
1177 :	sh002i	1096
1178 :			croak "getGlobalSet: requires 1 argument"
1179 :			unless @_ == 2;
1180 :			croak "getGlobalSet: argument 1 must contain a set_id"
1181 :			unless defined $setID;
1182 :
1183 :	sh002i	775	return $self->{set}->get($setID);
1184 :			}
1185 :
1186 :	sh002i	1512	=item getGlobalSets(@setIDs)
1187 :
1188 :	sh002i	1641	Return a list of global set records associated with the record IDs given. If
1189 :			there is no record associated with a given record ID, that element of the list
1190 :			will be undefined.
1191 :	sh002i	1512
1192 :			=cut
1193 :
1194 :			sub getGlobalSets {
1195 :			my ($self, @setIDs) = @_;
1196 :
1197 :	sh002i	1641	#croak "getGlobalSets: requires 1 or more argument"
1198 :			# unless @_ >= 2;
1199 :	sh002i	1512	foreach my $i (0 .. $#setIDs) {
1200 :			croak "getGlobalSets: element $i of argument list must contain a set_id"
1201 :			unless defined $setIDs[$i];
1202 :			}
1203 :
1204 :	sh002i	1587	return $self->{set}->gets(map { [$_] } @setIDs);
1205 :	sh002i	1512	}
1206 :
1207 :	sh002i	1696	=item addGlobalSet($GlobalSet)
1208 :
1209 :			=cut
1210 :
1211 :	sh002i	1641	sub putGlobalSet {
1212 :	sh002i	775	my ($self, $GlobalSet) = @_;
1213 :	sh002i	1096
1214 :			croak "putGlobalSet: requires 1 argument"
1215 :			unless @_ == 2;
1216 :			croak "putGlobalSet: argument 1 must be of type ", $self->{set}->{record}
1217 :			unless ref $GlobalSet eq $self->{set}->{record};
1218 :	sh002i	1635
1219 :			checkKeyfields($GlobalSet);
1220 :
1221 :	sh002i	1096	croak "putGlobalSet: global set not found (perhaps you meant to use addGlobalSet?)"
1222 :			unless $self->{set}->exists($GlobalSet->set_id);
1223 :
1224 :	sh002i	775	return $self->{set}->put($GlobalSet);
1225 :			}
1226 :
1227 :	sh002i	1696	=item addGlobalSet($setID)
1228 :
1229 :			=cut
1230 :
1231 :	sh002i	1641	sub deleteGlobalSet {
1232 :	sh002i	775	my ($self, $setID) = @_;
1233 :	sh002i	1096
1234 :			croak "deleteGlobalSet: requires 1 argument"
1235 :			unless @_ == 2;
1236 :			croak "deleteGlobalSet: argument 1 must contain a set_id"
1237 :	sh002i	1167	unless defined $setID or caller eq __PACKAGE__;
1238 :	sh002i	1096
1239 :	sh002i	1167	$self->deleteUserSet(undef, $setID);
1240 :			$self->deleteGlobalProblem($setID, undef);
1241 :	sh002i	775	return $self->{set}->delete($setID);
1242 :			}
1243 :
1244 :	sh002i	1583	=back
1245 :
1246 :			=cut
1247 :
1248 :	sh002i	775	################################################################################
1249 :			# set_user functions
1250 :			################################################################################
1251 :
1252 :	sh002i	1583	=head2 User-Specific Set Methods
1253 :
1254 :			FIXME: write this
1255 :
1256 :			=over
1257 :
1258 :			=cut
1259 :
1260 :	sh002i	1201	sub newUserSet {
1261 :	sh002i	1635	my ($self, @prototype) = @_;
1262 :			return $self->{set_user}->{record}->new(@prototype);
1263 :	sh002i	1201	}
1264 :
1265 :	sh002i	1661	sub countSetUsers {
1266 :			my ($self, $setID) = @_;
1267 :
1268 :	toenail	2330	croak "countSetUsers: requires 1 argument"
1269 :	sh002i	1661	unless @_ == 2;
1270 :	toenail	2330	croak "countSetUsers: argument 1 must contain a set_id"
1271 :	sh002i	1661	unless defined $setID;
1272 :
1273 :			# inefficient way
1274 :			#return scalar $self->{set_user}->list(undef, $setID);
1275 :
1276 :			# efficient way
1277 :			return $self->{set_user}->count(undef, $setID);
1278 :			}
1279 :
1280 :	sh002i	1641	sub listSetUsers {
1281 :	sh002i	909	my ($self, $setID) = @_;
1282 :	sh002i	1096
1283 :	sh002i	1661	carp "listSetUsers called in SCALAR context: use countSetUsers instead!\n"
1284 :			unless wantarray;
1285 :
1286 :	sh002i	1096	croak "listSetUsers: requires 1 argument"
1287 :			unless @_ == 2;
1288 :			croak "listSetUsers: argument 1 must contain a set_id"
1289 :			unless defined $setID;
1290 :
1291 :	sh002i	909	return map { $_->[0] } # extract user_id
1292 :			$self->{set_user}->list(undef, $setID);
1293 :			}
1294 :
1295 :	toenail	2330	sub countUserSets {
1296 :			my ($self, $userID) = @_;
1297 :
1298 :			croak "countUserSets: requires 1 argument"
1299 :			unless @_ == 2;
1300 :			croak "countUserSets: argument 1 must contain a user_id"
1301 :			unless defined $userID;
1302 :
1303 :			return $self->{set_user}->count($userID, undef);
1304 :			}
1305 :
1306 :	sh002i	1641	sub listUserSets {
1307 :	sh002i	775	my ($self, $userID) = @_;
1308 :	sh002i	1096
1309 :			croak "listUserSets: requires 1 argument"
1310 :			unless @_ == 2;
1311 :			croak "listUserSets: argument 1 must contain a user_id"
1312 :			unless defined $userID;
1313 :
1314 :	sh002i	808	return map { $_->[1] } # extract set_id
1315 :			$self->{set_user}->list($userID, undef);
1316 :	sh002i	775	}
1317 :
1318 :	glarose	3377	# the code from addUserSet() is duplicated in large part following in
1319 :			# addVersionedUserSet; changes here should accordingly be propagated down there
1320 :
1321 :	sh002i	1641	sub addUserSet {
1322 :	sh002i	775	my ($self, $UserSet) = @_;
1323 :	sh002i	1096
1324 :			croak "addUserSet: requires 1 argument"
1325 :			unless @_ == 2;
1326 :			croak "addUserSet: argument 1 must be of type ", $self->{set_user}->{record}
1327 :			unless ref $UserSet eq $self->{set_user}->{record};
1328 :	sh002i	1635
1329 :			checkKeyfields($UserSet);
1330 :
1331 :	sh002i	1096	croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"
1332 :			if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
1333 :			croak "addUserSet: user ", $UserSet->user_id, " not found"
1334 :	sh002i	775	unless $self->{user}->exists($UserSet->user_id);
1335 :	sh002i	1096	croak "addUserSet: set ", $UserSet->set_id, " not found"
1336 :	sh002i	775	unless $self->{set}->exists($UserSet->set_id);
1337 :	sh002i	1096
1338 :	sh002i	775	return $self->{set_user}->add($UserSet);
1339 :			}
1340 :
1341 :	glarose	3377	sub addVersionedUserSet {
1342 :			my ($self, $UserSet) = @_;
1343 :
1344 :			# this is the same as addUserSet,allowing for set names of the form setID,vN
1345 :
1346 :			croak "addVersionedUserSet: requires 1 argument"
1347 :			unless @_ == 2;
1348 :			croak "addVersionedUserSet: argument 1 must be of type ",
1349 :			$self->{set_user}->{record}
1350 :			unless ref $UserSet eq $self->{set_user}->{record};
1351 :
1352 :			# $versioned is a flag that we send in to allow commas in the set name
1353 :			# for versioned sets
1354 :			my $versioned = 1;
1355 :			checkKeyfields($UserSet, $versioned);
1356 :			my ($nonVersionedSetName) = ($UserSet->set_id =~ /^(.*),v\d+$/);
1357 :
1358 :			croak "addUserSet: user set exists (perhaps you meant to use putUserSet?)"
1359 :			if $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
1360 :			croak "addUserSet: user ", $UserSet->user_id, " not found"
1361 :			unless $self->{user}->exists($UserSet->user_id);
1362 :			# croak "addUserSet: set ", $UserSet->set_id, " not found"
1363 :			# unless $self->{set}->exists($UserSet->set_id);
1364 :			# here the appropriate check is whether a global set of the nonversioned set
1365 :			# name exists
1366 :			croak "addVersionedUserSet: set ", $nonVersionedSetName, " not found"
1367 :			unless $self->{set}->exists( $nonVersionedSetName );
1368 :
1369 :			return $self->{set_user}->add($UserSet);
1370 :			}
1371 :
1372 :	sh002i	1641	sub getUserSet {
1373 :	sh002i	775	my ($self, $userID, $setID) = @_;
1374 :	sh002i	1096
1375 :			croak "getUserSet: requires 2 arguments"
1376 :			unless @_ == 3;
1377 :			croak "getUserSet: argument 1 must contain a user_id"
1378 :			unless defined $userID;
1379 :			croak "getUserSet: argument 2 must contain a set_id"
1380 :			unless defined $setID;
1381 :
1382 :	sh002i	1589	#return $self->{set_user}->get($userID, $setID);
1383 :			return ( $self->getUserSets([$userID, $setID]) )[0];
1384 :	sh002i	775	}
1385 :
1386 :	sh002i	1512	=item getUserSets(@userSetIDs)
1387 :
1388 :	sh002i	1641	Return a list of user set records associated with the record IDs given. If there
1389 :			is no record associated with a given record ID, that element of the list will be
1390 :	sh002i	1512	undefined. @userProblemIDs consists of references to arrays in which the first
1391 :			element is the user_id and the second element is the set_id.
1392 :
1393 :			=cut
1394 :
1395 :			sub getUserSets {
1396 :			my ($self, @userSetIDs) = @_;
1397 :
1398 :	sh002i	1641	#croak "getUserSets: requires 1 or more argument"
1399 :			# unless @_ >= 2;
1400 :	sh002i	1512	foreach my $i (0 .. $#userSetIDs) {
1401 :			croak "getUserSets: element $i of argument list must contain a <user_id, set_id> pair"
1402 :			unless defined $userSetIDs[$i]
1403 :			and ref $userSetIDs[$i] eq "ARRAY"
1404 :			and @{$userSetIDs[$i]} == 2
1405 :			and defined $userSetIDs[$i]->[0]
1406 :			and defined $userSetIDs[$i]->[1];
1407 :			}
1408 :
1409 :	sh002i	1568	return $self->{set_user}->gets(@userSetIDs);
1410 :	sh002i	1512	}
1411 :
1412 :	glarose	3377	sub getUserSetVersions {
1413 :			my ( $self, $uid, $sid, $versionNum ) = @_;
1414 :			# in: $uid is a userID, $sid is a setID, and $versionNum is a version number
1415 :			# userID has set versions 1 through $versionNum defined
1416 :			# out: an array of user set objects is returned for the indicated version
1417 :			# numbers
1418 :
1419 :			croak "getUserSetVersions: requires three arguments, userID, setID, and " .
1420 :			"versionNum" if ( @_ < 3 );
1421 :
1422 :			my @userSetIDs = ();
1423 :			foreach my $i ( 1 .. $versionNum ) {
1424 :			push( @userSetIDs, [ $uid, "$sid,v$i" ] );
1425 :			}
1426 :
1427 :			return $self->getUserSets( @userSetIDs );
1428 :			}
1429 :
1430 :			# the code from putUserSet() is duplicated in large part in the following
1431 :			# putVersionedUserSet; c.f. that routine
1432 :
1433 :	sh002i	1641	sub putUserSet {
1434 :	sh002i	775	my ($self, $UserSet) = @_;
1435 :	sh002i	1096
1436 :			croak "putUserSet: requires 1 argument"
1437 :			unless @_ == 2;
1438 :			croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record}
1439 :			unless ref $UserSet eq $self->{set_user}->{record};
1440 :	sh002i	1635
1441 :			checkKeyfields($UserSet);
1442 :
1443 :	sh002i	1096	croak "putUserSet: user set not found (perhaps you meant to use addUserSet?)"
1444 :			unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
1445 :			croak "putUserSet: user ", $UserSet->user_id, " not found"
1446 :			unless $self->{user}->exists($UserSet->user_id);
1447 :			croak "putUserSet: set ", $UserSet->set_id, " not found"
1448 :			unless $self->{set}->exists($UserSet->set_id);
1449 :
1450 :	sh002i	775	return $self->{set_user}->put($UserSet);
1451 :			}
1452 :
1453 :	glarose	3377	sub putVersionedUserSet {
1454 :			my ($self, $UserSet) = @_;
1455 :			# this exists separate from putUserSet only so that we can make it harder
1456 :			# for anyone else to use commas in setIDs
1457 :
1458 :			croak "putUserSet: requires 1 argument"
1459 :			unless @_ == 2;
1460 :			croak "putUserSet: argument 1 must be of type ", $self->{set_user}->{record}
1461 :			unless ref $UserSet eq $self->{set_user}->{record};
1462 :
1463 :			# versioned allows us to have a wacked out setID
1464 :			my $versioned = 1;
1465 :			checkKeyfields($UserSet, $versioned);
1466 :
1467 :			my $nonVersionedSetID = $UserSet->set_id;
1468 :			$nonVersionedSetID =~ s/,v\d+$//;
1469 :			# my ($nonVersionedSetID) = ($UserSet->set_id =~ /^(.*)(,v\d+)?$/);
1470 :			croak "putVersionedUserSet: user set not found (perhaps you meant " .
1471 :			"to use addUserSet?)"
1472 :			unless $self->{set_user}->exists($UserSet->user_id, $UserSet->set_id);
1473 :			croak "putVersionedUserSet: user ", $UserSet->user_id, " not found"
1474 :			unless $self->{user}->exists($UserSet->user_id);
1475 :			croak "putVersionedUserSet: set $nonVersionedSetID not found"
1476 :			unless $self->{set}->exists($nonVersionedSetID);
1477 :
1478 :			return $self->{set_user}->put($UserSet);
1479 :			}
1480 :
1481 :	sh002i	1641	sub deleteUserSet {
1482 :	glarose	3377	my ($self, $userID, $setID, $skipVersionDel) = @_;
1483 :	sh002i	1096
1484 :			croak "getUserSet: requires 2 arguments"
1485 :			unless @_ == 3;
1486 :			croak "getUserSet: argument 1 must contain a user_id"
1487 :	sh002i	1167	unless defined $userID or caller eq __PACKAGE__;
1488 :	sh002i	1096	croak "getUserSet: argument 2 must contain a set_id"
1489 :	sh002i	1167	unless defined $userID or caller eq __PACKAGE__;
1490 :	sh002i	1096
1491 :	glarose	3377	$self->deleteUserSetVersions( $userID, $setID )
1492 :			if ( defined($setID) && ! ( defined($skipVersionDel) &&
1493 :			$skipVersionDel ) );
1494 :	sh002i	1167	$self->deleteUserProblem($userID, $setID, undef);
1495 :	sh002i	775	return $self->{set_user}->delete($userID, $setID);
1496 :			}
1497 :
1498 :	glarose	3377	sub deleteUserSetVersions {
1499 :			my ($self, $userID, $setID) = @_;
1500 :
1501 :			# this only gets called from deleteUserSet, so we don't worry about $setID
1502 :			# not being defined
1503 :
1504 :			# make a list of all users to delete set versions for. if we have a userID,
1505 :			# then just delete versions for that user
1506 :			my @allUsers = ();
1507 :			if ( defined( $userID ) ) {
1508 :			push( @allUsers, $userID );
1509 :			} else {
1510 :			# otherwise, get a list of all users to whom the set is assigned, and delete
1511 :			# all versions for all of them
1512 :			@allUsers = $self->listSetUsers( $setID );
1513 :			}
1514 :
1515 :			# skip version deletion when calling deleteUserSet from here
1516 :			my $skipVersionDel = 1;
1517 :
1518 :			# go through each userID and delete all versions of the set for each
1519 :			foreach my $uid ( @allUsers ) {
1520 :			my $setVersionNumber = $self->getUserSetVersionNumber($uid, $setID);
1521 :			if ( $setVersionNumber ) {
1522 :			for ( my $i=1; $i<=$setVersionNumber; $i++ ) {
1523 :			eval { $self->deleteUserSet( $uid, "$setID,v$i",
1524 :			$skipVersionDel ) };
1525 :			return $@ if ( $@ );
1526 :			}
1527 :			}
1528 :			}
1529 :			}
1530 :
1531 :			sub getUserSetVersionNumber {
1532 :			my ( $self, $uid, $sid ) = @_;
1533 :			# in: uid and sid are user and set ids. the setID is the 'global' setID
1534 :			# for the user, not a versioned value
1535 :			# out: the latest version number of the set that has been assigned to the
1536 :			# user is returned.
1537 :
1538 :			croak "getUserSetVersionNumber: requires 2 arguments, a user and set ID"
1539 :			unless @_ == 3 && defined $uid && defined $sid;
1540 :
1541 :			# we just get all sets for the user and figure out which of them
1542 :			# look like the sid.
1543 :			my @allSetIDs = $self->listUserSets( $uid );
1544 :			my @setIDs = sort( grep { /^$sid,v\d+$/ } @allSetIDs );
1545 :			my $lastSetID = $setIDs[-1];
1546 :			# I think this should be defined, unless the set hasn't been assigned to
1547 :			# the user at all, which we hope wouldn't have happened at this juncture
1548 :			if ( not defined($lastSetID) ) {
1549 :			return 0;
1550 :			} else {
1551 :			# we have to deal with the fact that 10 sorts to precede 2 (etc.)
1552 :			my @vNums = map { /^$sid,v(\d+)$/ } @setIDs;
1553 :			return ( ( sort {$a<=>$b} @vNums )[-1] );
1554 :			}
1555 :			}
1556 :
1557 :	sh002i	1583	=back
1558 :
1559 :			=cut
1560 :
1561 :	sh002i	775	################################################################################
1562 :			# problem functions
1563 :			################################################################################
1564 :
1565 :	sh002i	1583	=head2 Global Problem Methods
1566 :
1567 :			FIXME: write this
1568 :
1569 :			=over
1570 :
1571 :			=cut
1572 :
1573 :	sh002i	1201	sub newGlobalProblem {
1574 :	sh002i	1635	my ($self, @prototype) = @_;
1575 :			return $self->{problem}->{record}->new(@prototype);
1576 :	sh002i	1201	}
1577 :
1578 :	sh002i	1641	sub listGlobalProblems {
1579 :	sh002i	775	my ($self, $setID) = @_;
1580 :	sh002i	1096
1581 :			croak "listGlobalProblems: requires 1 arguments"
1582 :			unless @_ == 2;
1583 :			croak "listGlobalProblems: argument 1 must contain a set_id"
1584 :			unless defined $setID;
1585 :
1586 :	sh002i	775	return map { $_->[1] }
1587 :	sh002i	1096	$self->{problem}->list($setID, undef);
1588 :	sh002i	775	}
1589 :
1590 :	sh002i	1641	sub addGlobalProblem {
1591 :	sh002i	775	my ($self, $GlobalProblem) = @_;
1592 :	sh002i	1096
1593 :			croak "addGlobalProblem: requires 1 argument"
1594 :			unless @_ == 2;
1595 :			croak "addGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
1596 :			unless ref $GlobalProblem eq $self->{problem}->{record};
1597 :	sh002i	1635
1598 :			checkKeyfields($GlobalProblem);
1599 :
1600 :	sh002i	1096	croak "addGlobalProblem: global problem exists (perhaps you meant to use putGlobalProblem?)"
1601 :			if $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
1602 :			croak "addGlobalProblem: set ", $GlobalProblem->set_id, " not found"
1603 :	sh002i	775	unless $self->{set}->exists($GlobalProblem->set_id);
1604 :	sh002i	1096
1605 :	sh002i	775	return $self->{problem}->add($GlobalProblem);
1606 :			}
1607 :
1608 :	sh002i	1641	sub getGlobalProblem {
1609 :	sh002i	775	my ($self, $setID, $problemID) = @_;
1610 :	sh002i	1096
1611 :			croak "getGlobalProblem: requires 2 arguments"
1612 :			unless @_ == 3;
1613 :			croak "getGlobalProblem: argument 1 must contain a set_id"
1614 :			unless defined $setID;
1615 :			croak "getGlobalProblem: argument 2 must contain a problem_id"
1616 :			unless defined $problemID;
1617 :
1618 :	sh002i	916	return $self->{problem}->get($setID, $problemID);
1619 :	sh002i	775	}
1620 :
1621 :	sh002i	1512	=item getGlobalProblems(@problemIDs)
1622 :
1623 :	sh002i	1641	Return a list of global set records associated with the record IDs given. If
1624 :			there is no record associated with a given record ID, that element of the list
1625 :			will be undefined. @problemIDs consists of references to arrays in which the
1626 :			first element is the set_id, and the second element is the problem_id.
1627 :	sh002i	1512
1628 :			=cut
1629 :
1630 :			sub getGlobalProblems {
1631 :			my ($self, @problemIDs) = @_;
1632 :
1633 :	sh002i	1641	#croak "getGlobalProblems: requires 1 or more argument"
1634 :			# unless @_ >= 2;
1635 :	sh002i	1512	foreach my $i (0 .. $#problemIDs) {
1636 :	sh002i	3019	croak "getGlobalProblems: element $i of argument list must contain a <set_id, problem_id> pair"
1637 :	sh002i	1512	unless defined $problemIDs[$i]
1638 :			and ref $problemIDs[$i] eq "ARRAY"
1639 :			and @{$problemIDs[$i]} == 2
1640 :			and defined $problemIDs[$i]->[0]
1641 :			and defined $problemIDs[$i]->[1];
1642 :			}
1643 :
1644 :	sh002i	1568	return $self->{problem}->gets(@problemIDs);
1645 :	sh002i	1512	}
1646 :
1647 :	sh002i	1672	=item getAllGlobalProblems($setID)
1648 :
1649 :			Returns a list of Problem objects representing all the problems in the given
1650 :			global set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
1651 :			more efficient than using listGlobalProblems and getGlobalProblems.
1652 :
1653 :			=cut
1654 :
1655 :			sub getAllGlobalProblems {
1656 :			my ($self, $setID) = @_;
1657 :
1658 :			croak "getAllGlobalProblems: requires 1 arguments"
1659 :			unless @_ == 2;
1660 :			croak "getAllGlobalProblems: argument 1 must contain a set_id"
1661 :			unless defined $setID;
1662 :
1663 :			if ($self->{problem}->can("getAll")) {
1664 :			return $self->{problem}->getAll($setID);
1665 :			} else {
1666 :			my @problemIDPairs = $self->{problem}->list($setID, undef);
1667 :			return $self->{problem}->gets(@problemIDPairs);
1668 :			}
1669 :			}
1670 :
1671 :	sh002i	1641	sub putGlobalProblem {
1672 :	sh002i	775	my ($self, $GlobalProblem) = @_;
1673 :	sh002i	1096
1674 :			croak "putGlobalProblem: requires 1 argument"
1675 :			unless @_ == 2;
1676 :			croak "putGlobalProblem: argument 1 must be of type ", $self->{problem}->{record}
1677 :			unless ref $GlobalProblem eq $self->{problem}->{record};
1678 :	sh002i	1635
1679 :			checkKeyfields($GlobalProblem);
1680 :
1681 :	sh002i	1096	croak "putGlobalProblem: global problem not found (perhaps you meant to use addGlobalProblem?)"
1682 :			unless $self->{problem}->exists($GlobalProblem->set_id, $GlobalProblem->problem_id);
1683 :			croak "putGlobalProblem: set ", $GlobalProblem->set_id, " not found"
1684 :			unless $self->{set}->exists($GlobalProblem->set_id);
1685 :
1686 :	sh002i	775	return $self->{problem}->put($GlobalProblem);
1687 :			}
1688 :
1689 :	sh002i	1641	sub deleteGlobalProblem {
1690 :	sh002i	775	my ($self, $setID, $problemID) = @_;
1691 :	sh002i	1096
1692 :	sh002i	1167	croak "deleteGlobalProblem: requires 2 arguments"
1693 :	sh002i	1096	unless @_ == 3;
1694 :	sh002i	1167	croak "deleteGlobalProblem: argument 1 must contain a set_id"
1695 :			unless defined $setID or caller eq __PACKAGE__;
1696 :			croak "deleteGlobalProblem: argument 2 must contain a problem_id"
1697 :			unless defined $problemID or caller eq __PACKAGE__;
1698 :	sh002i	1096
1699 :	sh002i	1167	$self->deleteUserProblem(undef, $setID, $problemID);
1700 :	sh002i	775	return $self->{problem}->delete($setID, $problemID);
1701 :			}
1702 :
1703 :	sh002i	1583	=back
1704 :
1705 :			=cut
1706 :
1707 :	sh002i	775	################################################################################
1708 :			# problem_user functions
1709 :			################################################################################
1710 :
1711 :	sh002i	1583	=head2 User-Specific Problem Methods
1712 :
1713 :			FIXME: write this
1714 :
1715 :			=over
1716 :
1717 :			=cut
1718 :
1719 :	sh002i	1201	sub newUserProblem {
1720 :	sh002i	1635	my ($self, @prototype) = @_;
1721 :			return $self->{problem_user}->{record}->new(@prototype);
1722 :	sh002i	1201	}
1723 :
1724 :	sh002i	1661	sub countProblemUsers {
1725 :			my ($self, $setID, $problemID) = @_;
1726 :
1727 :			croak "countProblemUsers: requires 2 arguments"
1728 :			unless @_ == 3;
1729 :			croak "countProblemUsers: argument 1 must contain a set_id"
1730 :			unless defined $setID;
1731 :			croak "countProblemUsers: argument 2 must contain a problem_id"
1732 :			unless defined $problemID;
1733 :
1734 :			# the slow way
1735 :			#return scalar $self->{problem_user}->list(undef, $setID, $problemID);
1736 :
1737 :			# the fast way
1738 :			return $self->{problem_user}->count(undef, $setID, $problemID);
1739 :			}
1740 :
1741 :	sh002i	1641	sub listProblemUsers {
1742 :	sh002i	923	my ($self, $setID, $problemID) = @_;
1743 :	sh002i	1096
1744 :	sh002i	1661	carp "listProblemUsers called in SCALAR context: use countProblemUsers instead!\n"
1745 :			unless wantarray;
1746 :
1747 :	sh002i	1096	croak "listProblemUsers: requires 2 arguments"
1748 :			unless @_ == 3;
1749 :			croak "listProblemUsers: argument 1 must contain a set_id"
1750 :			unless defined $setID;
1751 :			croak "listProblemUsers: argument 2 must contain a problem_id"
1752 :			unless defined $problemID;
1753 :
1754 :	sh002i	923	return map { $_->[0] } # extract user_id
1755 :			$self->{problem_user}->list(undef, $setID, $problemID);
1756 :			}
1757 :
1758 :	sh002i	1641	sub listUserProblems {
1759 :	sh002i	775	my ($self, $userID, $setID) = @_;
1760 :	sh002i	1096
1761 :			croak "listUserProblems: requires 2 arguments"
1762 :			unless @_ == 3;
1763 :			croak "listUserProblems: argument 1 must contain a user_id"
1764 :			unless defined $userID;
1765 :			croak "listUserProblems: argument 2 must contain a set_id"
1766 :			unless defined $setID;
1767 :
1768 :	sh002i	923	return map { $_->[2] } # extract problem_id
1769 :	sh002i	808	$self->{problem_user}->list($userID, $setID, undef);
1770 :	sh002i	775	}
1771 :
1772 :	sh002i	1641	sub addUserProblem {
1773 :	sh002i	775	my ($self, $UserProblem) = @_;
1774 :	sh002i	1096
1775 :			croak "addUserProblem: requires 1 argument"
1776 :			unless @_ == 2;
1777 :			croak "addUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
1778 :			unless ref $UserProblem eq $self->{problem_user}->{record};
1779 :	glarose	3377
1780 :			# catch versioned sets here and check them allowing commas in some fields
1781 :			my $setID = $UserProblem->set_id;
1782 :			if ( $setID =~ /^(.*),v\d+/ ) { # then it's a versioned set
1783 :			$setID = $1;
1784 :			checkKeyfields($UserProblem, 1);
1785 :			} else {
1786 :			checkKeyfields($UserProblem);
1787 :			}
1788 :	sh002i	1635
1789 :	sh002i	1096	croak "addUserProblem: user problem exists (perhaps you meant to use putUserProblem?)"
1790 :	malsyned	1185	if $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
1791 :	sh002i	1096	croak "addUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
1792 :	glarose	3377	unless $self->{set_user}->exists($UserProblem->user_id, $setID);
1793 :	sh002i	1096	croak "addUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
1794 :	glarose	3377	unless $self->{problem}->exists($setID, $UserProblem->problem_id);
1795 :	sh002i	1096
1796 :	sh002i	775	return $self->{problem_user}->add($UserProblem);
1797 :			}
1798 :
1799 :	sh002i	1641	sub getUserProblem {
1800 :	sh002i	775	my ($self, $userID, $setID, $problemID) = @_;
1801 :	sh002i	1096
1802 :			croak "getUserProblem: requires 3 arguments"
1803 :			unless @_ == 4;
1804 :			croak "getUserProblem: argument 1 must contain a user_id"
1805 :			unless defined $userID;
1806 :			croak "getUserProblem: argument 2 must contain a set_id"
1807 :			unless defined $setID;
1808 :			croak "getUserProblem: argument 3 must contain a problem_id"
1809 :			unless defined $problemID;
1810 :
1811 :	sh002i	1589	return ( $self->getUserProblems([$userID, $setID, $problemID]) )[0];
1812 :	sh002i	775	}
1813 :
1814 :	sh002i	1512	=item getUserProblems(@userProblemIDs)
1815 :
1816 :			Return a list of user set records associated with the user IDs given. If there
1817 :			is no record associated with a given user ID, that element of the list will be
1818 :			undefined. @userProblemIDs consists of references to arrays in which the first
1819 :			element is the user_id, the second element is the set_id, and the third element
1820 :			is the problem_id.
1821 :
1822 :			=cut
1823 :
1824 :			sub getUserProblems {
1825 :			my ($self, @userProblemIDs) = @_;
1826 :
1827 :	sh002i	1641	#croak "getUserProblems: requires 1 or more argument"
1828 :			# unless @_ >= 2;
1829 :	sh002i	1512	foreach my $i (0 .. $#userProblemIDs) {
1830 :			croak "getUserProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
1831 :			unless defined $userProblemIDs[$i]
1832 :			and ref $userProblemIDs[$i] eq "ARRAY"
1833 :			and @{$userProblemIDs[$i]} == 3
1834 :			and defined $userProblemIDs[$i]->[0]
1835 :			and defined $userProblemIDs[$i]->[1]
1836 :			and defined $userProblemIDs[$i]->[2];
1837 :			}
1838 :
1839 :	sh002i	1586	return $self->{problem_user}->gets(@userProblemIDs);
1840 :	sh002i	1512	}
1841 :
1842 :	sh002i	1668	=item getAllUserProblems($userID, $setID)
1843 :
1844 :			Returns a list of UserProblem objects representing all the problems in the
1845 :			given set. When using the WW1Hash/GlobalTableEmulator schemas, this is far
1846 :			more efficient than using listUserProblems and getUserProblems.
1847 :
1848 :			=cut
1849 :
1850 :			sub getAllUserProblems {
1851 :			my ($self, $userID, $setID) = @_;
1852 :
1853 :	sh002i	1672	croak "getAllUserProblems: requires 2 arguments"
1854 :	sh002i	1668	unless @_ == 3;
1855 :	sh002i	1672	croak "getAllUserProblems: argument 1 must contain a user_id"
1856 :	sh002i	1668	unless defined $userID;
1857 :	sh002i	1672	croak "getAllUserProblems: argument 2 must contain a set_id"
1858 :	sh002i	1668	unless defined $setID;
1859 :
1860 :			if ($self->{problem_user}->can("getAll")) {
1861 :			return $self->{problem_user}->getAll($userID, $setID);
1862 :			} else {
1863 :			my @problemIDTriples = $self->{problem_user}->list($userID, $setID, undef);
1864 :			return $self->{problem_user}->gets(@problemIDTriples);
1865 :			}
1866 :			}
1867 :
1868 :	sh002i	1641	sub putUserProblem {
1869 :	glarose	3377	my ($self, $UserProblem, $versioned) = @_;
1870 :			# $versioned is an optional argument which lets us slip versioned setIDs
1871 :			# through checkKeyfields. this makes the first croak message a little
1872 :			# disingenuous, of course.
1873 :	sh002i	1096
1874 :			croak "putUserProblem: requires 1 argument"
1875 :	glarose	3377	unless @_ == 2 or @_ == 3;
1876 :	sh002i	1096	croak "putUserProblem: argument 1 must be of type ", $self->{problem_user}->{record}
1877 :			unless ref $UserProblem eq $self->{problem_user}->{record};
1878 :	sh002i	1635
1879 :	glarose	3377	checkKeyfields($UserProblem, $versioned);
1880 :	sh002i	1635
1881 :	sh002i	1096	croak "putUserProblem: user set ", $UserProblem->set_id, " for user ", $UserProblem->user_id, " not found"
1882 :			unless $self->{set_user}->exists($UserProblem->user_id, $UserProblem->set_id);
1883 :	malsyned	1104	croak "putUserProblem: user problem not found (perhaps you meant to use addUserProblem?)"
1884 :			unless $self->{problem_user}->exists($UserProblem->user_id, $UserProblem->set_id, $UserProblem->problem_id);
1885 :	glarose	3377
1886 :			# allow versioned set names when $versioned is defined and true
1887 :			my $unversionedSetID = $UserProblem->set_id;
1888 :			$unversionedSetID =~ s/,v\d+$// if ( defined($versioned) && $versioned );
1889 :
1890 :	sh002i	1096	croak "putUserProblem: problem ", $UserProblem->problem_id, " in set ", $UserProblem->set_id, " not found"
1891 :	glarose	3377	unless $self->{problem}->exists($unversionedSetID, $UserProblem->problem_id);
1892 :	sh002i	1096
1893 :	sh002i	775	return $self->{problem_user}->put($UserProblem);
1894 :			}
1895 :
1896 :	sh002i	1641	sub deleteUserProblem {
1897 :	sh002i	775	my ($self, $userID, $setID, $problemID) = @_;
1898 :	sh002i	1096
1899 :			croak "getUserProblem: requires 3 arguments"
1900 :			unless @_ == 4;
1901 :			croak "getUserProblem: argument 1 must contain a user_id"
1902 :	sh002i	1167	unless defined $userID or caller eq __PACKAGE__;
1903 :	sh002i	1096	croak "getUserProblem: argument 2 must contain a set_id"
1904 :	sh002i	1167	unless defined $setID or caller eq __PACKAGE__;
1905 :	sh002i	1096	croak "getUserProblem: argument 3 must contain a problem_id"
1906 :	sh002i	1167	unless defined $problemID or caller eq __PACKAGE__;
1907 :	sh002i	1096
1908 :	sh002i	775	return $self->{problem_user}->delete($userID, $setID, $problemID);
1909 :			}
1910 :
1911 :	sh002i	1583	=back
1912 :
1913 :			=cut
1914 :
1915 :	sh002i	775	################################################################################
1916 :			# set+set_user functions
1917 :			################################################################################
1918 :
1919 :	sh002i	1583	=head2 Set Merging Methods
1920 :
1921 :	sh002i	1641	These functions combine a global set and a user set to create a merged set,
1922 :			which is returned. Any field that is not defined in the user set is taken from
1923 :			the global set. Merged sets have the same type as user sets.
1924 :	sh002i	1583
1925 :			=over
1926 :
1927 :			=cut
1928 :
1929 :	sh002i	1096	sub getGlobalUserSet {
1930 :			carp "getGlobalUserSet: this method is deprecated -- use getMergedSet instead";
1931 :			return shift->getMergedSet(@_);
1932 :			}
1933 :
1934 :	sh002i	1641	=item getMergedSet($userID, $setID)
1935 :
1936 :			Returns a merged set record associated with the record IDs given. If there is no
1937 :			record associated with a given record ID, the undefined value is returned.
1938 :
1939 :			=cut
1940 :
1941 :	sh002i	1096	sub getMergedSet {
1942 :	sh002i	798	my ($self, $userID, $setID) = @_;
1943 :	sh002i	1096
1944 :	gage	1541	croak "getMergedSet: requires 2 arguments"
1945 :	sh002i	1096	unless @_ == 3;
1946 :	gage	1541	croak "getMergedSet: argument 1 must contain a user_id"
1947 :	sh002i	1096	unless defined $userID;
1948 :	gage	1541	croak "getMergedSet: argument 2 must contain a set_id"
1949 :	sh002i	1096	unless defined $setID;
1950 :
1951 :	sh002i	1586	return ( $self->getMergedSets([$userID, $setID]) )[0];
1952 :	sh002i	798	}
1953 :	sh002i	775
1954 :	glarose	3377	=item getMergedVersionedSet($userID, $setID, $versionNum)
1955 :	sh002i	1512
1956 :	glarose	3377	Returns a merged set record associated with the record IDs given, for
1957 :			versioned sets. If versionNum is supplied, the that version of the set
1958 :			is returned; otherwise, the latest version is returned. If there is no
1959 :			record associated with a given record ID, the undefined value is returned.
1960 :
1961 :			Note that sid can be setid,vN, thereby specifying the version number
1962 :			explicitly. If this is the case, any specified versionNum is ignored.
1963 :
1964 :			=cut
1965 :
1966 :			sub getMergedVersionedSet {
1967 :			my ( $self, $userID, $setID, $versionNum ) = @_;
1968 :			#
1969 :			# getMergedVersionedSet( self, uid, sid [, versionNum] )
1970 :			# in: userID uid, setID sid, and optionally version number versionNum
1971 :			# out: the merged set version for the user; if versionNum is specified,
1972 :			# return that set version and otherwise the latest version. if
1973 :			# no versioned set exists for the user, return undef.
1974 :			# note that sid can be setid,vN, thereby specifying the version number
1975 :			# explicitly. if this is the case, any specified versionNum is ignored
1976 :			# we'd like to use getMergedSet to do the dirty work here, but that runs
1977 :			# into problems because we want to merge with both the template set
1978 :			# (that is, the userSet setID) and the global set
1979 :
1980 :			croak "getMergedVersionedSet: requires at least two arguments, a userID " .
1981 :			"and setID (missing setID)" if ( @_ < 3 \|\| ! defined( $setID ) );
1982 :
1983 :			my $versionedSetID = $setID;
1984 :
1985 :			if ( ( ! defined($versionNum) \|\| ! $versionNum ) && $setID !~ /,v\d+$/ ) {
1986 :			$versionNum = $self->getUserSetVersionNumber( $userID, $setID );
1987 :
1988 :			if ( ! $versionNum ) {
1989 :			return undef;
1990 :			} else {
1991 :			$versionedSetID .= ",v$versionNum";
1992 :			}
1993 :			} elsif ( defined($versionNum) && $versionNum ) {
1994 :			$versionedSetID = ($setID =~ /,v\d+$/ ? $setID : "$setID,v$versionNum");
1995 :			} else { # the last case is that $setID =~ /,v\d+$/
1996 :			$setID =~ s/,v\d+//;
1997 :			}
1998 :
1999 :			croak "getMergedVersionedSet: requires at least two arguments, a userID " .
2000 :			"and setID (missing userID)" if ( ! defined( $userID ) );
2001 :
2002 :			return ( $self->getMergedVersionedSets( [$userID, $setID,
2003 :			$versionedSetID] ) )[0];
2004 :			}
2005 :
2006 :			=item getMergedSets(@userSetIDs)
2007 :
2008 :	sh002i	1641	Return a list of merged set records associated with the record IDs given. If
2009 :			there is no record associated with a given record ID, that element of the list
2010 :			will be undefined. @userSetIDs consists of references to arrays in which the
2011 :			first element is the user_id and the second element is the set_id.
2012 :	sh002i	1512
2013 :			=cut
2014 :
2015 :	glarose	3377	# a significant amount of getMergedSets is duplicated in getMergedVersionedSets
2016 :			# below
2017 :
2018 :	gage	1541	sub getMergedSets {
2019 :	sh002i	1512	my ($self, @userSetIDs) = @_;
2020 :
2021 :	sh002i	1641	#croak "getMergedSets: requires 1 or more argument"
2022 :			# unless @_ >= 2;
2023 :	sh002i	1512	foreach my $i (0 .. $#userSetIDs) {
2024 :	gage	1541	croak "getMergedSets: element $i of argument list must contain a <user_id, set_id> pair"
2025 :	sh002i	1512	unless defined $userSetIDs[$i]
2026 :			and ref $userSetIDs[$i] eq "ARRAY"
2027 :			and @{$userSetIDs[$i]} == 2
2028 :			and defined $userSetIDs[$i]->[0]
2029 :			and defined $userSetIDs[$i]->[1];
2030 :			}
2031 :
2032 :	sh002i	1649	# a horrible, terrible hack ;)
2033 :			if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash"
2034 :	sh002i	1657	and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
2035 :			#warn __PACKAGE__.": using a terrible hack.\n";
2036 :	sh002i	3485	debug("DB: getsNoFilter start");
2037 :	sh002i	1649	my @MergedSets = $self->{set_user}->getsNoFilter(@userSetIDs);
2038 :	sh002i	3485	debug("DB: getsNoFilter end");
2039 :	sh002i	1649	return @MergedSets;
2040 :			}
2041 :
2042 :	sh002i	3485	debug("DB: getUserSets start");
2043 :	sh002i	1635	my @UserSets = $self->getUserSets(@userSetIDs); # checked
2044 :	sh002i	1583
2045 :	sh002i	3485	debug("DB: pull out set IDs start");
2046 :	sh002i	1587	my @globalSetIDs = map { $_->[1] } @userSetIDs;
2047 :	sh002i	3485	debug("DB: getGlobalSets start");
2048 :	sh002i	1635	my @GlobalSets = $self->getGlobalSets(@globalSetIDs); # checked
2049 :	sh002i	1583
2050 :	sh002i	3485	debug("DB: calc common fields start");
2051 :	sh002i	1583	my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
2052 :			my @commonFields = grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
2053 :
2054 :	sh002i	3485	debug("DB: merge start");
2055 :	sh002i	1583	for (my $i = 0; $i < @UserSets; $i++) {
2056 :			my $UserSet = $UserSets[$i];
2057 :			my $GlobalSet = $GlobalSets[$i];
2058 :	sh002i	1635	next unless defined $UserSet and defined $GlobalSet;
2059 :	sh002i	1583	foreach my $field (@commonFields) {
2060 :	sh002i	2319	#next if defined $UserSet->$field;
2061 :	sh002i	2328	# ok, now we're testing for emptiness as well as definedness.
2062 :			next if defined $UserSet->$field and $UserSet->$field ne "";
2063 :	sh002i	1583	$UserSet->$field($GlobalSet->$field);
2064 :			}
2065 :			}
2066 :	sh002i	3485	debug("DB: merge done!");
2067 :	sh002i	1583
2068 :			return @UserSets;
2069 :	sh002i	1512	}
2070 :
2071 :	glarose	3377	sub getMergedVersionedSets {
2072 :			my ($self, @userSetIDs) = @_;
2073 :
2074 :			foreach my $i (0 .. $#userSetIDs) {
2075 :			croak "getMergedSets: element $i of argument list must contain a " .
2076 :			"<user_id, set_id, versioned_set_id> triple"
2077 :			unless( defined $userSetIDs[$i]
2078 :			and ref $userSetIDs[$i] eq "ARRAY"
2079 :			and @{$userSetIDs[$i]} == 3
2080 :			and defined $userSetIDs[$i]->[0]
2081 :			and defined $userSetIDs[$i]->[1]
2082 :			and defined $userSetIDs[$i]->[2] );
2083 :			}
2084 :
2085 :			# these are [user_id, set_id] pairs
2086 :			my @nonversionedUserSetIDs = map { [$_->[0], $_->[1]] } @userSetIDs;
2087 :			# these are [user_id, versioned_set_id] pairs
2088 :			my @versionedUserSetIDs = map { [$_->[0], $_->[2]] } @userSetIDs;
2089 :
2090 :			# the following has never been tested, and probably doesn't actually work
2091 :			# will anyone every try and do gateways on a GDBM install of WeBWorK2?
2092 :			# a horrible, terrible hack ;)
2093 :			if (ref $self->{set_user} eq "WeBWorK::DB::Schema::WW1Hash"
2094 :			and ref $self->{set} eq "WeBWorK::DB::Schema::GlobalTableEmulator") {
2095 :			#warn __PACKAGE__.": using a terrible hack.\n";
2096 :	sh002i	3485	# debug("DB: getsNoFilter start");
2097 :	glarose	3377	# my @MergedSets = $self->{set_user}->getsNoFilter(@versionedUserSetIDs);
2098 :	sh002i	3485	# debug("DB: getsNoFilter end");
2099 :	glarose	3377	# return @MergedSets;
2100 :			croak 'getMergedVersionedSets: using WW1Hash DB Schema! Versioned ' .
2101 :			'sets are not supported in this context.';
2102 :			}
2103 :
2104 :			# we merge the nonversioned ("template") user sets (user_id, set_id) and
2105 :			# the global data into the versioned user sets
2106 :	sh002i	3485	debug("DB: getUserSets start (nonversioned)");
2107 :	glarose	3377	my @TemplateUserSets = $self->getUserSets(@nonversionedUserSetIDs);
2108 :	sh002i	3485	debug("DB: getUserSets start (versioned)");
2109 :	glarose	3377	# these are the actual user sets that we want to use
2110 :			my @versionedUserSets = $self->getUserSets(@versionedUserSetIDs);
2111 :
2112 :	sh002i	3485	debug("DB: pull out set IDs start");
2113 :	glarose	3377	my @globalSetIDs = map { $_->[1] } @userSetIDs;
2114 :	sh002i	3485	debug("DB: getGlobalSets start");
2115 :	glarose	3377	my @GlobalSets = $self->getGlobalSets(@globalSetIDs);
2116 :
2117 :	sh002i	3485	debug("DB: calc common fields start");
2118 :	glarose	3377	my %globalSetFields = map { $_ => 1 } $self->newGlobalSet->FIELDS;
2119 :			my @commonFields =
2120 :			grep { exists $globalSetFields{$_} } $self->newUserSet->FIELDS;
2121 :
2122 :	sh002i	3485	debug("DB: merge start");
2123 :	glarose	3377	for (my $i = 0; $i < @TemplateUserSets; $i++) {
2124 :			next unless( defined $versionedUserSets[$i] and
2125 :			(defined $TemplateUserSets[$i] or
2126 :			defined $GlobalSets[$i]) );
2127 :			foreach my $field (@commonFields) {
2128 :			next if ( defined( $versionedUserSets[$i]->$field ) &&
2129 :			$versionedUserSets[$i]->$field ne '' );
2130 :			$versionedUserSets[$i]->$field($GlobalSets[$i]->$field) if
2131 :			(defined($GlobalSets[$i]->$field) &&
2132 :			$GlobalSets[$i]->$field ne '');
2133 :			$versionedUserSets[$i]->$field($TemplateUserSets[$i]->$field)
2134 :			if (defined($TemplateUserSets[$i]) &&
2135 :			defined($TemplateUserSets[$i]->$field) &&
2136 :			$TemplateUserSets[$i]->$field ne '');
2137 :			}
2138 :			}
2139 :	sh002i	3485	debug("DB: merge done!");
2140 :	glarose	3377
2141 :			return @versionedUserSets;
2142 :			}
2143 :
2144 :	sh002i	1583	=back
2145 :	gage	1541
2146 :	sh002i	1583	=cut
2147 :	gage	1541
2148 :	sh002i	775	################################################################################
2149 :			# problem+problem_user functions
2150 :			################################################################################
2151 :
2152 :	sh002i	1583	=head2 Problem Merging Methods
2153 :
2154 :	sh002i	1641	These functions combine a global problem and a user problem to create a merged
2155 :			problem, which is returned. Any field that is not defined in the user problem is
2156 :			taken from the global problem. Merged problems have the same type as user
2157 :			problems.
2158 :	sh002i	1583
2159 :			=over
2160 :
2161 :			=cut
2162 :
2163 :	sh002i	1096	sub getGlobalUserProblem {
2164 :			carp "getGlobalUserProblem: this method is deprecated -- use getMergedProblem instead";
2165 :			return shift->getMergedProblem(@_);
2166 :			}
2167 :
2168 :	sh002i	1641	=item getMergedProblem($userID, $setID, $problemID)
2169 :
2170 :			Returns a merged problem record associated with the record IDs given. If there
2171 :			is no record associated with a given record ID, the undefined value is returned.
2172 :
2173 :			=cut
2174 :
2175 :	sh002i	1096	sub getMergedProblem {
2176 :	sh002i	798	my ($self, $userID, $setID, $problemID) = @_;
2177 :	sh002i	1096
2178 :			croak "getGlobalUserSet: requires 3 arguments"
2179 :			unless @_ == 4;
2180 :			croak "getGlobalUserSet: argument 1 must contain a user_id"
2181 :			unless defined $userID;
2182 :			croak "getGlobalUserSet: argument 2 must contain a set_id"
2183 :			unless defined $setID;
2184 :			croak "getGlobalUserSet: argument 3 must contain a problem_id"
2185 :			unless defined $problemID;
2186 :
2187 :	sh002i	1586	return ( $self->getMergedProblems([$userID, $setID, $problemID]) )[0];
2188 :	sh002i	798	}
2189 :	sh002i	775
2190 :	glarose	3377	=item getMergedVersionedProblem($userID, $setID, $setVersionID, $problemID)
2191 :
2192 :			Returns a merged problem record associated with the record IDs given, for
2193 :			versioned problem sets. If there is no record associated with a given
2194 :			record ID, the undefined value is returned.
2195 :
2196 :			=cut
2197 :
2198 :			sub getMergedVersionedProblem {
2199 :			my ($self, $userID, $setID, $setVersionID, $problemID) = @_;
2200 :
2201 :			# this exists distinct from getMergedProblem only to be able to include the
2202 :			# setVersionID
2203 :
2204 :			croak "getGlobalUserSet: requires 4 arguments"
2205 :			unless @_ == 5;
2206 :			croak "getGlobalUserSet: argument 1 must contain a user_id"
2207 :			unless defined $userID;
2208 :			croak "getGlobalUserSet: argument 2 must contain a set_id"
2209 :			unless defined $setID;
2210 :			croak "getGlobalUserSet: argument 3 must contain a versioned set_id"
2211 :			unless defined $setVersionID;
2212 :			croak "getGlobalUserSet: argument 4 must contain a problem_id"
2213 :			unless defined $problemID;
2214 :
2215 :			return ($self->getMergedVersionedProblems([$userID, $setID, $setVersionID,
2216 :			$problemID]))[0];
2217 :			}
2218 :
2219 :	sh002i	1512	=item getMergedProblems(@userProblemIDs)
2220 :
2221 :	sh002i	1641	Return a list of merged problem records associated with the record IDs given. If
2222 :			there is no record associated with a given record ID, that element of the list
2223 :			will be undefined. @userProblemIDs consists of references to arrays in which the
2224 :			first element is the user_id, the second element is the set_id, and the third
2225 :			element is the problem_id.
2226 :	sh002i	1512
2227 :			=cut
2228 :
2229 :			sub getMergedProblems {
2230 :			my ($self, @userProblemIDs) = @_;
2231 :
2232 :	sh002i	1641	#croak "getMergedProblems: requires 1 or more argument"
2233 :			# unless @_ >= 2;
2234 :	sh002i	1512	foreach my $i (0 .. $#userProblemIDs) {
2235 :			croak "getMergedProblems: element $i of argument list must contain a <user_id, set_id, problem_id> triple"
2236 :			unless defined $userProblemIDs[$i]
2237 :			and ref $userProblemIDs[$i] eq "ARRAY"
2238 :			and @{$userProblemIDs[$i]} == 3
2239 :			and defined $userProblemIDs[$i]->[0]
2240 :			and defined $userProblemIDs[$i]->[1]
2241 :			and defined $userProblemIDs[$i]->[2];
2242 :			}
2243 :
2244 :	sh002i	3485	debug("DB: getUserProblems start");
2245 :	sh002i	1635	my @UserProblems = $self->getUserProblems(@userProblemIDs); # checked
2246 :	sh002i	1583
2247 :	sh002i	3485	debug("DB: pull out set/problem IDs start");
2248 :	sh002i	1583	my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @userProblemIDs;
2249 :	sh002i	3485	debug("DB: getGlobalProblems start");
2250 :	sh002i	1635	my @GlobalProblems = $self->getGlobalProblems(@globalProblemIDs); # checked
2251 :	sh002i	1583
2252 :	sh002i	3485	debug("DB: calc common fields start");
2253 :	sh002i	1583	my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
2254 :			my @commonFields = grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
2255 :
2256 :	sh002i	3485	debug("DB: merge start");
2257 :	sh002i	1583	for (my $i = 0; $i < @UserProblems; $i++) {
2258 :			my $UserProblem = $UserProblems[$i];
2259 :			my $GlobalProblem = $GlobalProblems[$i];
2260 :	sh002i	1635	next unless defined $UserProblem and defined $GlobalProblem;
2261 :	sh002i	1583	foreach my $field (@commonFields) {
2262 :	sh002i	2105	# FIXME: WW1Hash upgrades undefined fileds to "" when creating record objects
2263 :			# Shouldn't we be testing for emptiness rather than definedness?
2264 :			# I think the spec says that if a field is EMPTY the global value is used.
2265 :	sh002i	2319	#next if defined $UserProblem->$field;
2266 :	sh002i	2328	# ok, now we're testing for emptiness as well as definedness.
2267 :			next if defined $UserProblem->$field and $UserProblem->$field ne "";
2268 :	sh002i	1583	$UserProblem->$field($GlobalProblem->$field);
2269 :			}
2270 :			}
2271 :	sh002i	3485	debug("DB: merge done!");
2272 :	sh002i	1583
2273 :			return @UserProblems;
2274 :	sh002i	1512	}
2275 :
2276 :	glarose	3377	sub getMergedVersionedProblems {
2277 :			my ($self, @userProblemIDs) = @_;
2278 :
2279 :			foreach my $i (0 .. $#userProblemIDs) {
2280 :			croak "getMergedProblems: element $i of argument list must contain a " .
2281 :			"<user_id, set_id, versioned_set_id, problem_id> quadruple"
2282 :			unless( defined $userProblemIDs[$i]
2283 :			and ref $userProblemIDs[$i] eq "ARRAY"
2284 :			and @{$userProblemIDs[$i]} == 4
2285 :			and defined $userProblemIDs[$i]->[0]
2286 :			and defined $userProblemIDs[$i]->[1]
2287 :			and defined $userProblemIDs[$i]->[2]
2288 :			and defined $userProblemIDs[$i]->[3] );
2289 :			}
2290 :
2291 :	sh002i	3485	debug("DB: getUserProblems start");
2292 :	glarose	3377
2293 :			# these are triples [user_id, set_id, problem_id]
2294 :			my @nonversionedProblemIDs = map {[$_->[0],$_->[1],$_->[3]]} @userProblemIDs;
2295 :			# these are triples [user_id, versioned_set_id, problem_id]
2296 :			my @versionedProblemIDs = map {[$_->[0],$_->[2],$_->[3]]} @userProblemIDs;
2297 :
2298 :			# these are the actual user problems for the version
2299 :			my @versionUserProblems = $self->getUserProblems(@versionedProblemIDs);
2300 :
2301 :			# get global problems (no user_id, set_id = nonversioned set_id) and
2302 :			# template problems (user_id, set_id = nonversioned set_id); we merge with
2303 :			# both of these, replacing global values with template values and not
2304 :			# taking either in the event that the versioned problem already has a
2305 :			# value for the field in question
2306 :	sh002i	3485	debug("DB: pull out set/problem IDs start");
2307 :	glarose	3377	my @globalProblemIDs = map { [ $_->[1], $_->[2] ] } @nonversionedProblemIDs;
2308 :	sh002i	3485	debug("DB: getGlobalProblems start");
2309 :	glarose	3377	my @GlobalProblems = $self->getGlobalProblems( @globalProblemIDs );
2310 :	sh002i	3485	debug("DB: getTemplateProblems start");
2311 :	glarose	3377	my @TemplateProblems = $self->getUserProblems( @nonversionedProblemIDs );
2312 :
2313 :	sh002i	3485	debug("DB: calc common fields start");
2314 :	glarose	3377
2315 :			my %globalProblemFields = map { $_ => 1 } $self->newGlobalProblem->FIELDS;
2316 :			my @commonFields =
2317 :			grep { exists $globalProblemFields{$_} } $self->newUserProblem->FIELDS;
2318 :
2319 :	sh002i	3485	debug("DB: merge start");
2320 :	glarose	3377	for (my $i = 0; $i < @versionUserProblems; $i++) {
2321 :			my $UserProblem = $versionUserProblems[$i];
2322 :			my $GlobalProblem = $GlobalProblems[$i];
2323 :			my $TemplateProblem = $TemplateProblems[$i];
2324 :			next unless defined $UserProblem and ( defined $GlobalProblem or
2325 :			defined $TemplateProblem );
2326 :			foreach my $field (@commonFields) {
2327 :			next if defined $UserProblem->$field && $UserProblem->$field ne '';
2328 :			$UserProblem->$field($GlobalProblem->$field)
2329 :			if ( defined($GlobalProblem) && defined($GlobalProblem->$field)
2330 :			&& $GlobalProblem->$field ne '' );
2331 :			$UserProblem->$field($TemplateProblem->$field)
2332 :			if ( defined($TemplateProblem) &&
2333 :			defined($TemplateProblem->$field) &&
2334 :			$TemplateProblem->$field ne '' );
2335 :			}
2336 :			}
2337 :	sh002i	3485	debug("DB: merge done!");
2338 :	glarose	3377
2339 :			return @versionUserProblems;
2340 :			}
2341 :
2342 :	sh002i	1583	=back
2343 :
2344 :			=cut
2345 :
2346 :	sh002i	808	################################################################################
2347 :			# debugging
2348 :			################################################################################
2349 :
2350 :	sh002i	1583	#sub dumpDB($$) {
2351 :			# my ($self, $table) = @_;
2352 :			# return $self->{$table}->dumpDB();
2353 :			#}
2354 :	sh002i	808
2355 :	sh002i	1199	################################################################################
2356 :	sh002i	1635	# utilities
2357 :	sh002i	1199	################################################################################
2358 :
2359 :	glarose	3377	# the (optional) second argument to checkKeyfields is to support versioned
2360 :			# (gateway) sets, which may include commas in certain fields (in particular,
2361 :			# set names (e.g., setDerivativeGateway,v1) and user names (e.g.,
2362 :			# username,proctorname)
2363 :
2364 :			sub checkKeyfields($;$) {
2365 :			my ($Record, $versioned) = @_;
2366 :	sh002i	1199	foreach my $keyfield ($Record->KEYFIELDS) {
2367 :	sh002i	1226	my $value = $Record->$keyfield;
2368 :			croak "checkKeyfields: $keyfield is empty"
2369 :			unless defined $value and $value ne "";
2370 :	sh002i	1635
2371 :	sh002i	1226	if ($keyfield eq "problem_id") {
2372 :			croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [0-9])"
2373 :			unless $value =~ m/^\d*$/;
2374 :			} else {
2375 :	gage	3052	croak "checkKeyfields: invalid characters in $keyfield field: $value (valid characters are [A-Za-z0-9_.])"
2376 :	glarose	3377	# unless $value =~ m/^[.\w\-]*$/;
2377 :	jj	3398	unless ( $value =~ m/^[.\w-]*$/ \|\|
2378 :	glarose	3377	( $value =~ m/^[\w,-]*$/ &&
2379 :			(defined($versioned) && $versioned)
2380 :			&&
2381 :			($keyfield eq "set_id" \|\|
2382 :			$keyfield eq "user_id") ) );
2383 :	sh002i	1226	}
2384 :	sh002i	1199	}
2385 :			}
2386 :
2387 :	sh002i	1012	=head1 AUTHOR
2388 :
2389 :			Written by Sam Hathaway, sh002i (at) math.rochester.edu.
2390 :
2391 :	sh002i	1035	=cut
2392 :	gage	1023
2393 :	sh002i	775	1;

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9