Diff of /trunk/webwork2/lib/WeBWorK/DB.pm

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

 Legend:



Removed from v.916
 


changed lines


 
Added in v.1696
 Legend:



Removed from v.916
 


changed lines


 
Added in v.1696
-Removed from v.916
+Added in v.1696

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9