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

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

 Legend:



Removed from v.1012
 


changed lines


 
Added in v.2105
 Legend:



Removed from v.1012
 


changed lines


 
Added in v.2105
-Removed from v.1012
+Added in v.2105

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9