Annotation of /branches/rel-2-4-patches/webwork-modperl/lib/WeBWorK/ContentGenerator/CourseAdmin.pm

Revision 4918 - (view) (download) (as text)
Original Path: trunk/webwork-modperl/lib/WeBWorK/ContentGenerator/CourseAdmin.pm

1 :	sh002i	1945	################################################################################
2 :			# WeBWorK Online Homework Delivery System
3 :	sh002i	3973	# Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/
4 :	glarose	4918	# $CVSHeader: webwork2/lib/WeBWorK/ContentGenerator/CourseAdmin.pm,v 1.63 2007/03/30 14:21:14 glarose Exp $
5 :	sh002i	1945	#
6 :			# This program is free software; you can redistribute it and/or modify it under
7 :			# the terms of either: (a) the GNU General Public License as published by the
8 :			# Free Software Foundation; either version 2, or (at your option) any later
9 :			# version, or (b) the "Artistic License" which comes with this package.
10 :			#
11 :			# This program is distributed in the hope that it will be useful, but WITHOUT
12 :			# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
13 :			# FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the
14 :			# Artistic License for more details.
15 :			################################################################################
16 :
17 :			package WeBWorK::ContentGenerator::CourseAdmin;
18 :			use base qw(WeBWorK::ContentGenerator);
19 :
20 :			=head1 NAME
21 :
22 :			WeBWorK::ContentGenerator::CourseAdmin - Add, rename, and delete courses.
23 :
24 :			=cut
25 :
26 :			use strict;
27 :			use warnings;
28 :	gage	4235	#use CGI qw(-nosticky );
29 :			use WeBWorK::CGI;
30 :	glarose	4910	use Data::Dumper;
31 :	sh002i	1985	use File::Temp qw/tempfile/;
32 :	sh002i	2138	use WeBWorK::CourseEnvironment;
33 :	gage	3235	use IO::File;
34 :	sh002i	4087	use WeBWorK::Debug;
35 :	gage	3235	use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive);
36 :	gage	4129	use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse
37 :			listArchivedCourses unarchiveCourse);
38 :	sh002i	1985	use WeBWorK::Utils::DBImportExport qw(dbExport dbImport);
39 :	glarose	4910	# needed for location management
40 :			use Net::IP;
41 :	sh002i	1945
42 :	sh002i	4312	use constant IMPORT_EXPORT_WARNING => "The ability to import and export
43 :			databases is still under development. It seems to work but it is <b>VERY</b>
44 :			slow on large courses. You may prefer to use webwork2/bin/wwdb or the mysql
45 :			dump facility for archiving large courses. Please send bug reports if you find
46 :			errors.";
47 :
48 :	sh002i	1985	sub pre_header_initialize {
49 :			my ($self) = @_;
50 :			my $r = $self->r;
51 :			my $ce = $r->ce;
52 :			my $db = $r->db;
53 :			my $authz = $r->authz;
54 :			my $urlpath = $r->urlpath;
55 :	gage	2026	my $user = $r->param('user');
56 :	sh002i	1985
57 :	gage	2026	# check permissions
58 :			unless ($authz->hasPermissions($user, "create_and_delete_courses")) {
59 :			$self->addmessage( CGI::div({class=>'ResultsWithError'},"$user is not authorized to create or delete courses") );
60 :			return;
61 :			}
62 :	sh002i	1945
63 :	gage	3284	# get result and send to message
64 :			my $status_message = $r->param("status_message");
65 :			$self->addmessage(CGI::p("$status_message")) if $status_message;
66 :
67 :	sh002i	2478	## if the user is asking for the downloaded database...
68 :			#if (defined $r->param("download_exported_database")) {
69 :			# my $courseID = $r->param("export_courseID");
70 :			# my $random_chars = $r->param("download_exported_database");
71 :			#
72 :			# die "courseID not specified" unless defined $courseID;
73 :			# die "invalid file specification" unless $random_chars =~ m/^\w+$/;
74 :			#
75 :			# my $tempdir = $ce->{webworkDirs}->{tmp};
76 :			# my $export_file = "$tempdir/db_export_$random_chars";
77 :			#
78 :			# $self->reply_with_file("application/xml", $export_file, "${courseID}_database.xml", 0);
79 :			#
80 :			# return "";
81 :			#}
82 :			#
83 :			## otherwise...
84 :	gage	2026
85 :	sh002i	2478	my @errors;
86 :			my $method_to_call;
87 :	gage	2026
88 :	sh002i	1960	my $subDisplay = $r->param("subDisplay");
89 :			if (defined $subDisplay) {
90 :	sh002i	1945
91 :	sh002i	1960	if ($subDisplay eq "add_course") {
92 :			if (defined $r->param("add_course")) {
93 :	sh002i	2478	@errors = $self->add_course_validate;
94 :	sh002i	1960	if (@errors) {
95 :	sh002i	2478	$method_to_call = "add_course_form";
96 :	sh002i	1960	} else {
97 :	sh002i	2478	$method_to_call = "do_add_course";
98 :	sh002i	1960	}
99 :			} else {
100 :	sh002i	2478	$method_to_call = "add_course_form";
101 :	sh002i	1960	}
102 :			}
103 :
104 :	sh002i	3059	elsif ($subDisplay eq "rename_course") {
105 :			if (defined $r->param("rename_course")) {
106 :			@errors = $self->rename_course_validate;
107 :			if (@errors) {
108 :			$method_to_call = "rename_course_form";
109 :			} else {
110 :			$method_to_call = "do_rename_course";
111 :			}
112 :			} else {
113 :			$method_to_call = "rename_course_form";
114 :			}
115 :			}
116 :
117 :	sh002i	1960	elsif ($subDisplay eq "delete_course") {
118 :			if (defined $r->param("delete_course")) {
119 :			# validate or confirm
120 :	sh002i	2478	@errors = $self->delete_course_validate;
121 :	sh002i	1960	if (@errors) {
122 :	sh002i	2478	$method_to_call = "delete_course_form";
123 :	sh002i	1960	} else {
124 :	sh002i	2478	$method_to_call = "delete_course_confirm";
125 :	sh002i	1960	}
126 :			} elsif (defined $r->param("confirm_delete_course")) {
127 :			# validate and delete
128 :	sh002i	2478	@errors = $self->delete_course_validate;
129 :	sh002i	1960	if (@errors) {
130 :	sh002i	2478	$method_to_call = "delete_course_form";
131 :	sh002i	1960	} else {
132 :	sh002i	2478	$method_to_call = "do_delete_course";
133 :	sh002i	1960	}
134 :			} else {
135 :			# form only
136 :	sh002i	2478	$method_to_call = "delete_course_form";
137 :	sh002i	1960	}
138 :			}
139 :
140 :	sh002i	1985	elsif ($subDisplay eq "export_database") {
141 :			if (defined $r->param("export_database")) {
142 :	sh002i	2478	@errors = $self->export_database_validate;
143 :	sh002i	1985	if (@errors) {
144 :	sh002i	2478	$method_to_call = "export_database_form";
145 :	sh002i	1985	} else {
146 :	sh002i	2478	# we have to do something special here, since we're sending
147 :			# the database as we export it. $method_to_call still gets
148 :			# set here, but it gets caught by header() and content()
149 :			# below instead of by body().
150 :			$method_to_call = "do_export_database";
151 :	sh002i	1985	}
152 :			} else {
153 :	sh002i	2478	$method_to_call = "export_database_form";
154 :	sh002i	1985	}
155 :			}
156 :
157 :			elsif ($subDisplay eq "import_database") {
158 :			if (defined $r->param("import_database")) {
159 :	sh002i	2478	@errors = $self->import_database_validate;
160 :	sh002i	1985	if (@errors) {
161 :	sh002i	2478	$method_to_call = "import_database_form";
162 :	sh002i	1985	} else {
163 :	sh002i	2478	$method_to_call = "do_import_database";
164 :	sh002i	1985	}
165 :			} else {
166 :	sh002i	2478	$method_to_call = "import_database_form";
167 :	sh002i	1985	}
168 :			}
169 :
170 :	gage	3528	elsif ($subDisplay eq "archive_course") {
171 :			if (defined $r->param("archive_course")) {
172 :			# validate or confirm
173 :			@errors = $self->archive_course_validate;
174 :			if (@errors) {
175 :			$method_to_call = "archive_course_form";
176 :			} else {
177 :			$method_to_call = "archive_course_confirm";
178 :			}
179 :			} elsif (defined $r->param("confirm_archive_course")) {
180 :			# validate and archive
181 :			@errors = $self->archive_course_validate;
182 :			if (@errors) {
183 :			$method_to_call = "archive_course_form";
184 :			} else {
185 :			$method_to_call = "do_archive_course";
186 :			}
187 :			} else {
188 :			# form only
189 :			$method_to_call = "archive_course_form";
190 :			}
191 :			}
192 :	gage	4129	elsif ($subDisplay eq "unarchive_course") {
193 :			if (defined $r->param("unarchive_course")) {
194 :			# validate or confirm
195 :			@errors = $self->unarchive_course_validate;
196 :			if (@errors) {
197 :			$method_to_call = "unarchive_course_form";
198 :			} else {
199 :			$method_to_call = "unarchive_course_confirm";
200 :			}
201 :			} elsif (defined $r->param("confirm_unarchive_course")) {
202 :			# validate and archive
203 :			@errors = $self->unarchive_course_validate;
204 :			if (@errors) {
205 :			$method_to_call = "unarchive_course_form";
206 :			} else {
207 :			$method_to_call = "do_unarchive_course";
208 :			}
209 :			} else {
210 :			# form only
211 :			$method_to_call = "unarchive_course_form";
212 :			}
213 :			}
214 :	glarose	4910	elsif ($subDisplay eq "manage_locations") {
215 :			if (defined ($r->param("manage_location_action"))) {
216 :			$method_to_call =
217 :			$r->param("manage_location_action");
218 :			}
219 :			else{
220 :			$method_to_call = "manage_location_form";
221 :			}
222 :			}
223 :	sh002i	1985	else {
224 :	sh002i	2478	@errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}.";
225 :	sh002i	1985	}
226 :	sh002i	1960	}
227 :	sh002i	1945
228 :	sh002i	2478	$self->{errors} = \@errors;
229 :			$self->{method_to_call} = $method_to_call;
230 :			}
231 :
232 :			sub header {
233 :			my ($self) = @_;
234 :			my $method_to_call = $self->{method_to_call};
235 :	gage	3235	# if (defined $method_to_call and $method_to_call eq "do_export_database") {
236 :			# my $r = $self->r;
237 :			# my $courseID = $r->param("export_courseID");
238 :			# $r->content_type("application/octet-stream");
239 :			# $r->header_out("Content-Disposition" => "attachment; filename=\"${courseID}_database.xml\"");
240 :			# $r->send_http_header;
241 :			# } else {
242 :	sh002i	2478	$self->SUPER::header;
243 :	gage	3235	# }
244 :	sh002i	2478	}
245 :
246 :			# sends:
247 :	sh002i	2479	#
248 :	sh002i	2478	# HTTP/1.1 200 OK
249 :			# Date: Fri, 09 Jul 2004 19:05:55 GMT
250 :			# Server: Apache/1.3.27 (Unix) mod_perl/1.27
251 :			# Content-Disposition: attachment; filename="mth143_database.xml"
252 :			# Connection: close
253 :			# Content-Type: application/octet-stream
254 :
255 :			sub content {
256 :			my ($self) = @_;
257 :			my $method_to_call = $self->{method_to_call};
258 :			if (defined $method_to_call and $method_to_call eq "do_export_database") {
259 :	gage	3235	#$self->do_export_database;
260 :			$self->SUPER::content;
261 :	sh002i	2478	} else {
262 :			$self->SUPER::content;
263 :			}
264 :			}
265 :
266 :			sub body {
267 :			my ($self) = @_;
268 :			my $r = $self->r;
269 :			my $ce = $r->ce;
270 :			my $db = $r->db;
271 :			my $authz = $r->authz;
272 :			my $urlpath = $r->urlpath;
273 :
274 :			my $user = $r->param('user');
275 :
276 :			# check permissions
277 :			unless ($authz->hasPermissions($user, "create_and_delete_courses")) {
278 :			return "";
279 :			}
280 :	gage	3235	my $method_to_call = $self->{method_to_call};
281 :			my $methodMessage ="";
282 :	sh002i	2478
283 :	gage	3235	(defined($method_to_call) and $method_to_call eq "do_export_database") && do {
284 :			my @export_courseID = $r->param("export_courseID");
285 :			my $course_ids = join(", ", @export_courseID);
286 :			$methodMessage = CGI::p("Exporting database for course(s) $course_ids").
287 :			CGI::p(".... please wait....
288 :			If your browser times out you will
289 :			still be able to download the exported database using the
290 :			file manager.").CGI::hr();
291 :			};
292 :
293 :
294 :	sh002i	2478	print CGI::p({style=>"text-align: center"},
295 :	gage	3437	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"add_course",add_admin_users=>1,
296 :			add_dbLayout=>'sql_single',
297 :			add_templates_course => $ce->{siteDefaults}->{default_templates_course} \|\|""}
298 :			)},
299 :			"Add Course"
300 :			),
301 :	sh002i	2478	" \| ",
302 :	sh002i	3059	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"rename_course"})}, "Rename Course"),
303 :			" \| ",
304 :	sh002i	2478	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"delete_course"})}, "Delete Course"),
305 :			" \| ",
306 :			CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"export_database"})}, "Export Database"),
307 :			" \| ",
308 :			CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"),
309 :	gage	3528	" \| ",
310 :			CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"archive_course"})}, "Archive Course"),
311 :	gage	4129	"\|",
312 :			CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"unarchive_course"})}, "Unarchive Course"),
313 :	glarose	4910	"\|",
314 :			CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"manage_locations"})}, "Manage Locations"),
315 :	gage	3235	CGI::hr(),
316 :			$methodMessage,
317 :
318 :	sh002i	2478	);
319 :
320 :			my @errors = @{$self->{errors}};
321 :
322 :	gage	3235
323 :	sh002i	2478	if (@errors) {
324 :			print CGI::div({class=>"ResultsWithError"},
325 :			CGI::p("Please correct the following errors and try again:"),
326 :			CGI::ul(CGI::li(\@errors)),
327 :			);
328 :			}
329 :
330 :			if (defined $method_to_call and $method_to_call ne "") {
331 :			$self->$method_to_call;
332 :	gage	3434	} else {
333 :
334 :			print CGI::h2("Courses");
335 :
336 :	gage	3435	print CGI::start_ol();
337 :	gage	3434
338 :			my @courseIDs = listCourses($ce);
339 :			foreach my $courseID (sort {lc($a) cmp lc($b) } @courseIDs) {
340 :			next if $courseID eq "admin"; # done already above
341 :			my $urlpath = $r->urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets", courseID => $courseID);
342 :			my $tempCE = WeBWorK::CourseEnvironment->new(
343 :			$ce->{webworkDirs}->{root},
344 :			$ce->{webworkURLs}->{root},
345 :			$ce->{pg}->{directories}->{root},
346 :			$courseID,
347 :			);
348 :			print CGI::li(CGI::a({href=>$self->systemLink($urlpath, authen => 0)}, $courseID),
349 :			CGI::code(
350 :			$tempCE->{dbLayoutName},
351 :			),
352 :			(-r $tempCE->{courseFiles}->{environment}) ? "" : CGI::i(", missing course.conf"),
353 :
354 :			);
355 :
356 :			}
357 :
358 :	gage	3435	print CGI::end_ol();
359 :	gage	4129
360 :			print CGI::h2("Archived Courses");
361 :			print CGI::start_ol();
362 :
363 :			@courseIDs = listArchivedCourses($ce);
364 :			foreach my $courseID (sort {lc($a) cmp lc($b) } @courseIDs) {
365 :			print CGI::li($courseID),
366 :			}
367 :
368 :			print CGI::end_ol();
369 :	sh002i	2478	}
370 :	sh002i	1960	return "";
371 :			}
372 :
373 :	sh002i	1985	################################################################################
374 :
375 :	sh002i	1960	sub add_course_form {
376 :			my ($self) = @_;
377 :			my $r = $self->r;
378 :			my $ce = $r->ce;
379 :			#my $db = $r->db;
380 :			#my $authz = $r->authz;
381 :			#my $urlpath = $r->urlpath;
382 :	sh002i	1945
383 :	gage	2254	my $add_courseID = $r->param("add_courseID") \|\| "";
384 :	sh002i	2378	my $add_courseTitle = $r->param("add_courseTitle") \|\| "";
385 :			my $add_courseInstitution = $r->param("add_courseInstitution") \|\| "";
386 :
387 :			my $add_admin_users = $r->param("add_admin_users") \|\| "";
388 :
389 :			my $add_initial_userID = $r->param("add_initial_userID") \|\| "";
390 :			my $add_initial_password = $r->param("add_initial_password") \|\| "";
391 :			my $add_initial_confirmPassword = $r->param("add_initial_confirmPassword") \|\| "";
392 :			my $add_initial_firstName = $r->param("add_initial_firstName") \|\| "";
393 :			my $add_initial_lastName = $r->param("add_initial_lastName") \|\| "";
394 :			my $add_initial_email = $r->param("add_initial_email") \|\| "";
395 :
396 :			my $add_templates_course = $r->param("add_templates_course") \|\| "";
397 :
398 :	gage	2254	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";
399 :	sh002i	1945
400 :	sh002i	2639	my @dbLayouts = do {
401 :			my @ordered_layouts;
402 :	sh002i	4087	foreach my $layout (@{$ce->{dbLayout_order}}) {
403 :	sh002i	2639	if (exists $ce->{dbLayouts}->{$layout}) {
404 :			push @ordered_layouts, $layout;
405 :			}
406 :			}
407 :
408 :			my %ordered_layouts; @ordered_layouts{@ordered_layouts} = ();
409 :			my @other_layouts;
410 :			foreach my $layout (keys %{ $ce->{dbLayouts} }) {
411 :			unless (exists $ordered_layouts{$layout}) {
412 :			push @other_layouts, $layout;
413 :			}
414 :			}
415 :
416 :			(@ordered_layouts, @other_layouts);
417 :			};
418 :	sh002i	1960
419 :			my $ce2 = WeBWorK::CourseEnvironment->new(
420 :			$ce->{webworkDirs}->{root},
421 :			$ce->{webworkURLs}->{root},
422 :			$ce->{pg}->{directories}->{root},
423 :			"COURSENAME",
424 :			);
425 :
426 :	sh002i	2378	my @existingCourses = listCourses($ce);
427 :	gage	3434	@existingCourses = sort { lc($a) cmp lc ($b) } @existingCourses; #make sort case insensitive
428 :	sh002i	2148
429 :	sh002i	1960	print CGI::h2("Add Course");
430 :	sh002i	1945
431 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
432 :	sh002i	1960	print $self->hidden_authen_fields;
433 :			print $self->hidden_fields("subDisplay");
434 :	sh002i	1945
435 :	sh002i	2378	print CGI::p("Specify an ID, title, and institution for the new course. The course ID may contain only letters, numbers, hyphens, and underscores.");
436 :	sh002i	1960
437 :			print CGI::table({class=>"FormLayout"},
438 :	gage	4280	CGI::Tr({},
439 :	gage	2242	CGI::th({class=>"LeftHeader"}, "Course ID:"),
440 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_courseID", -value=>$add_courseID, -size=>25)),
441 :	sh002i	1960	),
442 :	gage	4280	CGI::Tr({},
443 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "Course Title:"),
444 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_courseTitle", -value=>$add_courseTitle, -size=>25)),
445 :	gage	2242	),
446 :	gage	4280	CGI::Tr({},
447 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "Institution:"),
448 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_courseInstitution", -value=>$add_courseInstitution, -size=>25)),
449 :	gage	2242	),
450 :	sh002i	2378	);
451 :
452 :			print CGI::p("To add the WeBWorK administrators to the new course (as instructors) check the box below.");
453 :	gage	4246	my @checked = ($add_admin_users) ?(checked=>1): (); # workaround because CGI::checkbox seems to have a bug -- it won't default to checked.
454 :	gage	4280	print CGI::p({},CGI::input({-type=>'checkbox', -name=>"add_admin_users", @checked }, "Add WeBWorK administrators to new course"));
455 :	sh002i	2378
456 :	gage	4127	print CGI::p("To add an additional instructor to the new course, specify user information below. The user ID may contain only
457 :			numbers, letters, hyphens, periods (dots), commas,and underscores.\n");
458 :	sh002i	2378
459 :	gage	4280	print CGI::table({class=>"FormLayout"}, CGI::Tr({},
460 :			CGI::td({},
461 :	sh002i	2378	CGI::table({class=>"FormLayout"},
462 :	gage	4280	CGI::Tr({},
463 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "User ID:"),
464 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_initial_userID", -value=>$add_initial_userID, -size=>25)),
465 :	sh002i	2378	),
466 :	gage	4280	CGI::Tr({},
467 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "Password:"),
468 :	gage	4244	CGI::td(CGI::password_field(-name=>"add_initial_password", -value=>$add_initial_password, -size=>25)),
469 :	sh002i	2378	),
470 :	gage	4280	CGI::Tr({},
471 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "Confirm Password:"),
472 :	gage	4244	CGI::td(CGI::password_field(-name=>"add_initial_confirmPassword", -value=>$add_initial_confirmPassword, -size=>25)),
473 :	sh002i	2378	),
474 :			),
475 :	gage	2299	),
476 :	gage	4280	CGI::td({},
477 :	sh002i	2378	CGI::table({class=>"FormLayout"},
478 :	gage	4280	CGI::Tr({},
479 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "First Name:"),
480 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_initial_firstName", -value=>$add_initial_firstName, -size=>25)),
481 :	sh002i	2378	),
482 :	gage	4280	CGI::Tr({},
483 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "Last Name:"),
484 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_initial_lastName", -value=>$add_initial_lastName, -size=>25)),
485 :	sh002i	2378	),
486 :	gage	4280	CGI::Tr({},
487 :	sh002i	2378	CGI::th({class=>"LeftHeader"}, "Email Address:"),
488 :	gage	4244	CGI::td(CGI::textfield(-name=>"add_initial_email", -value=>$add_initial_email, -size=>25)),
489 :	sh002i	2378	),
490 :			),
491 :	gage	2242
492 :			),
493 :	sh002i	2378	));
494 :	gage	2254
495 :	sh002i	2378	print CGI::p("To copy problem templates from an existing course, select the course below.");
496 :	gage	2254
497 :			print CGI::table({class=>"FormLayout"},
498 :	gage	4280	CGI::Tr({},
499 :	gage	2254	CGI::th({class=>"LeftHeader"}, "Copy templates from:"),
500 :			CGI::td(
501 :			CGI::popup_menu(
502 :			-name => "add_templates_course",
503 :			-values => [ "", @existingCourses ],
504 :			-default => $add_templates_course,
505 :			#-size => 10,
506 :			#-multiple => 0,
507 :			#-labels => \%courseLabels,
508 :			),
509 :
510 :			),
511 :			),
512 :			);
513 :
514 :	sh002i	4357
515 :
516 :	sh002i	2378	print CGI::p("Select a database layout below.");
517 :	gage	4295	print CGI::start_table({class=>"FormLayout"});
518 :	sh002i	4357
519 :			my %dbLayout_buttons;
520 :			my $selected_dbLayout = defined $add_dbLayout ? $add_dbLayout : $ce->{dbLayout_order}[0];
521 :			@dbLayout_buttons{@dbLayouts} = CGI::radio_group(-name=>"add_dbLayout",-values=>\@dbLayouts,-default=>$selected_dbLayout);
522 :	sh002i	1960	foreach my $dbLayout (@dbLayouts) {
523 :	sh002i	4087	my $dbLayoutLabel = (defined $ce->{dbLayout_descr}{$dbLayout})
524 :			? "$dbLayout - " . $ce->{dbLayout_descr}{$dbLayout}
525 :	gage	4295	: "$dbLayout - no description provided in global.conf";
526 :	gage	4280	print CGI::Tr({},
527 :	sh002i	4357	CGI::td({width=>'20%'}, $dbLayout_buttons{$dbLayout}),
528 :	sh002i	2639	CGI::td($dbLayoutLabel),
529 :	sh002i	1945	);
530 :			}
531 :	gage	4295	print CGI::end_table();
532 :			print CGI::p({style=>"text-align: left"}, CGI::submit(-name=>"add_course", -label=>"Add Course"));
533 :	sh002i	1945
534 :	sh002i	1960	print CGI::end_form();
535 :			}
536 :
537 :			sub add_course_validate {
538 :			my ($self) = @_;
539 :			my $r = $self->r;
540 :			my $ce = $r->ce;
541 :			#my $db = $r->db;
542 :			#my $authz = $r->authz;
543 :			#my $urlpath = $r->urlpath;
544 :
545 :	gage	2254	my $add_courseID = $r->param("add_courseID") \|\| "";
546 :	sh002i	2378	my $add_courseTitle = $r->param("add_courseTitle") \|\| "";
547 :			my $add_courseInstitution = $r->param("add_courseInstitution") \|\| "";
548 :
549 :			my $add_admin_users = $r->param("add_admin_users") \|\| "";
550 :
551 :			my $add_initial_userID = $r->param("add_initial_userID") \|\| "";
552 :			my $add_initial_password = $r->param("add_initial_password") \|\| "";
553 :			my $add_initial_confirmPassword = $r->param("add_initial_confirmPassword") \|\| "";
554 :			my $add_initial_firstName = $r->param("add_initial_firstName") \|\| "";
555 :			my $add_initial_lastName = $r->param("add_initial_lastName") \|\| "";
556 :			my $add_initial_email = $r->param("add_initial_email") \|\| "";
557 :
558 :			my $add_templates_course = $r->param("add_templates_course") \|\| "";
559 :
560 :	gage	2254	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";
561 :	sh002i	2378
562 :	sh002i	1960	my @errors;
563 :
564 :			if ($add_courseID eq "") {
565 :	sh002i	2378	push @errors, "You must specify a course ID.";
566 :	sh002i	1960	}
567 :	sh002i	2887	unless ($add_courseID =~ /^[\w-]*$/) { # regex copied from CourseAdministration.pm
568 :			push @errors, "Course ID may only contain letters, numbers, hyphens, and underscores.";
569 :			}
570 :	sh002i	2373	if (grep { $add_courseID eq $_ } listCourses($ce)) {
571 :	sh002i	2378	push @errors, "A course with ID $add_courseID already exists.";
572 :	sh002i	2373	}
573 :	sh002i	4377	#if ($add_courseTitle eq "") {
574 :			# push @errors, "You must specify a course title.";
575 :			#}
576 :			#if ($add_courseInstitution eq "") {
577 :			# push @errors, "You must specify an institution for this course.";
578 :			#}
579 :	sh002i	2378
580 :			if ($add_initial_userID ne "") {
581 :			if ($add_initial_password eq "") {
582 :			push @errors, "You must specify a password for the initial instructor.";
583 :			}
584 :			if ($add_initial_confirmPassword eq "") {
585 :			push @errors, "You must confirm the password for the initial instructor.";
586 :			}
587 :			if ($add_initial_password ne $add_initial_confirmPassword) {
588 :			push @errors, "The password and password confirmation for the instructor must match.";
589 :			}
590 :			if ($add_initial_firstName eq "") {
591 :			push @errors, "You must specify a first name for the initial instructor.";
592 :			}
593 :			if ($add_initial_lastName eq "") {
594 :			push @errors, "You must specify a last name for the initial instructor.";
595 :			}
596 :			if ($add_initial_email eq "") {
597 :			push @errors, "You must specify an email address for the initial instructor.";
598 :			}
599 :	gage	2242	}
600 :	sh002i	1960
601 :			if ($add_dbLayout eq "") {
602 :			push @errors, "You must select a database layout.";
603 :			} else {
604 :			if (exists $ce->{dbLayouts}->{$add_dbLayout}) {
605 :	sh002i	4357	# we used to check for layout-specific fields here, but there aren't any layouts that require them
606 :			# anymore. (in the future, we'll probably deal with this in layout-specific modules.)
607 :	sh002i	1960	} else {
608 :			push @errors, "The database layout $add_dbLayout doesn't exist.";
609 :			}
610 :			}
611 :
612 :			return @errors;
613 :			}
614 :
615 :			sub do_add_course {
616 :			my ($self) = @_;
617 :			my $r = $self->r;
618 :			my $ce = $r->ce;
619 :			my $db = $r->db;
620 :	gage	4127	my $authz = $r->authz;
621 :	sh002i	1960	my $urlpath = $r->urlpath;
622 :
623 :	sh002i	2378	my $add_courseID = $r->param("add_courseID") \|\| "";
624 :			my $add_courseTitle = $r->param("add_courseTitle") \|\| "";
625 :			my $add_courseInstitution = $r->param("add_courseInstitution") \|\| "";
626 :
627 :			my $add_admin_users = $r->param("add_admin_users") \|\| "";
628 :
629 :			my $add_initial_userID = $r->param("add_initial_userID") \|\| "";
630 :			my $add_initial_password = $r->param("add_initial_password") \|\| "";
631 :			my $add_initial_confirmPassword = $r->param("add_initial_confirmPassword") \|\| "";
632 :			my $add_initial_firstName = $r->param("add_initial_firstName") \|\| "";
633 :			my $add_initial_lastName = $r->param("add_initial_lastName") \|\| "";
634 :			my $add_initial_email = $r->param("add_initial_email") \|\| "";
635 :
636 :			my $add_templates_course = $r->param("add_templates_course") \|\| "";
637 :
638 :			my $add_dbLayout = $r->param("add_dbLayout") \|\| "";
639 :	gage	2242
640 :	sh002i	1960	my $ce2 = WeBWorK::CourseEnvironment->new(
641 :			$ce->{webworkDirs}->{root},
642 :			$ce->{webworkURLs}->{root},
643 :			$ce->{pg}->{directories}->{root},
644 :			$add_courseID,
645 :			);
646 :
647 :	gage	2042	my %courseOptions = ( dbLayoutName => $add_dbLayout );
648 :	sh002i	2384
649 :			if ($add_initial_email ne "") {
650 :			$courseOptions{allowedRecipients} = [ $add_initial_email ];
651 :	sh002i	2853	# don't set feedbackRecipients -- this just gets in the way of the more
652 :			# intelligent "receive_recipients" method.
653 :			#$courseOptions{feedbackRecipients} = [ $add_initial_email ];
654 :	sh002i	2384	}
655 :
656 :	sh002i	4357	# this is kinda left over from when we had 'gdbm' and 'sql' database layouts
657 :			# below this line, we would grab values from getopt and put them in this hash
658 :			# but for now the hash can remain empty
659 :	sh002i	1960	my %dbOptions;
660 :	sh002i	2378
661 :	sh002i	1960	my @users;
662 :	sh002i	2378
663 :			# copy users from current (admin) course if desired
664 :			if ($add_admin_users ne "") {
665 :			foreach my $userID ($db->listUsers) {
666 :	sh002i	2887	if ($userID eq $add_initial_userID) {
667 :	gage	3284	$self->addbadmessage( "User '$userID' will not be copied from admin course as it is the initial instructor.");
668 :	sh002i	2885	next;
669 :			}
670 :	sh002i	2378	my $User = $db->getUser($userID);
671 :			my $Password = $db->getPassword($userID);
672 :			my $PermissionLevel = $db->getPermissionLevel($userID);
673 :	gage	4127	push @users, [ $User, $Password, $PermissionLevel ]
674 :			if $authz->hasPermissions($userID,"create_and_delete_courses");
675 :			#only transfer the "instructors" in the admin course classlist.
676 :	sh002i	2378	}
677 :			}
678 :
679 :			# add initial instructor if desired
680 :	sh002i	1960	if ($add_initial_userID ne "") {
681 :	sh002i	2004	my $User = $db->newUser(
682 :	sh002i	2384	user_id => $add_initial_userID,
683 :			first_name => $add_initial_firstName,
684 :			last_name => $add_initial_lastName,
685 :			student_id => $add_initial_userID,
686 :			email_address => $add_initial_email,
687 :			status => "C",
688 :	sh002i	2004	);
689 :			my $Password = $db->newPassword(
690 :	sh002i	2378	user_id => $add_initial_userID,
691 :	sh002i	1960	password => cryptPassword($add_initial_password),
692 :	sh002i	2004	);
693 :			my $PermissionLevel = $db->newPermissionLevel(
694 :	sh002i	2378	user_id => $add_initial_userID,
695 :	sh002i	1960	permission => "10",
696 :	sh002i	2004	);
697 :			push @users, [ $User, $Password, $PermissionLevel ];
698 :	sh002i	1960	}
699 :	sh002i	2378
700 :	dpvc	2704	push @{$courseOptions{PRINT_FILE_NAMES_FOR}}, map { $_->[0]->user_id } @users;
701 :	sh002i	2384
702 :	sh002i	2148	my %optional_arguments;
703 :			if ($add_templates_course ne "") {
704 :			$optional_arguments{templatesFrom} = $add_templates_course;
705 :			}
706 :
707 :	sh002i	1960	eval {
708 :			addCourse(
709 :	sh002i	2004	courseID => $add_courseID,
710 :			ce => $ce2,
711 :			courseOptions => \%courseOptions,
712 :			dbOptions => \%dbOptions,
713 :			users => \@users,
714 :	sh002i	2148	%optional_arguments,
715 :	sh002i	1945	);
716 :	sh002i	1960	};
717 :			if ($@) {
718 :			my $error = $@;
719 :			print CGI::div({class=>"ResultsWithError"},
720 :			CGI::p("An error occured while creating the course $add_courseID:"),
721 :			CGI::tt(CGI::escapeHTML($error)),
722 :			);
723 :	gage	2254	# get rid of any partially built courses
724 :			# FIXME -- this is too fragile
725 :			unless ($error =~ /course exists/) {
726 :			eval {
727 :			deleteCourse(
728 :			courseID => $add_courseID,
729 :			ce => $ce2,
730 :			dbOptions => \%dbOptions,
731 :			);
732 :			}
733 :			}
734 :	sh002i	1960	} else {
735 :	gage	2256	#log the action
736 :	gage	2242	writeLog($ce, "hosted_courses", join("\t",
737 :			"\tAdded",
738 :	sh002i	4377	( defined $add_courseInstitution ? $add_courseInstitution : "(no institution specified)" ),
739 :			( defined $add_courseTitle ? $add_courseTitle : "(no title specified)" ),
740 :	gage	2242	$add_courseID,
741 :	sh002i	2378	$add_initial_firstName,
742 :			$add_initial_lastName,
743 :			$add_initial_email,
744 :	gage	2242	));
745 :	gage	2256	# add contact to admin course as student?
746 :			# FIXME -- should we do this?
747 :	gage	4127	if ($add_initial_userID ne "") {
748 :			my $composite_id = "${add_initial_userID}_${add_courseID}"; # student id includes school name and contact
749 :			my $User = $db->newUser(
750 :			user_id => $composite_id, # student id includes school name and contact
751 :			first_name => $add_initial_firstName,
752 :			last_name => $add_initial_lastName,
753 :			student_id => $add_initial_userID,
754 :			email_address => $add_initial_email,
755 :			status => "C",
756 :			);
757 :			my $Password = $db->newPassword(
758 :			user_id => $composite_id,
759 :			password => cryptPassword($add_initial_password),
760 :			);
761 :			my $PermissionLevel = $db->newPermissionLevel(
762 :			user_id => $composite_id,
763 :			permission => "0",
764 :			);
765 :			# add contact to admin course as student
766 :			# or if this contact and course already exist in a dropped status
767 :			# change the student's status to enrolled
768 :			if (my $oldUser = $db->getUser($composite_id) ) {
769 :			warn "Replacing old data for $composite_id status: ". $oldUser->status;
770 :			$db->deleteUser($composite_id);
771 :			}
772 :			eval { $db->addUser($User) }; warn $@ if $@;
773 :			eval { $db->addPassword($Password) }; warn $@ if $@;
774 :			eval { $db->addPermissionLevel($PermissionLevel) }; warn $@ if $@;
775 :			}
776 :	sh002i	1960	print CGI::div({class=>"ResultsWithoutError"},
777 :			CGI::p("Successfully created the course $add_courseID"),
778 :			);
779 :			my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets",
780 :			courseID => $add_courseID);
781 :			my $newCourseURL = $self->systemLink($newCoursePath, authen => 0);
782 :			print CGI::div({style=>"text-align: center"},
783 :			CGI::a({href=>$newCourseURL}, "Log into $add_courseID"),
784 :			);
785 :			}
786 :	gage	2322
787 :	gage	2299
788 :	sh002i	1960	}
789 :
790 :			################################################################################
791 :
792 :	sh002i	3059	sub rename_course_form {
793 :			my ($self) = @_;
794 :			my $r = $self->r;
795 :			my $ce = $r->ce;
796 :			#my $db = $r->db;
797 :			#my $authz = $r->authz;
798 :			#my $urlpath = $r->urlpath;
799 :
800 :			my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";
801 :			my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";
802 :
803 :			my @courseIDs = listCourses($ce);
804 :	gage	3434	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs;
805 :	sh002i	3059
806 :			my %courseLabels; # records... heh.
807 :			foreach my $courseID (@courseIDs) {
808 :			my $tempCE = WeBWorK::CourseEnvironment->new(
809 :			$ce->{webworkDirs}->{root},
810 :			$ce->{webworkURLs}->{root},
811 :			$ce->{pg}->{directories}->{root},
812 :			$courseID,
813 :			);
814 :			$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
815 :			}
816 :
817 :			print CGI::h2("Rename Course");
818 :
819 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
820 :	sh002i	3059	print $self->hidden_authen_fields;
821 :			print $self->hidden_fields("subDisplay");
822 :
823 :			print CGI::p("Select a course to rename.");
824 :
825 :			print CGI::table({class=>"FormLayout"},
826 :	gage	4280	CGI::Tr({},
827 :	sh002i	3059	CGI::th({class=>"LeftHeader"}, "Course Name:"),
828 :			CGI::td(
829 :			CGI::scrolling_list(
830 :			-name => "rename_oldCourseID",
831 :			-values => \@courseIDs,
832 :			-default => $rename_oldCourseID,
833 :			-size => 10,
834 :			-multiple => 0,
835 :			-labels => \%courseLabels,
836 :			),
837 :			),
838 :			),
839 :	gage	4280	CGI::Tr({},
840 :	sh002i	3059	CGI::th({class=>"LeftHeader"}, "New Name:"),
841 :	gage	4244	CGI::td(CGI::textfield(-name=>"rename_newCourseID", -value=>$rename_newCourseID, -size=>25)),
842 :	sh002i	3059	),
843 :			);
844 :
845 :			print CGI::end_table();
846 :
847 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"rename_course", -label=>"Rename Course"));
848 :	sh002i	3059
849 :			print CGI::end_form();
850 :			}
851 :
852 :			sub rename_course_validate {
853 :			my ($self) = @_;
854 :			my $r = $self->r;
855 :			my $ce = $r->ce;
856 :			#my $db = $r->db;
857 :			#my $authz = $r->authz;
858 :			#my $urlpath = $r->urlpath;
859 :
860 :			my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";
861 :			my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";
862 :
863 :			my @errors;
864 :
865 :			if ($rename_oldCourseID eq "") {
866 :			push @errors, "You must select a course to rename.";
867 :			}
868 :			if ($rename_newCourseID eq "") {
869 :			push @errors, "You must specify a new name for the course.";
870 :			}
871 :			if ($rename_oldCourseID eq $rename_newCourseID) {
872 :			push @errors, "Can't rename to the same name.";
873 :			}
874 :			unless ($rename_newCourseID =~ /^[\w-]*$/) { # regex copied from CourseAdministration.pm
875 :			push @errors, "Course ID may only contain letters, numbers, hyphens, and underscores.";
876 :			}
877 :			if (grep { $rename_newCourseID eq $_ } listCourses($ce)) {
878 :			push @errors, "A course with ID $rename_newCourseID already exists.";
879 :			}
880 :
881 :			my $ce2 = WeBWorK::CourseEnvironment->new(
882 :			$ce->{webworkDirs}->{root},
883 :			$ce->{webworkURLs}->{root},
884 :			$ce->{pg}->{directories}->{root},
885 :			$rename_oldCourseID,
886 :			);
887 :
888 :			return @errors;
889 :			}
890 :
891 :			sub do_rename_course {
892 :			my ($self) = @_;
893 :			my $r = $self->r;
894 :			my $ce = $r->ce;
895 :			my $db = $r->db;
896 :			#my $authz = $r->authz;
897 :			my $urlpath = $r->urlpath;
898 :
899 :			my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";
900 :			my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";
901 :
902 :			my $ce2 = WeBWorK::CourseEnvironment->new(
903 :			$ce->{webworkDirs}->{root},
904 :			$ce->{webworkURLs}->{root},
905 :			$ce->{pg}->{directories}->{root},
906 :			$rename_oldCourseID,
907 :			);
908 :
909 :			my $dbLayoutName = $ce->{dbLayoutName};
910 :
911 :	sh002i	4357	# this is kinda left over from when we had 'gdbm' and 'sql' database layouts
912 :			# below this line, we would grab values from getopt and put them in this hash
913 :			# but for now the hash can remain empty
914 :	sh002i	3059	my %dbOptions;
915 :
916 :			eval {
917 :			renameCourse(
918 :			courseID => $rename_oldCourseID,
919 :			ce => $ce2,
920 :			dbOptions => \%dbOptions,
921 :			newCourseID => $rename_newCourseID,
922 :			);
923 :			};
924 :			if ($@) {
925 :			my $error = $@;
926 :			print CGI::div({class=>"ResultsWithError"},
927 :			CGI::p("An error occured while renaming the course $rename_oldCourseID to $rename_newCourseID:"),
928 :			CGI::tt(CGI::escapeHTML($error)),
929 :			);
930 :			} else {
931 :			print CGI::div({class=>"ResultsWithoutError"},
932 :			CGI::p("Successfully renamed the course $rename_oldCourseID to $rename_newCourseID"),
933 :			);
934 :			my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets",
935 :			courseID => $rename_newCourseID);
936 :			my $newCourseURL = $self->systemLink($newCoursePath, authen => 0);
937 :			print CGI::div({style=>"text-align: center"},
938 :			CGI::a({href=>$newCourseURL}, "Log into $rename_newCourseID"),
939 :			);
940 :			}
941 :			}
942 :
943 :			################################################################################
944 :
945 :	sh002i	1960	sub delete_course_form {
946 :			my ($self) = @_;
947 :			my $r = $self->r;
948 :			my $ce = $r->ce;
949 :			#my $db = $r->db;
950 :			#my $authz = $r->authz;
951 :			#my $urlpath = $r->urlpath;
952 :
953 :			my $delete_courseID = $r->param("delete_courseID") \|\| "";
954 :
955 :			my @courseIDs = listCourses($ce);
956 :	gage	3434	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
957 :	sh002i	1960
958 :			my %courseLabels; # records... heh.
959 :			foreach my $courseID (@courseIDs) {
960 :			my $tempCE = WeBWorK::CourseEnvironment->new(
961 :			$ce->{webworkDirs}->{root},
962 :			$ce->{webworkURLs}->{root},
963 :			$ce->{pg}->{directories}->{root},
964 :			$courseID,
965 :			);
966 :			$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
967 :			}
968 :
969 :			print CGI::h2("Delete Course");
970 :
971 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
972 :	sh002i	1960	print $self->hidden_authen_fields;
973 :			print $self->hidden_fields("subDisplay");
974 :
975 :			print CGI::p("Select a course to delete.");
976 :
977 :			print CGI::table({class=>"FormLayout"},
978 :	gage	4280	CGI::Tr({},
979 :	sh002i	1960	CGI::th({class=>"LeftHeader"}, "Course Name:"),
980 :	sh002i	1945	CGI::td(
981 :	sh002i	1960	CGI::scrolling_list(
982 :			-name => "delete_courseID",
983 :			-values => \@courseIDs,
984 :			-default => $delete_courseID,
985 :			-size => 10,
986 :			-multiple => 0,
987 :			-labels => \%courseLabels,
988 :	sh002i	1945	),
989 :			),
990 :	sh002i	1960	),
991 :			);
992 :
993 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"delete_course", -value=>"Delete Course"));
994 :	sh002i	1960
995 :			print CGI::end_form();
996 :			}
997 :
998 :			sub delete_course_validate {
999 :			my ($self) = @_;
1000 :			my $r = $self->r;
1001 :			my $ce = $r->ce;
1002 :			#my $db = $r->db;
1003 :			#my $authz = $r->authz;
1004 :			my $urlpath = $r->urlpath;
1005 :
1006 :			my $delete_courseID = $r->param("delete_courseID") \|\| "";
1007 :
1008 :			my @errors;
1009 :
1010 :			if ($delete_courseID eq "") {
1011 :			push @errors, "You must specify a course name.";
1012 :			} elsif ($delete_courseID eq $urlpath->arg("courseID")) {
1013 :			push @errors, "You cannot delete the course you are currently using.";
1014 :			}
1015 :
1016 :			my $ce2 = WeBWorK::CourseEnvironment->new(
1017 :			$ce->{webworkDirs}->{root},
1018 :			$ce->{webworkURLs}->{root},
1019 :			$ce->{pg}->{directories}->{root},
1020 :			$delete_courseID,
1021 :			);
1022 :
1023 :			return @errors;
1024 :			}
1025 :
1026 :			sub delete_course_confirm {
1027 :			my ($self) = @_;
1028 :			my $r = $self->r;
1029 :			my $ce = $r->ce;
1030 :			#my $db = $r->db;
1031 :			#my $authz = $r->authz;
1032 :			#my $urlpath = $r->urlpath;
1033 :
1034 :			print CGI::h2("Delete Course");
1035 :
1036 :			my $delete_courseID = $r->param("delete_courseID") \|\| "";
1037 :
1038 :			my $ce2 = WeBWorK::CourseEnvironment->new(
1039 :			$ce->{webworkDirs}->{root},
1040 :			$ce->{webworkURLs}->{root},
1041 :			$ce->{pg}->{directories}->{root},
1042 :			$delete_courseID,
1043 :			);
1044 :
1045 :	sh002i	4357	print CGI::p("Are you sure you want to delete the course " . CGI::b($delete_courseID)
1046 :			. "? All course files and data will be destroyed. There is no undo available.");
1047 :	sh002i	1945
1048 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1049 :	sh002i	1960	print $self->hidden_authen_fields;
1050 :			print $self->hidden_fields("subDisplay");
1051 :	sh002i	4357	print $self->hidden_fields(qw/delete_courseID/);
1052 :	sh002i	1960
1053 :			print CGI::p({style=>"text-align: center"},
1054 :	gage	4244	CGI::submit(-name=>"decline_delete_course", -label=>"Don't delete"),
1055 :	sh002i	1960	" ",
1056 :	gage	4244	CGI::submit(-name=>"confirm_delete_course", -label=>"Delete"),
1057 :	sh002i	1960	);
1058 :
1059 :			print CGI::end_form();
1060 :			}
1061 :
1062 :			sub do_delete_course {
1063 :			my ($self) = @_;
1064 :			my $r = $self->r;
1065 :			my $ce = $r->ce;
1066 :	gage	4127	my $db = $r->db;
1067 :	sh002i	1960	#my $authz = $r->authz;
1068 :			#my $urlpath = $r->urlpath;
1069 :
1070 :			my $delete_courseID = $r->param("delete_courseID") \|\| "";
1071 :
1072 :			my $ce2 = WeBWorK::CourseEnvironment->new(
1073 :			$ce->{webworkDirs}->{root},
1074 :			$ce->{webworkURLs}->{root},
1075 :			$ce->{pg}->{directories}->{root},
1076 :			$delete_courseID,
1077 :			);
1078 :
1079 :	sh002i	4357	# this is kinda left over from when we had 'gdbm' and 'sql' database layouts
1080 :			# below this line, we would grab values from getopt and put them in this hash
1081 :			# but for now the hash can remain empty
1082 :	sh002i	1960	my %dbOptions;
1083 :
1084 :			eval {
1085 :			deleteCourse(
1086 :			courseID => $delete_courseID,
1087 :			ce => $ce2,
1088 :			dbOptions => \%dbOptions,
1089 :			);
1090 :			};
1091 :
1092 :			if ($@) {
1093 :			my $error = $@;
1094 :			print CGI::div({class=>"ResultsWithError"},
1095 :			CGI::p("An error occured while deleting the course $delete_courseID:"),
1096 :			CGI::tt(CGI::escapeHTML($error)),
1097 :			);
1098 :			} else {
1099 :	gage	4127	# mark the contact person in the admin course as dropped.
1100 :			# find the contact person for the course by searching the admin classlist.
1101 :			my @contacts = grep /_$delete_courseID$/, $db->listUsers;
1102 :	sh002i	4311	if (@contacts) {
1103 :			die "Incorrect number of contacts for the course $delete_courseID". join(" ", @contacts) if @contacts !=1;
1104 :			#warn "contacts", join(" ", @contacts);
1105 :			#my $composite_id = "${add_initial_userID}_${add_courseID}";
1106 :			my $composite_id = $contacts[0];
1107 :
1108 :			# mark the contact person as dropped.
1109 :			my $User = $db->getUser($composite_id);
1110 :			my $status_name = 'Drop';
1111 :			my $status_value = ($ce->status_name_to_abbrevs($status_name))[0];
1112 :			$User->status($status_value);
1113 :			$db->putUser($User);
1114 :			}
1115 :	gage	4127
1116 :	sh002i	1960	print CGI::div({class=>"ResultsWithoutError"},
1117 :	sh002i	2378	CGI::p("Successfully deleted the course $delete_courseID."),
1118 :	sh002i	1960	);
1119 :	gage	2242	writeLog($ce, "hosted_courses", join("\t",
1120 :			"\tDeleted",
1121 :			"",
1122 :			"",
1123 :			$delete_courseID,
1124 :			));
1125 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1126 :	sh002i	1945	print $self->hidden_authen_fields;
1127 :	sh002i	1960	print $self->hidden_fields("subDisplay");
1128 :	sh002i	1945
1129 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"decline_delete_course", -value=>"OK"),);
1130 :	sh002i	1945
1131 :	sh002i	1960	print CGI::end_form();
1132 :	sh002i	1945	}
1133 :			}
1134 :
1135 :	sh002i	1985	################################################################################
1136 :
1137 :			sub export_database_form {
1138 :			my ($self) = @_;
1139 :			my $r = $self->r;
1140 :			my $ce = $r->ce;
1141 :			#my $db = $r->db;
1142 :			#my $authz = $r->authz;
1143 :			#my $urlpath = $r->urlpath;
1144 :
1145 :			my @tables = keys %{$ce->{dbLayout}};
1146 :
1147 :			my $export_courseID = $r->param("export_courseID") \|\| "";
1148 :			my @export_tables = $r->param("export_tables");
1149 :	gage	3235
1150 :	sh002i	1985	@export_tables = @tables unless @export_tables;
1151 :
1152 :			my @courseIDs = listCourses($ce);
1153 :	gage	3434	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
1154 :	sh002i	1985
1155 :			my %courseLabels; # records... heh.
1156 :			foreach my $courseID (@courseIDs) {
1157 :			my $tempCE = WeBWorK::CourseEnvironment->new(
1158 :			$ce->{webworkDirs}->{root},
1159 :			$ce->{webworkURLs}->{root},
1160 :			$ce->{pg}->{directories}->{root},
1161 :			$courseID,
1162 :			);
1163 :			$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1164 :			}
1165 :
1166 :			print CGI::h2("Export Database");
1167 :
1168 :	sh002i	4312	print CGI::p(IMPORT_EXPORT_WARNING);
1169 :
1170 :	gage	4244	print CGI::start_form(-method=>"GET", -action=>$r->uri);
1171 :	sh002i	1985	print $self->hidden_authen_fields;
1172 :			print $self->hidden_fields("subDisplay");
1173 :
1174 :	gage	4280	print CGI::p({},"Select a course to export the course's database. Please note
1175 :	sh002i	2844	that exporting can take a very long time for a large course. If you have
1176 :			shell access to the WeBWorK server, you may use the ", CGI::code("wwdb"), "
1177 :			utility instead.");
1178 :	sh002i	1985
1179 :			print CGI::table({class=>"FormLayout"},
1180 :	gage	4280	CGI::Tr({},
1181 :	sh002i	1985	CGI::th({class=>"LeftHeader"}, "Course Name:"),
1182 :			CGI::td(
1183 :			CGI::scrolling_list(
1184 :			-name => "export_courseID",
1185 :			-values => \@courseIDs,
1186 :			-default => $export_courseID,
1187 :			-size => 10,
1188 :	gage	3235	-multiple => 1,
1189 :	sh002i	1985	-labels => \%courseLabels,
1190 :			),
1191 :			),
1192 :			),
1193 :	gage	4280	CGI::Tr({},
1194 :	sh002i	1985	CGI::th({class=>"LeftHeader"}, "Tables to Export:"),
1195 :	gage	4280	CGI::td({},
1196 :	sh002i	1985	CGI::checkbox_group(
1197 :			-name => "export_tables",
1198 :			-values => \@tables,
1199 :			-default => \@export_tables,
1200 :			-linebreak => 1,
1201 :			),
1202 :			),
1203 :			),
1204 :			);
1205 :
1206 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"export_database", -value=>"Export Database"));
1207 :	sh002i	1985
1208 :			print CGI::end_form();
1209 :			}
1210 :
1211 :			sub export_database_validate {
1212 :			my ($self) = @_;
1213 :			my $r = $self->r;
1214 :			#my $ce = $r->ce;
1215 :			#my $db = $r->db;
1216 :			#my $authz = $r->authz;
1217 :			#my $urlpath = $r->urlpath;
1218 :
1219 :	gage	3235	my @export_courseID = $r->param("export_courseID") \|\| ();
1220 :	sh002i	1985	my @export_tables = $r->param("export_tables");
1221 :	gage	3235
1222 :	sh002i	1985	my @errors;
1223 :	gage	3235
1224 :			unless ( @export_courseID) {
1225 :			push @errors, "You must specify at least one course name.";
1226 :	sh002i	1985	}
1227 :
1228 :			unless (@export_tables) {
1229 :			push @errors, "You must specify at least one table to export.";
1230 :			}
1231 :
1232 :			return @errors;
1233 :			}
1234 :
1235 :			sub do_export_database {
1236 :			my ($self) = @_;
1237 :			my $r = $self->r;
1238 :			my $ce = $r->ce;
1239 :			#my $db = $r->db;
1240 :			#my $authz = $r->authz;
1241 :			my $urlpath = $r->urlpath;
1242 :
1243 :	gage	3235	my @export_courseID = $r->param("export_courseID");
1244 :	sh002i	1985	my @export_tables = $r->param("export_tables");
1245 :
1246 :	gage	3235	foreach my $export_courseID (@export_courseID) {
1247 :
1248 :			my $ce2 = WeBWorK::CourseEnvironment->new(
1249 :			$ce->{webworkDirs}->{root},
1250 :			$ce->{webworkURLs}->{root},
1251 :			$ce->{pg}->{directories}->{root},
1252 :			$export_courseID,
1253 :			);
1254 :
1255 :			my $db2 = new WeBWorK::DB($ce2->{dbLayout});
1256 :
1257 :			#my ($fh, $export_file) = tempfile("db_export_XXXXXX", DIR => $ce->{webworkDirs}->{tmp});
1258 :			#my ($random_chars) = $export_file =~ m/db_export_(\w+)$/;
1259 :			# export to the admin/templates directory
1260 :			my $exportFileName = "$export_courseID.exported.xml";
1261 :			my $exportFilePath = $ce->{courseDirs}->{templates}."/$exportFileName";
1262 :			# get a unique name
1263 :			my $number =1;
1264 :			while (-e "$exportFilePath.$number.gz") {
1265 :			$number++;
1266 :			last if $number>9;
1267 :			}
1268 :			if ($number<=9 ) {
1269 :			$exportFilePath = "$exportFilePath.$number";
1270 :			$exportFileName = "$exportFileName.$number";
1271 :			} else {
1272 :			$self->addbadmessage(CGI::p("There are more than 9 exported files for this course! Please
1273 :			remove some of these files."));
1274 :			$exportFilePath = "$exportFilePath.999";
1275 :			$exportFileName = "$exportFileName.999";
1276 :			}
1277 :	sh002i	1985
1278 :	gage	3235	my $outputFileHandle = new IO::File(">$exportFilePath") or warn "Unable to create $exportFilePath";
1279 :	sh002i	1985
1280 :	gage	3235	my @errors;
1281 :			eval {
1282 :			@errors = dbExport(
1283 :			db => $db2,
1284 :			#xml => $fh,
1285 :			xml => $outputFileHandle,
1286 :			tables => \@export_tables,
1287 :			);
1288 :			};
1289 :
1290 :			$outputFileHandle->close();
1291 :	sh002i	1985
1292 :	glarose	4910	my $gzipMessage = system( 'gzip', $exportFilePath);
1293 :			if ( !$gzipMessage ) {
1294 :			$self->addgoodmessage(CGI::p( "Database saved to templates/$exportFileName.gzip.
1295 :			You may download it with the file manager."));
1296 :	gage	3235	} else {
1297 :	glarose	4910	$self->addbadmessage(CGI::p( "Failed to gzip file $exportFilePath"));
1298 :	gage	3235	}
1299 :			unlink $exportFilePath;
1300 :			} # end export of one course
1301 :	sh002i	2478	#push @errors, "Fatal exception: $@" if $@;
1302 :			#
1303 :			#if (@errors) {
1304 :			# print CGI::div({class=>"ResultsWithError"},
1305 :			# CGI::p("An error occured while exporting the database of course $export_courseID:"),
1306 :			# CGI::ul(CGI::li(\@errors)),
1307 :			# );
1308 :			#} else {
1309 :			# print CGI::div({class=>"ResultsWithoutError"},
1310 :			# CGI::p("Export succeeded."),
1311 :			# );
1312 :			#
1313 :			# print CGI::div({style=>"text-align: center"},
1314 :			# CGI::a({href=>$self->systemLink($urlpath, params=>{download_exported_database=>$random_chars, export_courseID=>undef})}, "Download Exported Database"),
1315 :			# );
1316 :			#}
1317 :	sh002i	1985	}
1318 :
1319 :			################################################################################
1320 :
1321 :			sub import_database_form {
1322 :			my ($self) = @_;
1323 :			my $r = $self->r;
1324 :			my $ce = $r->ce;
1325 :			#my $db = $r->db;
1326 :			#my $authz = $r->authz;
1327 :			#my $urlpath = $r->urlpath;
1328 :
1329 :			my @tables = keys %{$ce->{dbLayout}};
1330 :
1331 :			my $import_file = $r->param("import_file") \|\| "";
1332 :			my $import_courseID = $r->param("import_courseID") \|\| "";
1333 :			my @import_tables = $r->param("import_tables");
1334 :			my $import_conflict = $r->param("import_conflict") \|\| "skip";
1335 :
1336 :			@import_tables = @tables unless @import_tables;
1337 :
1338 :			my @courseIDs = listCourses($ce);
1339 :	gage	3434	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
1340 :	gage	2045
1341 :	sh002i	1985
1342 :			my %courseLabels; # records... heh.
1343 :			foreach my $courseID (@courseIDs) {
1344 :			my $tempCE = WeBWorK::CourseEnvironment->new(
1345 :			$ce->{webworkDirs}->{root},
1346 :			$ce->{webworkURLs}->{root},
1347 :			$ce->{pg}->{directories}->{root},
1348 :			$courseID,
1349 :			);
1350 :			$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1351 :			}
1352 :
1353 :	gage	3235	# find databases:
1354 :			my $templatesDir = $ce->{courseDirs}->{templates};
1355 :	sh002i	4642	my $exempt_dirs = join("\|", keys %{ $r->ce->{courseFiles}->{problibs} });
1356 :	gage	3235
1357 :			my @databaseFiles = listFilesRecursive(
1358 :			$templatesDir,
1359 :			qr/.\.exported\.xml\.\d*\.gz$/, # match these files #FIXME this is too restricive!!
1360 :			qr/^(?:$exempt_dirs\|CVS)$/, # prune these directories
1361 :			0, # match against file name only
1362 :			1, # prune against path relative to $templatesDir
1363 :			);
1364 :
1365 :			my %databaseLabels = map { ($_ => $_) } @databaseFiles;
1366 :
1367 :			#######
1368 :
1369 :	sh002i	1985	print CGI::h2("Import Database");
1370 :
1371 :	sh002i	4312	print CGI::p(IMPORT_EXPORT_WARNING);
1372 :
1373 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri, -enctype=>&CGI::MULTIPART);
1374 :	sh002i	1985	print $self->hidden_authen_fields;
1375 :			print $self->hidden_fields("subDisplay");
1376 :
1377 :			print CGI::table({class=>"FormLayout"},
1378 :	gage	4280	CGI::Tr({},
1379 :	sh002i	1985	CGI::th({class=>"LeftHeader"}, "Database XML File:"),
1380 :			CGI::td(
1381 :	gage	3235	CGI::scrolling_list(
1382 :	sh002i	1985	-name => "import_file",
1383 :	gage	3235	-values => \@databaseFiles,
1384 :			-default => undef,
1385 :			-size => 10,
1386 :			-multiple => 0,
1387 :			-labels => \%databaseLabels,
1388 :	sh002i	1985	),
1389 :	gage	3235
1390 :			)
1391 :	sh002i	1985	),
1392 :	gage	4280	CGI::Tr({},
1393 :	sh002i	1985	CGI::th({class=>"LeftHeader"}, "Tables to Import:"),
1394 :			CGI::td(
1395 :			CGI::checkbox_group(
1396 :			-name => "import_tables",
1397 :			-values => \@tables,
1398 :			-default => \@import_tables,
1399 :			-linebreak => 1,
1400 :			),
1401 :			),
1402 :			),
1403 :	gage	4280	CGI::Tr({},
1404 :	sh002i	1985	CGI::th({class=>"LeftHeader"}, "Import into Course:"),
1405 :			CGI::td(
1406 :			CGI::scrolling_list(
1407 :			-name => "import_courseID",
1408 :			-values => \@courseIDs,
1409 :			-default => $import_courseID,
1410 :			-size => 10,
1411 :			-multiple => 0,
1412 :			-labels => \%courseLabels,
1413 :			),
1414 :			),
1415 :			),
1416 :	gage	4280	CGI::Tr({},
1417 :	sh002i	1985	CGI::th({class=>"LeftHeader"}, "Conflicts:"),
1418 :			CGI::td(
1419 :			CGI::radio_group(
1420 :			-name => "import_conflict",
1421 :			-values => [qw/skip replace/],
1422 :			-default => $import_conflict,
1423 :			-linebreak=>'true',
1424 :			-labels => {
1425 :			skip => "Skip duplicate records",
1426 :			replace => "Replace duplicate records",
1427 :			},
1428 :			),
1429 :			),
1430 :			),
1431 :			);
1432 :
1433 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"import_database", -value=>"Import Database"));
1434 :	sh002i	1985
1435 :			print CGI::end_form();
1436 :			}
1437 :
1438 :			sub import_database_validate {
1439 :			my ($self) = @_;
1440 :			my $r = $self->r;
1441 :			#my $ce = $r->ce;
1442 :			#my $db = $r->db;
1443 :			#my $authz = $r->authz;
1444 :			#my $urlpath = $r->urlpath;
1445 :
1446 :			my $import_file = $r->param("import_file") \|\| "";
1447 :			my $import_courseID = $r->param("import_courseID") \|\| "";
1448 :			my @import_tables = $r->param("import_tables");
1449 :			#my $import_conflict = $r->param("import_conflict") \|\| "skip"; # not checked
1450 :
1451 :			my @errors;
1452 :
1453 :			if ($import_file eq "") {
1454 :	gage	3235	push @errors, "You must specify a database file to import.";
1455 :	sh002i	1985	}
1456 :
1457 :			if ($import_courseID eq "") {
1458 :			push @errors, "You must specify a course name.";
1459 :			}
1460 :
1461 :			unless (@import_tables) {
1462 :			push @errors, "You must specify at least one table to import.";
1463 :			}
1464 :
1465 :			return @errors;
1466 :			}
1467 :
1468 :			sub do_import_database {
1469 :			my ($self) = @_;
1470 :			my $r = $self->r;
1471 :			my $ce = $r->ce;
1472 :			#my $db = $r->db;
1473 :			#my $authz = $r->authz;
1474 :			my $urlpath = $r->urlpath;
1475 :
1476 :			my $import_file = $r->param("import_file");
1477 :			my $import_courseID = $r->param("import_courseID");
1478 :			my @import_tables = $r->param("import_tables");
1479 :			my $import_conflict = $r->param("import_conflict") \|\| "skip"; # need default -- not checked above
1480 :
1481 :			my $ce2 = WeBWorK::CourseEnvironment->new(
1482 :			$ce->{webworkDirs}->{root},
1483 :			$ce->{webworkURLs}->{root},
1484 :			$ce->{pg}->{directories}->{root},
1485 :			$import_courseID,
1486 :			);
1487 :
1488 :			my $db2 = new WeBWorK::DB($ce2->{dbLayout});
1489 :
1490 :	gage	3235	# locate file
1491 :			my $templateDir = $ce->{courseDirs}->{templates};
1492 :			my $filePath = "$templateDir/$import_file";
1493 :
1494 :	glarose	4910	my $gunzipMessage = system( 'gunzip', $filePath);
1495 :			#FIXME
1496 :			#warn "gunzip ", $gunzipMessage;
1497 :			$filePath =~ s/\.gz$//;
1498 :			#warn "new file path is $filePath";
1499 :			my $fileHandle = new IO::File("<$filePath");
1500 :			# retrieve upload from upload cache
1501 :	gage	3235	# my ($id, $hash) = split /\s+/, $import_file;
1502 :			# my $upload = WeBWorK::Upload->retrieve($id, $hash,
1503 :			# dir => $ce->{webworkDirs}->{uploadCache}
1504 :			# );
1505 :	sh002i	1985
1506 :			my @errors;
1507 :
1508 :	glarose	4910	eval {
1509 :			@errors = dbImport(
1510 :			db => $db2,
1511 :			# xml => $upload->fileHandle,
1512 :			xml => $fileHandle,
1513 :			tables => \@import_tables,
1514 :			conflict => $import_conflict,
1515 :			);
1516 :			};
1517 :	sh002i	1985
1518 :	glarose	4910	push @errors, "Fatal exception: $@" if $@;
1519 :			push @errors, $gunzipMessage if $gunzipMessage;
1520 :
1521 :	sh002i	1985	if (@errors) {
1522 :			print CGI::div({class=>"ResultsWithError"},
1523 :			CGI::p("An error occured while importing the database of course $import_courseID:"),
1524 :			CGI::ul(CGI::li(\@errors)),
1525 :			);
1526 :			} else {
1527 :			print CGI::div({class=>"ResultsWithoutError"},
1528 :			CGI::p("Import succeeded."),
1529 :			);
1530 :			}
1531 :			}
1532 :	gage	3528	##########################################################################
1533 :			sub archive_course_form {
1534 :			my ($self) = @_;
1535 :			my $r = $self->r;
1536 :			my $ce = $r->ce;
1537 :			#my $db = $r->db;
1538 :			#my $authz = $r->authz;
1539 :			#my $urlpath = $r->urlpath;
1540 :
1541 :			my $archive_courseID = $r->param("archive_courseID") \|\| "";
1542 :
1543 :			my @courseIDs = listCourses($ce);
1544 :			@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
1545 :
1546 :			my %courseLabels; # records... heh.
1547 :			foreach my $courseID (@courseIDs) {
1548 :			my $tempCE = WeBWorK::CourseEnvironment->new(
1549 :			$ce->{webworkDirs}->{root},
1550 :			$ce->{webworkURLs}->{root},
1551 :			$ce->{pg}->{directories}->{root},
1552 :			$courseID,
1553 :			);
1554 :			$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1555 :			}
1556 :
1557 :			print CGI::h2("archive Course");
1558 :
1559 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1560 :	gage	3528	print $self->hidden_authen_fields;
1561 :			print $self->hidden_fields("subDisplay");
1562 :
1563 :			print CGI::p("Select a course to archive.");
1564 :
1565 :			print CGI::table({class=>"FormLayout"},
1566 :	gage	4280	CGI::Tr({},
1567 :	gage	3528	CGI::th({class=>"LeftHeader"}, "Course Name:"),
1568 :			CGI::td(
1569 :			CGI::scrolling_list(
1570 :			-name => "archive_courseID",
1571 :			-values => \@courseIDs,
1572 :			-default => $archive_courseID,
1573 :			-size => 10,
1574 :			-multiple => 0,
1575 :			-labels => \%courseLabels,
1576 :			),
1577 :			),
1578 :	gage	4136
1579 :	gage	3528	),
1580 :	gage	4280	CGI::Tr({},
1581 :	gage	4136	CGI::th({class=>"LeftHeader"}, "Delete course:"),
1582 :			CGI::td({-style=>'color:red'}, CGI::checkbox({
1583 :			-name=>'delete_course',
1584 :			-checked=>0,
1585 :			-value => 1,
1586 :			-label =>'Delete course after archiving. Caution there is no undo!',
1587 :			},
1588 :			),
1589 :			),
1590 :			)
1591 :	gage	3528	);
1592 :
1593 :			print CGI::p(
1594 :			"Currently the archive facility is only available for mysql databases.
1595 :			It depends on the mysqldump application."
1596 :			);
1597 :	gage	4129
1598 :	gage	3528
1599 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"archive_course", -value=>"archive Course"));
1600 :	gage	3528
1601 :			print CGI::end_form();
1602 :			}
1603 :	sh002i	1985
1604 :	gage	3528	sub archive_course_validate {
1605 :			my ($self) = @_;
1606 :			my $r = $self->r;
1607 :			my $ce = $r->ce;
1608 :			#my $db = $r->db;
1609 :			#my $authz = $r->authz;
1610 :			my $urlpath = $r->urlpath;
1611 :
1612 :			my $archive_courseID = $r->param("archive_courseID") \|\| "";
1613 :
1614 :			my @errors;
1615 :
1616 :			if ($archive_courseID eq "") {
1617 :			push @errors, "You must specify a course name.";
1618 :			} elsif ($archive_courseID eq $urlpath->arg("courseID")) {
1619 :			push @errors, "You cannot archive the course you are currently using.";
1620 :			}
1621 :
1622 :	sh002i	4357	#my $ce2 = WeBWorK::CourseEnvironment->new(
1623 :			# $ce->{webworkDirs}->{root},
1624 :			# $ce->{webworkURLs}->{root},
1625 :			# $ce->{pg}->{directories}->{root},
1626 :			# $archive_courseID,
1627 :			#);
1628 :	gage	3528
1629 :			return @errors;
1630 :			}
1631 :
1632 :			sub archive_course_confirm {
1633 :			my ($self) = @_;
1634 :			my $r = $self->r;
1635 :			my $ce = $r->ce;
1636 :			#my $db = $r->db;
1637 :			#my $authz = $r->authz;
1638 :			#my $urlpath = $r->urlpath;
1639 :
1640 :			print CGI::h2("archive Course");
1641 :
1642 :			my $archive_courseID = $r->param("archive_courseID") \|\| "";
1643 :	gage	4136	my $delete_course_flag = $r->param("delete_course") \|\| "";
1644 :	sh002i	4357
1645 :	gage	3528	my $ce2 = WeBWorK::CourseEnvironment->new(
1646 :			$ce->{webworkDirs}->{root},
1647 :			$ce->{webworkURLs}->{root},
1648 :			$ce->{pg}->{directories}->{root},
1649 :			$archive_courseID,
1650 :			);
1651 :
1652 :	gage	4136	if ($ce2->{dbLayoutName} ) {
1653 :	gage	3528	print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID)
1654 :	gage	3621	. "? ");
1655 :	gage	4136	print(CGI::p({-style=>'color:red; font-weight:bold'}, "Are you sure that you want to delete the course ".
1656 :			CGI::b($archive_courseID). " after archiving? This cannot be undone!")) if $delete_course_flag;
1657 :	gage	3528
1658 :	gage	4136
1659 :	gage	3528	}
1660 :
1661 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1662 :	gage	3528	print $self->hidden_authen_fields;
1663 :			print $self->hidden_fields("subDisplay");
1664 :	sh002i	4357	print $self->hidden_fields(qw/archive_courseID delete_course/);
1665 :	gage	3528
1666 :			print CGI::p({style=>"text-align: center"},
1667 :	gage	4244	CGI::submit(-name=>"decline_archive_course", -value=>"Don't archive"),
1668 :	gage	3528	" ",
1669 :	gage	4244	CGI::submit(-name=>"confirm_archive_course", -value=>"archive"),
1670 :	gage	3528	);
1671 :
1672 :			print CGI::end_form();
1673 :			}
1674 :
1675 :			sub do_archive_course {
1676 :			my ($self) = @_;
1677 :			my $r = $self->r;
1678 :			my $ce = $r->ce;
1679 :	gage	4136	my $db = $r->db;
1680 :	gage	3528	#my $authz = $r->authz;
1681 :			#my $urlpath = $r->urlpath;
1682 :
1683 :			my $archive_courseID = $r->param("archive_courseID") \|\| "";
1684 :	gage	4136	my $delete_course_flag = $r->param("delete_course") \|\| "";
1685 :	gage	3528
1686 :			my $ce2 = WeBWorK::CourseEnvironment->new(
1687 :			$ce->{webworkDirs}->{root},
1688 :			$ce->{webworkURLs}->{root},
1689 :			$ce->{pg}->{directories}->{root},
1690 :			$archive_courseID,
1691 :			);
1692 :
1693 :	sh002i	4357	# this is kinda left over from when we had 'gdbm' and 'sql' database layouts
1694 :			# below this line, we would grab values from getopt and put them in this hash
1695 :			# but for now the hash can remain empty
1696 :	gage	3528	my %dbOptions;
1697 :
1698 :			eval {
1699 :			archiveCourse(
1700 :			courseID => $archive_courseID,
1701 :			ce => $ce2,
1702 :			dbOptions => \%dbOptions,
1703 :			);
1704 :			};
1705 :
1706 :			if ($@) {
1707 :			my $error = $@;
1708 :			print CGI::div({class=>"ResultsWithError"},
1709 :			CGI::p("An error occured while archiving the course $archive_courseID:"),
1710 :			CGI::tt(CGI::escapeHTML($error)),
1711 :			);
1712 :			} else {
1713 :			print CGI::div({class=>"ResultsWithoutError"},
1714 :			CGI::p("Successfully archived the course $archive_courseID"),
1715 :			);
1716 :			writeLog($ce, "hosted_courses", join("\t",
1717 :			"\tarchived",
1718 :			"",
1719 :			"",
1720 :			$archive_courseID,
1721 :			));
1722 :	gage	4136
1723 :			if ($delete_course_flag) {
1724 :			eval {
1725 :			deleteCourse(
1726 :			courseID => $archive_courseID,
1727 :			ce => $ce2,
1728 :			dbOptions => \%dbOptions,
1729 :			);
1730 :			};
1731 :
1732 :			if ($@) {
1733 :			my $error = $@;
1734 :			print CGI::div({class=>"ResultsWithError"},
1735 :			CGI::p("An error occured while deleting the course $archive_courseID:"),
1736 :			CGI::tt(CGI::escapeHTML($error)),
1737 :			);
1738 :			} else {
1739 :			# mark the contact person in the admin course as dropped.
1740 :			# find the contact person for the course by searching the admin classlist.
1741 :			my @contacts = grep /_$archive_courseID$/, $db->listUsers;
1742 :	sh002i	4311	if (@contacts) {
1743 :			die "Incorrect number of contacts for the course $archive_courseID". join(" ", @contacts) if @contacts !=1;
1744 :			#warn "contacts", join(" ", @contacts);
1745 :			#my $composite_id = "${add_initial_userID}_${add_courseID}";
1746 :			my $composite_id = $contacts[0];
1747 :
1748 :			# mark the contact person as dropped.
1749 :			my $User = $db->getUser($composite_id);
1750 :			my $status_name = 'Drop';
1751 :			my $status_value = ($ce->status_name_to_abbrevs($status_name))[0];
1752 :			$User->status($status_value);
1753 :			$db->putUser($User);
1754 :			}
1755 :	gage	4136
1756 :			print CGI::div({class=>"ResultsWithoutError"},
1757 :			CGI::p("Successfully deleted the course $archive_courseID."),
1758 :			);
1759 :			}
1760 :
1761 :
1762 :			}
1763 :
1764 :	gage	4244	# print CGI::start_form(-method=>"POST", -action=>$r->uri);
1765 :	gage	4129	# print $self->hidden_authen_fields;
1766 :			# print $self->hidden_fields("subDisplay");
1767 :			#
1768 :			# print CGI::p({style=>"text-align: center"}, CGI::submit("decline_archive_course", "OK"),);
1769 :			#
1770 :			# print CGI::end_form();
1771 :	gage	3528	}
1772 :			}
1773 :	gage	4129	##########################################################################
1774 :			sub unarchive_course_form {
1775 :			my ($self) = @_;
1776 :			my $r = $self->r;
1777 :			my $ce = $r->ce;
1778 :			#my $db = $r->db;
1779 :			#my $authz = $r->authz;
1780 :			#my $urlpath = $r->urlpath;
1781 :
1782 :			my $unarchive_courseID = $r->param("unarchive_courseID") \|\| "";
1783 :
1784 :			# First find courses which have been archived.
1785 :			my @courseIDs = listArchivedCourses($ce);
1786 :			@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
1787 :
1788 :			my %courseLabels; # records... heh.
1789 :			foreach my $courseID (@courseIDs) {
1790 :			$courseLabels{$courseID} = $courseID;
1791 :			}
1792 :
1793 :			print CGI::h2("Unarchive Course -- not yet operational");
1794 :
1795 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1796 :	gage	4129	print $self->hidden_authen_fields;
1797 :			print $self->hidden_fields("subDisplay");
1798 :
1799 :			print CGI::p("Select a course to unarchive.");
1800 :
1801 :			print CGI::table({class=>"FormLayout"},
1802 :	gage	4280	CGI::Tr({},
1803 :	gage	4129	CGI::th({class=>"LeftHeader"}, "Course Name:"),
1804 :			CGI::td(
1805 :			CGI::scrolling_list(
1806 :			-name => "unarchive_courseID",
1807 :			-values => \@courseIDs,
1808 :			-default => $unarchive_courseID,
1809 :			-size => 10,
1810 :			-multiple => 0,
1811 :			-labels => \%courseLabels,
1812 :			),
1813 :			),
1814 :			),
1815 :			);
1816 :
1817 :			print CGI::p(
1818 :			"Currently the unarchive facility is only available for mysql databases.
1819 :			It depends on the mysqldump application."
1820 :			);
1821 :	gage	3528
1822 :	gage	4129
1823 :	gage	4244	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"unarchive_course", -value=>"Unarchive Course"));
1824 :	gage	4129
1825 :			print CGI::end_form();
1826 :			}
1827 :
1828 :			sub unarchive_course_validate {
1829 :			my ($self) = @_;
1830 :			my $r = $self->r;
1831 :			my $ce = $r->ce;
1832 :			#my $db = $r->db;
1833 :			#my $authz = $r->authz;
1834 :			my $urlpath = $r->urlpath;
1835 :
1836 :			my $unarchive_courseID = $r->param("unarchive_courseID") \|\| "";
1837 :
1838 :			my @errors;
1839 :
1840 :			my $new_courseID = $unarchive_courseID; $new_courseID =~ s/\.tar\.gz$//;
1841 :
1842 :			if ($new_courseID eq "") {
1843 :			push @errors, "You must specify a course name.";
1844 :			} elsif ( -d $ce->{webworkDirs}->{courses}."/$new_courseID" ) {
1845 :			#Check that a directory for this course doesn't already exist
1846 :			push @errors, "A directory already exists with the name $new_courseID.
1847 :			You must first delete this existing course before you can unarchive.";
1848 :			}
1849 :
1850 :
1851 :
1852 :			return @errors;
1853 :			}
1854 :
1855 :			sub unarchive_course_confirm {
1856 :			my ($self) = @_;
1857 :			my $r = $self->r;
1858 :			my $ce = $r->ce;
1859 :			#my $db = $r->db;
1860 :			#my $authz = $r->authz;
1861 :			#my $urlpath = $r->urlpath;
1862 :
1863 :			print CGI::h2("Unarchive Course");
1864 :
1865 :			my $unarchive_courseID = $r->param("unarchive_courseID") \|\| "";
1866 :
1867 :			my $new_courseID = $unarchive_courseID; $new_courseID =~ s/\.tar\.gz$//;
1868 :
1869 :
1870 :
1871 :	gage	4244	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1872 :	gage	4129	print CGI::p($unarchive_courseID," to course ",
1873 :			CGI::input({-name=>'new_courseID', -value=>$new_courseID})
1874 :			);
1875 :
1876 :			print $self->hidden_authen_fields;
1877 :			print $self->hidden_fields("subDisplay");
1878 :	sh002i	4357	print $self->hidden_fields(qw/unarchive_courseID/);
1879 :	gage	4129
1880 :			print CGI::p({style=>"text-align: center"},
1881 :	gage	4244	CGI::submit(-name=>"decline_unarchive_course", -value=>"Don't unarchive"),
1882 :	gage	4129	" ",
1883 :	gage	4244	CGI::submit(-name=>"confirm_unarchive_course", -value=>"unarchive"),
1884 :	gage	4129	);
1885 :
1886 :			print CGI::end_form();
1887 :			}
1888 :
1889 :			sub do_unarchive_course {
1890 :			my ($self) = @_;
1891 :			my $r = $self->r;
1892 :			my $ce = $r->ce;
1893 :			#my $db = $r->db;
1894 :			#my $authz = $r->authz;
1895 :			my $urlpath = $r->urlpath;
1896 :			my $new_courseID = $r->param("new_courseID") \|\| "";
1897 :			my $unarchive_courseID = $r->param("unarchive_courseID") \|\| "";
1898 :
1899 :			my %dbOptions;
1900 :
1901 :			eval {
1902 :			unarchiveCourse(
1903 :			courseID => $new_courseID,
1904 :			archivePath =>$ce->{webworkDirs}->{courses}."/$unarchive_courseID",
1905 :			ce => $ce , # $ce2,
1906 :			dbOptions => undef,
1907 :			);
1908 :			};
1909 :
1910 :			if ($@) {
1911 :			my $error = $@;
1912 :			print CGI::div({class=>"ResultsWithError"},
1913 :			CGI::p("An error occured while archiving the course $unarchive_courseID:"),
1914 :			CGI::tt(CGI::escapeHTML($error)),
1915 :			);
1916 :			} else {
1917 :			print CGI::div({class=>"ResultsWithoutError"},
1918 :			CGI::p("Successfully unarchived $unarchive_courseID to the course $new_courseID"),
1919 :			);
1920 :			writeLog($ce, "hosted_courses", join("\t",
1921 :			"\tunarchived",
1922 :			"",
1923 :			"",
1924 :			"$unarchive_courseID to $new_courseID",
1925 :			));
1926 :
1927 :			my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets",
1928 :			courseID => $new_courseID);
1929 :			my $newCourseURL = $self->systemLink($newCoursePath, authen => 0);
1930 :			print CGI::div({style=>"text-align: center"},
1931 :			CGI::a({href=>$newCourseURL}, "Log into $new_courseID"),
1932 :			);
1933 :			}
1934 :			}
1935 :
1936 :	gage	3528	################################################################################
1937 :	glarose	4910	## location management routines; added by DG [Danny Ginn] 20070215
1938 :			## revised by glarose
1939 :
1940 :			sub manage_location_form {
1941 :			my ($self) = @_;
1942 :			my $r = $self->r;
1943 :			my $ce = $r->ce;
1944 :			my $db = $r->db;
1945 :			#my $authz = $r->authz;
1946 :			my $urlpath = $r->urlpath;
1947 :
1948 :			# get a list of all existing locations
1949 :			my @locations = sort {lc($a->location_id) cmp lc($b->location_id)}
1950 :			$db->getAllLocations();
1951 :			my %locAddr = map {$_->location_id => [ $db->listLocationAddresses($_->location_id) ]} @locations;
1952 :
1953 :			my @locationIDs = map { $_->location_id } @locations;
1954 :
1955 :			print CGI::h2("Manage Locations");
1956 :
1957 :			print CGI::p({},CGI::strong("Currently defined locations are listed below."));
1958 :
1959 :			print CGI::start_form(-method=>"POST", -action=>$r->uri);
1960 :			print $self->hidden_authen_fields;
1961 :			print $self->hidden_fields("subDisplay");
1962 :
1963 :			# get a list of radio buttons to select an action
1964 :			my @actionRadios =
1965 :			CGI::radio_group(-name => "manage_location_action",
1966 :			-values => ["edit_location_form",
1967 :			"add_location_handler",
1968 :			"delete_location_handler"],
1969 :			-labels => { edit_location_form => "",
1970 :			add_location_handler => "",
1971 :			delete_location_handler => "", },
1972 :			-default => $r->param("manage_location_action") ? $r->param("manage_location_action") : 'none');
1973 :
1974 :			print CGI::start_table({});
1975 :			print CGI::Tr({}, CGI::th({-colspan=>4,-align=>"left"},
1976 :			"Select an action to perform:"));
1977 :
1978 :			# edit action
1979 :			print CGI::Tr({},
1980 :			CGI::td({},[ $actionRadios[0], "Edit Location:" ]),
1981 :			CGI::td({-colspan=>2, -align=>"left"},
1982 :			CGI::div({-style=>"width:25%;"},
1983 :			CGI::popup_menu(-name=>"edit_location",
1984 :			-values=>[@locationIDs]))) );
1985 :			# create action
1986 :			print CGI::Tr({},
1987 :			CGI::td({-align=>"left"},[ $actionRadios[1],
1988 :			"Create Location:" ]),
1989 :			CGI::td({-colspan=>2},
1990 :			"Location name: " .
1991 :			CGI::textfield(-name=>"new_location_name",
1992 :			-size=>"10",
1993 :			-default=>$r->param("new_location_name")?$r->param("new_location_name"):'')));
1994 :			print CGI::Tr({valign=>'top'},
1995 :			CGI::td({}, [" ", "Location description:"]),
1996 :			CGI::td({-colspan=>2},
1997 :			CGI::textfield(-name=>"new_location_description",
1998 :			-size=>"50",
1999 :			-default=>$r->param("new_location_description")?$r->param("new_location_description"):'')) );
2000 :			print CGI::Tr({}, CGI::td({}," "),
2001 :			CGI::td({-colspan=>3}, "Addresses for new location " .
2002 :			"(enter one per line, as single IP addresses " .
2003 :			"(e.g., 192.168.1.101), address masks (e.g., " .
2004 :			"192.168.1.0/24), or IP ranges (e.g., " .
2005 :			"192.168.1.101-192.168.1.150)):"));
2006 :			print CGI::Tr({}, CGI::td({}, " "),
2007 :			CGI::td({-colspan=>3},
2008 :			CGI::textarea({-name=>"new_location_addresses",
2009 :			-rows=>5, -columns=>28,
2010 :			-default=>$r->param("new_location_addresses")?$r->param("new_location_addresses"):''})));
2011 :
2012 :			# delete action
2013 :			print CGI::Tr({},
2014 :			CGI::td({-colspan=>4},
2015 :			CGI::div({-class=>"ResultsWithError"},
2016 :			CGI::em({}, "Deletion deletes all location " .
2017 :			"data and related addresses, and is" .
2018 :
2019 :			" not undoable!"))));
2020 :			print CGI::Tr({},
2021 :			CGI::td({},
2022 :			[ $actionRadios[2],
2023 :			CGI::div({-class=>"ResultsWithError"},
2024 :			"Delete location:") ]),
2025 :			CGI::td({-colspan=>2},
2026 :			CGI::popup_menu(-name=>"delete_location",
2027 :	glarose	4918	-values=>["",
2028 :	glarose	4917	"selected_locations",
2029 :			@locationIDs],
2030 :	glarose	4918	-labels=>{selected_locations => "locations selected below",
2031 :			"" => "no location"}) .
2032 :	glarose	4910	CGI::span({-style=>"color:#C33;"}, " Confirm: ") .
2033 :			CGI::checkbox({-name=>"delete_confirm",
2034 :			-value=>"true",
2035 :			-label=>""}) ) );
2036 :			print CGI::end_table();
2037 :
2038 :			print CGI::p({}, CGI::submit(-name=>"manage_locations", -value=>"Take Action!"));
2039 :
2040 :			# existing location table
2041 :			# FIXME: the styles for this table should be off in a stylesheet
2042 :			# somewhere
2043 :			print CGI::start_div({align=>"center"}),
2044 :			CGI::start_table({border=>1, cellpadding=>2});
2045 :			print CGI::Tr({style=>"background-color:#e0e0e0;font-size:92%", align=>"left"},
2046 :	glarose	4917	CGI::th({}, ["Select", "Location", "Description",
2047 :			"Addresses"]));
2048 :	glarose	4910	foreach my $loc ( @locations ) {
2049 :	glarose	4917	my $editAddr = $self->systemLink($urlpath, params=>{subDisplay=>"manage_locations", manage_location_action=>"edit_location_form", edit_location=>$loc->location_id});
2050 :	glarose	4910	print CGI::Tr({valign=>'top',style=>"background-color:#eeeeee;"},
2051 :			CGI::td({style=>'font-size:85%;'},
2052 :	glarose	4917	[ CGI::checkbox(-name=>"delete_selected",
2053 :			-value=>$loc->location_id,
2054 :			-label=>''),
2055 :			CGI::a({href=>$editAddr}, $loc->location_id),
2056 :	glarose	4910	$loc->description,
2057 :			join(', ', @{$locAddr{$loc->location_id}}) ]));
2058 :			}
2059 :			print CGI::end_table(), CGI::end_div();
2060 :	glarose	4917	print CGI::end_form();
2061 :	glarose	4910
2062 :	glarose	4917
2063 :	glarose	4910	}
2064 :
2065 :			sub add_location_handler {
2066 :			my $self = shift();
2067 :			my $r = $self->r;
2068 :			my $db = $r->db;
2069 :
2070 :			# the location data we're to add
2071 :			my $locationID = $r->param("new_location_name");
2072 :			my $locationDescr = $r->param("new_location_description");
2073 :			my $locationAddr = $r->param("new_location_addresses");
2074 :			# break the addresses up
2075 :			$locationAddr =~ s/\s-\s/-/g;
2076 :			$locationAddr =~ s/\s\/\s/\//g;
2077 :			my @addresses = split(/\s+/, $locationAddr);
2078 :
2079 :			# sanity checks
2080 :			my $badAddr = '';
2081 :			foreach my $addr ( @addresses ) {
2082 :			unless ( new Net::IP($addr) ) {
2083 :			$badAddr .= "$addr, ";
2084 :			$locationAddr =~ s/$addr\n//s;
2085 :			}
2086 :			}
2087 :			$badAddr =~ s/, $//;
2088 :
2089 :			# a check to be sure that the location addresses don't already
2090 :			# exist
2091 :			my $badLocAddr;
2092 :			if ( ! $badAddr && $locationID ) {
2093 :			if ( $db->countLocationAddresses( $locationID ) ) {
2094 :			my @allLocAddr = $db->listLocationAddresses($locationID);
2095 :			foreach my $addr ( @addresses ) {
2096 :			$badLocAddr .= "$addr, "
2097 :			if ( grep {/^$addr$/} @allLocAddr );
2098 :			}
2099 :			$badLocAddr =~ s/, $//;
2100 :			}
2101 :			}
2102 :
2103 :			if ( ! @addresses \|\| ! $locationID \|\| ! $locationDescr ) {
2104 :			print CGI::div({-class=>"ResultsWithError"},
2105 :			"Missing required input data. Please check " .
2106 :			"that you have filled in all of the create " .
2107 :			"location fields and resubmit.");
2108 :			} elsif ( $badAddr ) {
2109 :			$r->param("new_location_addresses", $locationAddr);
2110 :			print CGI::div({-class=>"ResultsWithError"},
2111 :			"Address(es) $badAddr is(are) not in a " .
2112 :			"recognized form. Please check your " .
2113 :			"data entry and resubmit.");
2114 :			} elsif ( $db->existsLocation( $locationID ) ) {
2115 :			print CGI::div({-class=>"ResultsWithError"},
2116 :			"A location with the name $locationID " .
2117 :			"already exists in the database. Did " .
2118 :			"you mean to edit that location instead?");
2119 :			} elsif ( $badLocAddr ) {
2120 :			print CGI::div({-class=>"ResultsWithError"},
2121 :			"Address(es) $badLocAddr already exist " .
2122 :			"in the database. THIS SHOULD NOT HAPPEN! " .
2123 :			"Please double check the integrity of " .
2124 :			"the WeBWorK database before continuing.");
2125 :			} else {
2126 :			# add the location
2127 :			my $locationObj = $db->newLocation;
2128 :			$locationObj->location_id( $locationID );
2129 :			$locationObj->description( $locationDescr );
2130 :			$db->addLocation( $locationObj );
2131 :
2132 :			# and add the addresses
2133 :			foreach my $addr ( @addresses ) {
2134 :			my $locationAddress = $db->newLocationAddress;
2135 :			$locationAddress->location_id($locationID);
2136 :			$locationAddress->ip_mask($addr);
2137 :
2138 :			$db->addLocationAddress( $locationAddress );
2139 :			}
2140 :
2141 :			# we've added the location, so clear those param
2142 :			# entries
2143 :			$r->param('manage_location_action','none');
2144 :			$r->param('new_location_name','');
2145 :			$r->param('new_location_description','');
2146 :			$r->param('new_location_addresses','');
2147 :
2148 :			print CGI::div({-class=>"ResultsWithoutError"},
2149 :			"Location $locationID has been created, " .
2150 :			"with addresses " . join(', ', @addresses) .
2151 :			".");
2152 :			}
2153 :
2154 :			$self->manage_location_form;
2155 :			}
2156 :
2157 :			sub delete_location_handler {
2158 :			my $self = shift;
2159 :			my $r = $self->r;
2160 :			my $db = $r->db;
2161 :
2162 :			# what location are we deleting?
2163 :			my $locationID = $r->param("delete_location");
2164 :	glarose	4917	# check for selected deletions if appropriate
2165 :			my @delLocations = ( $locationID );
2166 :			if ( $locationID eq 'selected_locations' ) {
2167 :			@delLocations = $r->param("delete_selected");
2168 :			$locationID = @delLocations;
2169 :			}
2170 :	glarose	4910	# are we sure?
2171 :			my $confirm = $r->param("delete_confirm");
2172 :
2173 :	glarose	4917	my $badID;
2174 :	glarose	4910	if ( ! $locationID ) {
2175 :			print CGI::div({-class=>"ResultsWithError"},
2176 :			"Please provide a location name " .
2177 :			"to delete.");
2178 :
2179 :	glarose	4917	} elsif ( $badID = $self->existsLocations_helper( @delLocations ) ) {
2180 :	glarose	4910	print CGI::div({-class=>"ResultsWithError"},
2181 :	glarose	4917	"No location with name $badID " .
2182 :	glarose	4910	"exists in the database.");
2183 :
2184 :			} elsif ( ! $confirm \|\| $confirm ne 'true' ) {
2185 :			print CGI::div({-class=>"ResultsWithError"},
2186 :			"Location deletion requires confirmation.");
2187 :			} else {
2188 :	glarose	4917	foreach ( @delLocations ) {
2189 :			$db->deleteLocation( $_ );
2190 :			}
2191 :	glarose	4910	print CGI::div({-class=>"ResultsWithoutError"},
2192 :	glarose	4917	"Location" . (@delLocations > 1 ? 's ' : ' ') .
2193 :			join(', ', @delLocations) .
2194 :			(@delLocations > 1 ? ' have ' : ' has ' ) .
2195 :			'been deleted.');
2196 :	glarose	4910	$r->param('manage_location_action','none');
2197 :			$r->param('delete_location','');
2198 :			}
2199 :			$self->manage_location_form;
2200 :			}
2201 :	glarose	4917	sub existsLocations_helper {
2202 :			my ($self, @locations) = @_;
2203 :			my $db = $self->r->db;
2204 :			foreach ( @locations ) {
2205 :			return $_ if ( ! $db->existsLocation($_) );
2206 :			}
2207 :			return 0;
2208 :			}
2209 :	glarose	4910
2210 :			sub edit_location_form {
2211 :			my $self = shift;
2212 :			my $r = $self->r;
2213 :			my $db = $r->db;
2214 :
2215 :			my $locationID = $r->param("edit_location");
2216 :			if ( $db->existsLocation( $locationID ) ) {
2217 :			my $location = $db->getLocation($locationID);
2218 :			# this doesn't give that nice a sort for IP addresses,
2219 :			# b/c there's the problem with 192.168.1.168 sorting
2220 :			# ahead of 192.168.1.2. we could do better if we
2221 :			# either invoked Net::IP in the sort routine, or if
2222 :			# we insisted on dealing only with IPv4. rather than
2223 :			# deal with either of those, we'll leave this for now
2224 :			my @locAddresses = sort { $a cmp $b }
2225 :			$db->listLocationAddresses($locationID);
2226 :
2227 :			print CGI::h2("Editing location ", $locationID);
2228 :
2229 :			print CGI::p({},"Edit the current value of the location ",
2230 :			"description, if desired, then add and select ",
2231 :			"addresses to delete, and then click the ",
2232 :			"\"Take Action\" button to make all of your ",
2233 :			"changes. Or, click \"Manage Locations\" ",
2234 :			"above to make no changes and return to the ",
2235 :			"Manage Locations page.");
2236 :
2237 :			print CGI::start_form(-method=>"POST",
2238 :			-action=>$r->uri);
2239 :			print $self->hidden_authen_fields;
2240 :			print $self->hidden_fields("subDisplay");
2241 :			print CGI::hidden(-name=>'edit_location',
2242 :			-default=>$locationID);
2243 :			print CGI::hidden(-name=>'manage_location_action',
2244 :			-default=>'edit_location_handler');
2245 :
2246 :			print CGI::start_table();
2247 :			print CGI::Tr({-valign=>'top'},
2248 :			CGI::td({-colspan=>3},
2249 :			"Location description: ", CGI::br(),
2250 :			CGI::textfield(-name=>"location_description",
2251 :			-size=>"50",
2252 :			-default=>$location->description)));
2253 :			print CGI::Tr({-valign=>'top'},
2254 :			CGI::td({-width=>"50%"},
2255 :			"Addresses to add to the location " .
2256 :			"(enter one per line, as single IP addresses " .
2257 :			"(e.g., 192.168.1.101), address masks " .
2258 :			"(e.g., 192.168.1.0/24), or IP ranges " .
2259 :			"(e.g., 192.168.1.101-192.168.1.150)):" .
2260 :			CGI::br() .
2261 :			CGI::textarea({-name=>"new_location_addresses",
2262 :			-rows=>5, -columns=>28})),
2263 :			CGI::td({}, " "),
2264 :			CGI::td({-width=>"50%"},
2265 :			"Existing addresses for the location are " .
2266 :			"given in the scrolling list below. Select " .
2267 :			"addresses from the list to delete them:" .
2268 :			CGI::br() .
2269 :			CGI::scrolling_list(-name=>'delete_location_addresses',
2270 :			-values=>[@locAddresses],
2271 :			-size=>8,
2272 :			-multiple=>'multiple') .
2273 :			CGI::br() . "or: " .
2274 :			CGI::checkbox(-name=>'delete_all_addresses',
2275 :			-value=>'true',
2276 :			-label=>'Delete all existing addresses')
2277 :			));
2278 :
2279 :			print CGI::end_table();
2280 :
2281 :			print CGI::p({},CGI::submit(-value=>'Take Action!'));
2282 :
2283 :			} else {
2284 :			print CGI::div({-class=>"ResultsWithError"},
2285 :			"Location $locationID does not exist " .
2286 :			"in the WeBWorK database. Please check " .
2287 :			"your input (perhaps you need to reload " .
2288 :			"the location management page?).");
2289 :
2290 :			$self->manage_location_form;
2291 :			}
2292 :			}
2293 :
2294 :			sub edit_location_handler {
2295 :			my $self = shift;
2296 :			my $r = $self->r;
2297 :			my $db = $r->db;
2298 :
2299 :			my $locationID = $r->param("edit_location");
2300 :			my $locationDesc = $r->param("location_description");
2301 :			my $addAddresses = $r->param("new_location_addresses");
2302 :			my @delAddresses = $r->param("delete_location_addresses");
2303 :			my $deleteAll = $r->param("delete_all_addresses");
2304 :
2305 :			# gut check
2306 :			if ( ! $locationID ) {
2307 :			print CGI::div({-class=>"ResultsWithError"},
2308 :			"No location specified to edit?! " .
2309 :			"Please check your input data.");
2310 :			$self->manage_location_form;
2311 :
2312 :			} elsif ( ! $db->existsLocation( $locationID ) ) {
2313 :			print CGI::div({-class=>"ResultsWithError"},
2314 :			"Location $locationID does not exist " .
2315 :			"in the WeBWorK database. Please check " .
2316 :			"your input (perhaps you need to reload " .
2317 :			"the location management page?).");
2318 :			$self->manage_location_form;
2319 :			} else {
2320 :			my $location = $db->getLocation($locationID);
2321 :
2322 :			# get the current location addresses. if we're deleting
2323 :			# all of the existing addresses, we don't use this list
2324 :			# to determine which addresses to add, however.
2325 :			my @currentAddr = $db->listLocationAddresses($locationID);
2326 :			my @compareAddr = ( ! $deleteAll \|\| $deleteAll ne 'true' )
2327 :			? @currentAddr : ();
2328 :
2329 :			my $doneMsg = '';
2330 :
2331 :			if ($locationDesc && $location->description ne $locationDesc) {
2332 :			$location->description($locationDesc);
2333 :			$db->putLocation($location);
2334 :			$doneMsg .= CGI::p({},"Updated location description.");
2335 :			}
2336 :			# get the actual addresses to add out of the text field
2337 :			$addAddresses =~ s/\s-\s/-/g;
2338 :			$addAddresses =~ s/\s\/\s/\//g;
2339 :			my @addAddresses = split(/\s+/, $addAddresses);
2340 :
2341 :			# make sure that we're adding and deleting only those
2342 :			# addresses that are not yet/currently in the location
2343 :			# addresses
2344 :			my @toAdd = (); my @noAdd = ();
2345 :			my @toDel = (); my @noDel = ();
2346 :			foreach my $addr ( @addAddresses ) {
2347 :			if (grep {/^$addr$/} @compareAddr) {push(@noAdd,$addr);}
2348 :			else { push(@toAdd, $addr); }
2349 :			}
2350 :			if ( $deleteAll && $deleteAll eq 'true' ) {
2351 :			@toDel = @currentAddr;
2352 :			} else {
2353 :			foreach my $addr ( @delAddresses ) {
2354 :			if (grep {/^$addr$/} @currentAddr) {
2355 :			push(@toDel,$addr);
2356 :			} else { push(@noDel, $addr); }
2357 :			}
2358 :			}
2359 :
2360 :			# and make sure that all of the addresses we're adding are
2361 :			# a sensible form
2362 :			my $badAddr = '';
2363 :			foreach my $addr ( @toAdd ) {
2364 :			unless ( new Net::IP($addr) ) {
2365 :			$badAddr .= "$addr, ";
2366 :			}
2367 :			}
2368 :			$badAddr =~ s/, $//;
2369 :
2370 :			# delete addresses first, because we allow deletion of
2371 :			# all existing addresses, then addition of addresses.
2372 :			# note that we don't allow deletion and then addition
2373 :			# of the same address normally, however; in that case
2374 :			# we'll end up just deleting the address.
2375 :			foreach ( @toDel ) {
2376 :			$db->deleteLocationAddress($locationID, $_);
2377 :			}
2378 :			foreach ( @toAdd ) {
2379 :			my $locAddr = $db->newLocationAddress;
2380 :			$locAddr->location_id($locationID);
2381 :			$locAddr->ip_mask($_);
2382 :
2383 :			$db->addLocationAddress($locAddr);
2384 :			}
2385 :
2386 :			my $addrMsg = '';
2387 :			$addrMsg .= "Deleted addresses " . join(', ', @toDel) .
2388 :			" from location." . CGI::br() if ( @toDel );
2389 :			$addrMsg .= "Added addresses " . join(', ', @toAdd) .
2390 :			" to location $locationID. " if ( @toAdd );
2391 :
2392 :			my $badMsg = '';
2393 :			$badMsg .= 'Address(es) ' . join(', ', @noAdd) .
2394 :			" in the add list is(are) already in the " .
2395 :			"location $locationID, and so were " .
2396 :			"skipped." . CGI::br() if ( @noAdd );
2397 :			$badMsg .= "Address(es) $badAddr is(are) not in a " .
2398 :			"recognized form. Please check your data " .
2399 :			"entry and try again." . CGI::br() if ( $badAddr );
2400 :			$badMsg .= 'Address(es) ' . join(', ', @noDel) .
2401 :			" in the delete list is(are) not in the " .
2402 :			"location $locationID, and so were " .
2403 :			"skipped." if ( @noDel );
2404 :
2405 :			print CGI::div({-class=>"ResultsWithError"}, $badMsg)
2406 :			if ( $badMsg );
2407 :			if ( $doneMsg \|\| $addrMsg ) {
2408 :			print CGI::div({-class=>"ResultsWithoutError"},
2409 :			CGI::p({}, $doneMsg, $addrMsg));
2410 :			} else {
2411 :			print CGI::div({-class=>"ResultsWithError"},
2412 :			"No valid changes submitted for ",
2413 :			"location $locationID.");
2414 :			}
2415 :
2416 :			$self->edit_location_form;
2417 :			}
2418 :			}
2419 :
2420 :			################################################################################
2421 :	sh002i	1945	1;

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9