Diff of /branches/rel-2-4-patches/webwork2/lib/WeBWorK/ContentGenerator/CourseAdmin.pm

Revision 3621		Revision 4918
1	################################################################################	1	################################################################################
2	# WeBWorK Online Homework Delivery System	2	# WeBWorK Online Homework Delivery System
3	# Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/	3	# Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/
4	# $CVSHeader: webwork-modperl/lib/WeBWorK/ContentGenerator/CourseAdmin.pm,v 1.40 2005/08/14 16:51:15 gage Exp $	4	# $CVSHeader: webwork2/lib/WeBWorK/ContentGenerator/CourseAdmin.pm,v 1.63 2007/03/30 14:21:14 glarose Exp $
5	#	5	#
6	# This program is free software; you can redistribute it and/or modify it under	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	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	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.	9	# version, or (b) the "Artistic License" which comes with this package.
…		…
23		23
24	=cut	24	=cut
25		25
26	use strict;	26	use strict;
27	use warnings;	27	use warnings;
28	use CGI::Pretty qw();	28	#use CGI qw(-nosticky );
		29	use WeBWorK::CGI;
29	use Data::Dumper;	30	use Data::Dumper;
30	use File::Temp qw/tempfile/;	31	use File::Temp qw/tempfile/;
31	use WeBWorK::CourseEnvironment;	32	use WeBWorK::CourseEnvironment;
32	use IO::File;	33	use IO::File;
		34	use WeBWorK::Debug;
33	use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive);	35	use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive);
34	use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse);	36	use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse
		37	listArchivedCourses unarchiveCourse);
35	use WeBWorK::Utils::DBImportExport qw(dbExport dbImport);	38	use WeBWorK::Utils::DBImportExport qw(dbExport dbImport);
		39	# needed for location management
		40	use Net::IP;
36		41
37	# put the following database layouts at the top of the list, in this order	42	use constant IMPORT_EXPORT_WARNING => "The ability to import and export
38	our @DB_LAYOUT_ORDER = qw/sql_single gdbm sql/;	43	databases is still under development. It seems to work but it is <b>VERY</b>
39		44	slow on large courses. You may prefer to use webwork2/bin/wwdb or the mysql
40	our %DB_LAYOUT_DESCRIPTIONS = (	45	dump facility for archiving large courses. Please send bug reports if you find
41	gdbm => CGI::i("Deprecated. Uses GDBM databases to record WeBWorK data. Use this layout if the course must be used with WeBWorK 1.x."),	46	errors.";
42	sql => CGI::i("Deprecated. Uses a separate SQL database to record WeBWorK data for each course."),
43	sql_single => "Uses a single SQL database to record WeBWorK data for all courses using this layout. This is the recommended layout for new courses.",
44	);
45		47
46	sub pre_header_initialize {	48	sub pre_header_initialize {
47	my ($self) = @_;	49	my ($self) = @_;
48	my $r = $self->r;	50	my $r = $self->r;
49	my $ce = $r->ce;	51	my $ce = $r->ce;
…		…
185	} else {	187	} else {
186	# form only	188	# form only
187	$method_to_call = "archive_course_form";	189	$method_to_call = "archive_course_form";
188	}	190	}
189	}	191	}
		192	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	}
190		213	}
		214	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	}
191	else {	223	else {
192	@errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}.";	224	@errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}.";
193	}	225	}
194
195	}	226	}
196		227
197	$self->{errors} = \@errors;	228	$self->{errors} = \@errors;
198	$self->{method_to_call} = $method_to_call;	229	$self->{method_to_call} = $method_to_call;
199	}	230	}
…		…
275	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"export_database"})}, "Export Database"),	306	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"export_database"})}, "Export Database"),
276	" \| ",	307	" \| ",
277	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"),	308	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"),
278	" \| ",	309	" \| ",
279	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"archive_course"})}, "Archive Course"),	310	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"archive_course"})}, "Archive Course"),
		311	"\|",
		312	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"unarchive_course"})}, "Unarchive Course"),
		313	"\|",
		314	CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"manage_locations"})}, "Manage Locations"),
280	CGI::hr(),	315	CGI::hr(),
281	$methodMessage,	316	$methodMessage,
282		317
283	);	318	);
284
285	print CGI::p("The ability to import and to export databases is still under development.
286	It seems to work but it is <b>VERY</b> slow on large courses. You may prefer to
287	use webwork2/bin/wwdb or the mysql dump facility for archiving large courses.
288	Please send bug reports if you find errors. ");
289		319
290	my @errors = @{$self->{errors}};	320	my @errors = @{$self->{errors}};
291		321
292		322
293	if (@errors) {	323	if (@errors) {
…		…
324	);	354	);
325		355
326	}	356	}
327		357
328	print CGI::end_ol();	358	print CGI::end_ol();
		359
		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();
329	}	369	}
330	return "";	370	return "";
331	}	371	}
332		372
333	################################################################################	373	################################################################################
…		…
354	my $add_initial_email = $r->param("add_initial_email") \|\| "";	394	my $add_initial_email = $r->param("add_initial_email") \|\| "";
355		395
356	my $add_templates_course = $r->param("add_templates_course") \|\| "";	396	my $add_templates_course = $r->param("add_templates_course") \|\| "";
357		397
358	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";	398	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";
359	my $add_sql_host = $r->param("add_sql_host") \|\| "";
360	my $add_sql_port = $r->param("add_sql_port") \|\| "";
361	my $add_sql_username = $r->param("add_sql_username") \|\| "";
362	my $add_sql_password = $r->param("add_sql_password") \|\| "";
363	my $add_sql_database = $r->param("add_sql_database") \|\| "";
364	my $add_sql_wwhost = $r->param("add_sql_wwhost") \|\| "";
365	my $add_gdbm_globalUserID = $r->param("add_gdbm_globalUserID") \|\| "";
366		399
367	my @dbLayouts = do {	400	my @dbLayouts = do {
368	my @ordered_layouts;	401	my @ordered_layouts;
369	foreach my $layout (@DB_LAYOUT_ORDER) {	402	foreach my $layout (@{$ce->{dbLayout_order}}) {
370	if (exists $ce->{dbLayouts}->{$layout}) {	403	if (exists $ce->{dbLayouts}->{$layout}) {
371	push @ordered_layouts, $layout;	404	push @ordered_layouts, $layout;
372	}	405	}
373	}	406	}
374		407
…		…
388	$ce->{webworkURLs}->{root},	421	$ce->{webworkURLs}->{root},
389	$ce->{pg}->{directories}->{root},	422	$ce->{pg}->{directories}->{root},
390	"COURSENAME",	423	"COURSENAME",
391	);	424	);
392		425
393	my $dbi_source = do {
394	# find the most common SQL source (stolen from CourseManagement.pm)
395	my %sources;
396	foreach my $table (keys %{ $ce2->{dbLayouts}->{sql} }) {
397	$sources{$ce2->{dbLayouts}->{sql}->{$table}->{source}}++;
398	}
399	my $source;
400	if (keys %sources > 1) {
401	foreach my $curr (keys %sources) {
402	$source = $curr if not defined $source or
403	$sources{$curr} > $sources{$source};
404	}
405	} else {
406	($source) = keys %sources;
407	}
408	$source;
409	};
410
411	my @existingCourses = listCourses($ce);	426	my @existingCourses = listCourses($ce);
412	@existingCourses = sort { lc($a) cmp lc ($b) } @existingCourses; #make sort case insensitive	427	@existingCourses = sort { lc($a) cmp lc ($b) } @existingCourses; #make sort case insensitive
413		428
414	print CGI::h2("Add Course");	429	print CGI::h2("Add Course");
415		430
416	print CGI::start_form("POST", $r->uri);	431	print CGI::start_form(-method=>"POST", -action=>$r->uri);
417	print $self->hidden_authen_fields;	432	print $self->hidden_authen_fields;
418	print $self->hidden_fields("subDisplay");	433	print $self->hidden_fields("subDisplay");
419		434
420	print CGI::p("Specify an ID, title, and institution for the new course. The course ID may contain only letters, numbers, hyphens, and underscores.");	435	print CGI::p("Specify an ID, title, and institution for the new course. The course ID may contain only letters, numbers, hyphens, and underscores.");
421		436
422	print CGI::table({class=>"FormLayout"},	437	print CGI::table({class=>"FormLayout"},
423	CGI::Tr(	438	CGI::Tr({},
424	CGI::th({class=>"LeftHeader"}, "Course ID:"),	439	CGI::th({class=>"LeftHeader"}, "Course ID:"),
425	CGI::td(CGI::textfield("add_courseID", $add_courseID, 25)),	440	CGI::td(CGI::textfield(-name=>"add_courseID", -value=>$add_courseID, -size=>25)),
426	),	441	),
427	CGI::Tr(	442	CGI::Tr({},
428	CGI::th({class=>"LeftHeader"}, "Course Title:"),	443	CGI::th({class=>"LeftHeader"}, "Course Title:"),
429	CGI::td(CGI::textfield("add_courseTitle", $add_courseTitle, 25)),	444	CGI::td(CGI::textfield(-name=>"add_courseTitle", -value=>$add_courseTitle, -size=>25)),
430	),	445	),
431	CGI::Tr(	446	CGI::Tr({},
432	CGI::th({class=>"LeftHeader"}, "Institution:"),	447	CGI::th({class=>"LeftHeader"}, "Institution:"),
433	CGI::td(CGI::textfield("add_courseInstitution", $add_courseInstitution, 25)),	448	CGI::td(CGI::textfield(-name=>"add_courseInstitution", -value=>$add_courseInstitution, -size=>25)),
434	),	449	),
435	);	450	);
436		451
437	print CGI::p("To add the WeBWorK administrators to the new course (as instructors) check the box below.");	452	print CGI::p("To add the WeBWorK administrators to the new course (as instructors) check the box below.");
438	my $checked = ($add_admin_users) ?"checked": ""; # workaround because CGI::checkbox seems to have a bug -- it won't default to checked.	453	my @checked = ($add_admin_users) ?(checked=>1): (); # workaround because CGI::checkbox seems to have a bug -- it won't default to checked.
439	print CGI::p(CGI::input({-type=>'checkbox', -name=>"add_admin_users", $checked=>'' }, "Add WeBWorK administrators to new course"));	454	print CGI::p({},CGI::input({-type=>'checkbox', -name=>"add_admin_users", @checked }, "Add WeBWorK administrators to new course"));
440		455
441	print CGI::p("To add an additional instructor to the new course, specify user information below. The user ID may contain only numbers, letters, hyphens, and underscores.");	456	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");
442		458
443	print CGI::table({class=>"FormLayout"}, CGI::Tr(	459	print CGI::table({class=>"FormLayout"}, CGI::Tr({},
444	CGI::td(	460	CGI::td({},
445	CGI::table({class=>"FormLayout"},	461	CGI::table({class=>"FormLayout"},
446	CGI::Tr(	462	CGI::Tr({},
447	CGI::th({class=>"LeftHeader"}, "User ID:"),	463	CGI::th({class=>"LeftHeader"}, "User ID:"),
448	CGI::td(CGI::textfield("add_initial_userID", $add_initial_userID, 25)),	464	CGI::td(CGI::textfield(-name=>"add_initial_userID", -value=>$add_initial_userID, -size=>25)),
449	),	465	),
450	CGI::Tr(	466	CGI::Tr({},
451	CGI::th({class=>"LeftHeader"}, "Password:"),	467	CGI::th({class=>"LeftHeader"}, "Password:"),
452	CGI::td(CGI::password_field("add_initial_password", $add_initial_password, 25)),	468	CGI::td(CGI::password_field(-name=>"add_initial_password", -value=>$add_initial_password, -size=>25)),
453	),	469	),
454	CGI::Tr(	470	CGI::Tr({},
455	CGI::th({class=>"LeftHeader"}, "Confirm Password:"),	471	CGI::th({class=>"LeftHeader"}, "Confirm Password:"),
456	CGI::td(CGI::password_field("add_initial_confirmPassword", $add_initial_confirmPassword, 25)),	472	CGI::td(CGI::password_field(-name=>"add_initial_confirmPassword", -value=>$add_initial_confirmPassword, -size=>25)),
457	),	473	),
458	),	474	),
459	),	475	),
460	CGI::td(	476	CGI::td({},
461	CGI::table({class=>"FormLayout"},	477	CGI::table({class=>"FormLayout"},
462	CGI::Tr(	478	CGI::Tr({},
463	CGI::th({class=>"LeftHeader"}, "First Name:"),	479	CGI::th({class=>"LeftHeader"}, "First Name:"),
464	CGI::td(CGI::textfield("add_initial_firstName", $add_initial_firstName, 25)),	480	CGI::td(CGI::textfield(-name=>"add_initial_firstName", -value=>$add_initial_firstName, -size=>25)),
465	),	481	),
466	CGI::Tr(	482	CGI::Tr({},
467	CGI::th({class=>"LeftHeader"}, "Last Name:"),	483	CGI::th({class=>"LeftHeader"}, "Last Name:"),
468	CGI::td(CGI::textfield("add_initial_lastName", $add_initial_lastName, 25)),	484	CGI::td(CGI::textfield(-name=>"add_initial_lastName", -value=>$add_initial_lastName, -size=>25)),
469	),	485	),
470	CGI::Tr(	486	CGI::Tr({},
471	CGI::th({class=>"LeftHeader"}, "Email Address:"),	487	CGI::th({class=>"LeftHeader"}, "Email Address:"),
472	CGI::td(CGI::textfield("add_initial_email", $add_initial_email, 25)),	488	CGI::td(CGI::textfield(-name=>"add_initial_email", -value=>$add_initial_email, -size=>25)),
473	),	489	),
474	),	490	),
475		491
476	),	492	),
477	));	493	));
478		494
479	print CGI::p("To copy problem templates from an existing course, select the course below.");	495	print CGI::p("To copy problem templates from an existing course, select the course below.");
480		496
481	print CGI::table({class=>"FormLayout"},	497	print CGI::table({class=>"FormLayout"},
482	CGI::Tr(	498	CGI::Tr({},
483	CGI::th({class=>"LeftHeader"}, "Copy templates from:"),	499	CGI::th({class=>"LeftHeader"}, "Copy templates from:"),
484	CGI::td(	500	CGI::td(
485	CGI::popup_menu(	501	CGI::popup_menu(
486	-name => "add_templates_course",	502	-name => "add_templates_course",
487	-values => [ "", @existingCourses ],	503	-values => [ "", @existingCourses ],
…		…
493		509
494	),	510	),
495	),	511	),
496	);	512	);
497		513
		514
		515
498	print CGI::p("Select a database layout below.");	516	print CGI::p("Select a database layout below.");
		517	print CGI::start_table({class=>"FormLayout"});
499		518
		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);
500	foreach my $dbLayout (@dbLayouts) {	522	foreach my $dbLayout (@dbLayouts) {
501	print CGI::start_table({class=>"FormLayout"});	523	my $dbLayoutLabel = (defined $ce->{dbLayout_descr}{$dbLayout})
502		524	? "$dbLayout - " . $ce->{dbLayout_descr}{$dbLayout}
503	my $dbLayoutLabel = (defined $DB_LAYOUT_DESCRIPTIONS{$dbLayout})	525	: "$dbLayout - no description provided in global.conf";
504	? "$dbLayout - $DB_LAYOUT_DESCRIPTIONS{$dbLayout}"
505	: $dbLayout;
506
507	# we generate singleton radio button tags ourselves because it's too much of a pain to do it with CGI.pm
508	print CGI::Tr(	526	print CGI::Tr({},
509	CGI::td({style=>"text-align: right"},	527	CGI::td({width=>'20%'}, $dbLayout_buttons{$dbLayout}),
510	'<input type="radio" name="add_dbLayout" value="' . $dbLayout . '"'
511	. ($add_dbLayout eq $dbLayout ? " checked" : "") . ' />',
512	),
513	CGI::td($dbLayoutLabel),	528	CGI::td($dbLayoutLabel),
514	);	529	);
515
516	print CGI::start_Tr();
517	print CGI::td(); # for indentation :(
518	print CGI::start_td();
519
520
521	if ($dbLayout eq "sql") {
522
523	print CGI::p({style=>'font-style:italic'},"The following information is only required for the deprecated sql database format:");
524	print CGI::start_table({class=>"FormLayout"});
525	print CGI::Tr(CGI::td({colspan=>2},
526	"Enter the user ID and password for an SQL account with sufficient permissions to create a new database."
527	)
528	);
529	print CGI::Tr(
530	CGI::th({class=>"LeftHeader"}, "SQL Admin Username:"),
531	CGI::td(CGI::textfield("add_sql_username", $add_sql_username, 25)),
532	);
533	print CGI::Tr(
534	CGI::th({class=>"LeftHeader"}, "SQL Admin Password:"),
535	CGI::td(CGI::password_field("add_sql_password", $add_sql_password, 25)),
536	);
537
538	print CGI::Tr(CGI::td({colspan=>2},
539	"The optionial SQL settings you enter below must match the settings in the DBI source"
540	. " specification " . CGI::tt($dbi_source) . ". Replace " . CGI::tt("COURSENAME")
541	. " with the course name you entered above."
542	)
543	);
544	print CGI::Tr(
545	CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
546	CGI::td(
547	CGI::textfield("add_sql_host", $add_sql_host, 25),
548	CGI::br(),
549	CGI::small("Leave blank to use the default host."),
550	),
551	);
552	print CGI::Tr(
553	CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
554	CGI::td(
555	CGI::textfield("add_sql_port", $add_sql_port, 25),
556	CGI::br(),
557	CGI::small("Leave blank to use the default port."),
558	),
559	);
560
561	print CGI::Tr(
562	CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
563	CGI::td(
564	CGI::textfield("add_sql_database", $add_sql_database, 25),
565	CGI::br(),
566	CGI::small("Leave blank to use the name ", CGI::tt("webwork_COURSENAME"), "."),
567	),
568	);
569	print CGI::Tr(
570	CGI::th({class=>"LeftHeader"}, "WeBWorK Host:"),
571	CGI::td(
572	CGI::textfield("add_sql_wwhost", $add_sql_wwhost \|\| "localhost", 25),
573	CGI::br(),
574	CGI::small("If the SQL server does not run on the same host as WeBWorK, enter the host name of the WeBWorK server as seen by the SQL server."),
575	),
576	);
577	print CGI::end_table();
578	} elsif ($dbLayout eq "gdbm") {
579	print CGI::p({style=>"font-style: italic"},"The following information is only required for the deprecated gdbm database format:");
580	print CGI::start_table({class=>"FormLayout"});
581	print CGI::Tr(
582	CGI::th({class=>"LeftHeader"}, "GDBM Global User ID:"),
583	CGI::td(CGI::textfield("add_gdbm_globalUserID", $add_gdbm_globalUserID \|\| "global_user", 25)),
584	);
585	print CGI::end_table();
586	}	530	}
587
588	print CGI::end_td();
589	print CGI::end_Tr();
590	print CGI::end_table();	531	print CGI::end_table();
591	}
592
593	print CGI::p({style=>"text-align: center"}, CGI::submit("add_course", "Add Course"));	532	print CGI::p({style=>"text-align: left"}, CGI::submit(-name=>"add_course", -label=>"Add Course"));
594		533
595	print CGI::end_form();	534	print CGI::end_form();
596	}	535	}
597		536
598	sub add_course_validate {	537	sub add_course_validate {
…		…
617	my $add_initial_email = $r->param("add_initial_email") \|\| "";	556	my $add_initial_email = $r->param("add_initial_email") \|\| "";
618		557
619	my $add_templates_course = $r->param("add_templates_course") \|\| "";	558	my $add_templates_course = $r->param("add_templates_course") \|\| "";
620		559
621	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";	560	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";
622	my $add_sql_host = $r->param("add_sql_host") \|\| "";
623	my $add_sql_port = $r->param("add_sql_port") \|\| "";
624	my $add_sql_username = $r->param("add_sql_username") \|\| "";
625	my $add_sql_password = $r->param("add_sql_password") \|\| "";
626	my $add_sql_database = $r->param("add_sql_database") \|\| "";
627	my $add_sql_wwhost = $r->param("add_sql_wwhost") \|\| "";
628	my $add_gdbm_globalUserID = $r->param("add_gdbm_globalUserID") \|\| "";
629		561
630	my @errors;	562	my @errors;
631		563
632	if ($add_courseID eq "") {	564	if ($add_courseID eq "") {
633	push @errors, "You must specify a course ID.";	565	push @errors, "You must specify a course ID.";
…		…
636	push @errors, "Course ID may only contain letters, numbers, hyphens, and underscores.";	568	push @errors, "Course ID may only contain letters, numbers, hyphens, and underscores.";
637	}	569	}
638	if (grep { $add_courseID eq $_ } listCourses($ce)) {	570	if (grep { $add_courseID eq $_ } listCourses($ce)) {
639	push @errors, "A course with ID $add_courseID already exists.";	571	push @errors, "A course with ID $add_courseID already exists.";
640	}	572	}
641	if ($add_courseTitle eq "") {	573	#if ($add_courseTitle eq "") {
642	push @errors, "You must specify a course title.";	574	# push @errors, "You must specify a course title.";
643	}	575	#}
644	if ($add_courseInstitution eq "") {	576	#if ($add_courseInstitution eq "") {
645	push @errors, "You must specify an institution for this course.";	577	# push @errors, "You must specify an institution for this course.";
646	}	578	#}
647		579
648	if ($add_initial_userID ne "") {	580	if ($add_initial_userID ne "") {
649	if ($add_initial_password eq "") {	581	if ($add_initial_password eq "") {
650	push @errors, "You must specify a password for the initial instructor.";	582	push @errors, "You must specify a password for the initial instructor.";
651	}	583	}
…		…
668		600
669	if ($add_dbLayout eq "") {	601	if ($add_dbLayout eq "") {
670	push @errors, "You must select a database layout.";	602	push @errors, "You must select a database layout.";
671	} else {	603	} else {
672	if (exists $ce->{dbLayouts}->{$add_dbLayout}) {	604	if (exists $ce->{dbLayouts}->{$add_dbLayout}) {
673	if ($add_dbLayout eq "sql") {	605	# we used to check for layout-specific fields here, but there aren't any layouts that require them
674	push @errors, "You must specify the SQL admin username." if $add_sql_username eq "";	606	# anymore. (in the future, we'll probably deal with this in layout-specific modules.)
675	push @errors, "You must specify the WeBWorK host." if $add_sql_wwhost eq "";
676	} elsif ($add_dbLayout eq "gdbm") {
677	push @errors, "You must specify the GDBM global user ID." if $add_gdbm_globalUserID eq "";
678	}
679	} else {	607	} else {
680	push @errors, "The database layout $add_dbLayout doesn't exist.";	608	push @errors, "The database layout $add_dbLayout doesn't exist.";
681	}	609	}
682	}	610	}
683		611
…		…
687	sub do_add_course {	615	sub do_add_course {
688	my ($self) = @_;	616	my ($self) = @_;
689	my $r = $self->r;	617	my $r = $self->r;
690	my $ce = $r->ce;	618	my $ce = $r->ce;
691	my $db = $r->db;	619	my $db = $r->db;
692	#my $authz = $r->authz;	620	my $authz = $r->authz;
693	my $urlpath = $r->urlpath;	621	my $urlpath = $r->urlpath;
694		622
695	my $add_courseID = $r->param("add_courseID") \|\| "";	623	my $add_courseID = $r->param("add_courseID") \|\| "";
696	my $add_courseTitle = $r->param("add_courseTitle") \|\| "";	624	my $add_courseTitle = $r->param("add_courseTitle") \|\| "";
697	my $add_courseInstitution = $r->param("add_courseInstitution") \|\| "";	625	my $add_courseInstitution = $r->param("add_courseInstitution") \|\| "";
…		…
706	my $add_initial_email = $r->param("add_initial_email") \|\| "";	634	my $add_initial_email = $r->param("add_initial_email") \|\| "";
707		635
708	my $add_templates_course = $r->param("add_templates_course") \|\| "";	636	my $add_templates_course = $r->param("add_templates_course") \|\| "";
709		637
710	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";	638	my $add_dbLayout = $r->param("add_dbLayout") \|\| "";
711	my $add_sql_host = $r->param("add_sql_host") \|\| "";
712	my $add_sql_port = $r->param("add_sql_port") \|\| "";
713	my $add_sql_username = $r->param("add_sql_username") \|\| "";
714	my $add_sql_password = $r->param("add_sql_password") \|\| "";
715	my $add_sql_database = $r->param("add_sql_database") \|\| "";
716	my $add_sql_wwhost = $r->param("add_sql_wwhost") \|\| "";
717	my $add_gdbm_globalUserID = $r->param("add_gdbm_globalUserID") \|\| "";
718		639
719	my $ce2 = WeBWorK::CourseEnvironment->new(	640	my $ce2 = WeBWorK::CourseEnvironment->new(
720	$ce->{webworkDirs}->{root},	641	$ce->{webworkDirs}->{root},
721	$ce->{webworkURLs}->{root},	642	$ce->{webworkURLs}->{root},
722	$ce->{pg}->{directories}->{root},	643	$ce->{pg}->{directories}->{root},
…		…
730	# don't set feedbackRecipients -- this just gets in the way of the more	651	# don't set feedbackRecipients -- this just gets in the way of the more
731	# intelligent "receive_recipients" method.	652	# intelligent "receive_recipients" method.
732	#$courseOptions{feedbackRecipients} = [ $add_initial_email ];	653	#$courseOptions{feedbackRecipients} = [ $add_initial_email ];
733	}	654	}
734		655
735	if ($add_dbLayout eq "gdbm") {	656	# this is kinda left over from when we had 'gdbm' and 'sql' database layouts
736	$courseOptions{globalUserID} = $add_gdbm_globalUserID if $add_gdbm_globalUserID ne "";	657	# below this line, we would grab values from getopt and put them in this hash
737	}	658	# but for now the hash can remain empty
738
739	my %dbOptions;	659	my %dbOptions;
740	if ($add_dbLayout eq "sql") {
741	$dbOptions{host} = $add_sql_host if $add_sql_host ne "";
742	$dbOptions{port} = $add_sql_port if $add_sql_port ne "";
743	$dbOptions{username} = $add_sql_username;
744	$dbOptions{password} = $add_sql_password;
745	$dbOptions{database} = $add_sql_database \|\| "webwork_$add_courseID";
746	$dbOptions{wwhost} = $add_sql_wwhost;
747	}
748		660
749	my @users;	661	my @users;
750		662
751	# copy users from current (admin) course if desired	663	# copy users from current (admin) course if desired
752	if ($add_admin_users ne "") {	664	if ($add_admin_users ne "") {
…		…
756	next;	668	next;
757	}	669	}
758	my $User = $db->getUser($userID);	670	my $User = $db->getUser($userID);
759	my $Password = $db->getPassword($userID);	671	my $Password = $db->getPassword($userID);
760	my $PermissionLevel = $db->getPermissionLevel($userID);	672	my $PermissionLevel = $db->getPermissionLevel($userID);
761	push @users, [ $User, $Password, $PermissionLevel ];	673	push @users, [ $User, $Password, $PermissionLevel ]
		674	if $authz->hasPermissions($userID,"create_and_delete_courses");
		675	#only transfer the "instructors" in the admin course classlist.
762	}	676	}
763	}	677	}
764		678
765	# add initial instructor if desired	679	# add initial instructor if desired
766	if ($add_initial_userID ne "") {	680	if ($add_initial_userID ne "") {
…		…
819	}	733	}
820	} else {	734	} else {
821	#log the action	735	#log the action
822	writeLog($ce, "hosted_courses", join("\t",	736	writeLog($ce, "hosted_courses", join("\t",
823	"\tAdded",	737	"\tAdded",
824	$add_courseInstitution,	738	( defined $add_courseInstitution ? $add_courseInstitution : "(no institution specified)" ),
825	$add_courseTitle,	739	( defined $add_courseTitle ? $add_courseTitle : "(no title specified)" ),
826	$add_courseID,	740	$add_courseID,
827	$add_initial_firstName,	741	$add_initial_firstName,
828	$add_initial_lastName,	742	$add_initial_lastName,
829	$add_initial_email,	743	$add_initial_email,
830	));	744	));
831	# add contact to admin course as student?	745	# add contact to admin course as student?
832	# FIXME -- should we do this?	746	# FIXME -- should we do this?
		747	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	}
833	print CGI::div({class=>"ResultsWithoutError"},	776	print CGI::div({class=>"ResultsWithoutError"},
834	CGI::p("Successfully created the course $add_courseID"),	777	CGI::p("Successfully created the course $add_courseID"),
835	);	778	);
836	my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets",	779	my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets",
837	courseID => $add_courseID);	780	courseID => $add_courseID);
…		…
854	#my $authz = $r->authz;	797	#my $authz = $r->authz;
855	#my $urlpath = $r->urlpath;	798	#my $urlpath = $r->urlpath;
856		799
857	my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";	800	my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";
858	my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";	801	my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";
859
860	my $rename_sql_host = $r->param("rename_sql_host") \|\| "";
861	my $rename_sql_port = $r->param("rename_sql_port") \|\| "";
862	my $rename_sql_username = $r->param("rename_sql_username") \|\| "";
863	my $rename_sql_password = $r->param("rename_sql_password") \|\| "";
864	my $rename_sql_oldDatabase = $r->param("rename_sql_oldDatabase") \|\| "";
865	my $rename_sql_newDatabase = $r->param("rename_sql_newDatabase") \|\| "";
866	my $rename_sql_wwhost = $r->param("rename_sql_wwhost") \|\| "";
867		802
868	my @courseIDs = listCourses($ce);	803	my @courseIDs = listCourses($ce);
869	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs;	804	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs;
870		805
871	my %courseLabels; # records... heh.	806	my %courseLabels; # records... heh.
…		…
879	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";	814	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
880	}	815	}
881		816
882	print CGI::h2("Rename Course");	817	print CGI::h2("Rename Course");
883		818
884	print CGI::start_form("POST", $r->uri);	819	print CGI::start_form(-method=>"POST", -action=>$r->uri);
885	print $self->hidden_authen_fields;	820	print $self->hidden_authen_fields;
886	print $self->hidden_fields("subDisplay");	821	print $self->hidden_fields("subDisplay");
887		822
888	print CGI::p("Select a course to rename.");	823	print CGI::p("Select a course to rename.");
889		824
890	print CGI::table({class=>"FormLayout"},	825	print CGI::table({class=>"FormLayout"},
891	CGI::Tr(	826	CGI::Tr({},
892	CGI::th({class=>"LeftHeader"}, "Course Name:"),	827	CGI::th({class=>"LeftHeader"}, "Course Name:"),
893	CGI::td(	828	CGI::td(
894	CGI::scrolling_list(	829	CGI::scrolling_list(
895	-name => "rename_oldCourseID",	830	-name => "rename_oldCourseID",
896	-values => \@courseIDs,	831	-values => \@courseIDs,
…		…
899	-multiple => 0,	834	-multiple => 0,
900	-labels => \%courseLabels,	835	-labels => \%courseLabels,
901	),	836	),
902	),	837	),
903	),	838	),
904	CGI::Tr(	839	CGI::Tr({},
905	CGI::th({class=>"LeftHeader"}, "New Name:"),	840	CGI::th({class=>"LeftHeader"}, "New Name:"),
906	CGI::td(CGI::textfield("rename_newCourseID", $rename_newCourseID, 25)),	841	CGI::td(CGI::textfield(-name=>"rename_newCourseID", -value=>$rename_newCourseID, -size=>25)),
907	),	842	),
908	);	843	);
909		844
910	print CGI::p(
911	"If the course's database layout (indicated in parentheses above) is "
912	. CGI::b("sql") . ", supply the SQL connections information requested below."
913	);
914
915	print CGI::start_table({class=>"FormLayout"});
916	print CGI::Tr(CGI::td({colspan=>2},
917	"Enter the user ID and password for an SQL account with sufficient permissions to create and delete databases."
918	)
919	);
920	print CGI::Tr(
921	CGI::th({class=>"LeftHeader"}, "SQL Admin Username:"),
922	CGI::td(CGI::textfield("rename_sql_username", $rename_sql_username, 25)),
923	);
924	print CGI::Tr(
925	CGI::th({class=>"LeftHeader"}, "SQL Admin Password:"),
926	CGI::td(CGI::password_field("rename_sql_password", $rename_sql_password, 25)),
927	);
928
929	print CGI::Tr(
930	CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
931	CGI::td(
932	CGI::textfield("rename_sql_host", $rename_sql_host, 25),
933	CGI::br(),
934	CGI::small("Leave blank to use the default host."),
935	),
936	);
937	print CGI::Tr(
938	CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
939	CGI::td(
940	CGI::textfield("rename_sql_port", $rename_sql_port, 25),
941	CGI::br(),
942	CGI::small("Leave blank to use the default port."),
943	),
944	);
945
946	print CGI::Tr(
947	CGI::th({class=>"LeftHeader"}, "SQL Current Database Name:"),
948	CGI::td(
949	CGI::textfield("rename_sql_database", $rename_sql_oldDatabase, 25),
950	CGI::br(),
951	CGI::small("Leave blank to use the name ", CGI::tt("webwork_COURSENAME"), "."),
952	),
953	);
954	print CGI::Tr(
955	CGI::th({class=>"LeftHeader"}, "SQL New Database Name:"),
956	CGI::td(
957	CGI::textfield("rename_sql_database", $rename_sql_newDatabase, 25),
958	CGI::br(),
959	CGI::small("Leave blank to use the name ", CGI::tt("webwork_COURSENAME"), "."),
960	),
961	);
962	print CGI::Tr(
963	CGI::th({class=>"LeftHeader"}, "WeBWorK Host:"),
964	CGI::td(
965	CGI::textfield("rename_sql_wwhost", $rename_sql_wwhost \|\| "localhost", 25),
966	CGI::br(),
967	CGI::small("If the SQL server does not run on the same host as WeBWorK, enter the host name of the WeBWorK server as seen by the SQL server."),
968	),
969	);
970	print CGI::end_table();	845	print CGI::end_table();
971		846
972	print CGI::p({style=>"text-align: center"}, CGI::submit("rename_course", "Rename Course"));	847	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"rename_course", -label=>"Rename Course"));
973		848
974	print CGI::end_form();	849	print CGI::end_form();
975	}	850	}
976		851
977	sub rename_course_validate {	852	sub rename_course_validate {
…		…
982	#my $authz = $r->authz;	857	#my $authz = $r->authz;
983	#my $urlpath = $r->urlpath;	858	#my $urlpath = $r->urlpath;
984		859
985	my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";	860	my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";
986	my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";	861	my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";
987
988	my $rename_sql_host = $r->param("rename_sql_host") \|\| "";
989	my $rename_sql_port = $r->param("rename_sql_port") \|\| "";
990	my $rename_sql_username = $r->param("rename_sql_username") \|\| "";
991	my $rename_sql_password = $r->param("rename_sql_password") \|\| "";
992	my $rename_sql_oldDatabase = $r->param("rename_sql_oldDatabase") \|\| "";
993	my $rename_sql_newDatabase = $r->param("rename_sql_newDatabase") \|\| "";
994	my $rename_sql_wwhost = $r->param("rename_sql_wwhost") \|\| "";
995		862
996	my @errors;	863	my @errors;
997		864
998	if ($rename_oldCourseID eq "") {	865	if ($rename_oldCourseID eq "") {
999	push @errors, "You must select a course to rename.";	866	push @errors, "You must select a course to rename.";
…		…
1016	$ce->{webworkURLs}->{root},	883	$ce->{webworkURLs}->{root},
1017	$ce->{pg}->{directories}->{root},	884	$ce->{pg}->{directories}->{root},
1018	$rename_oldCourseID,	885	$rename_oldCourseID,
1019	);	886	);
1020		887
1021	if ($ce2->{dbLayoutName} eq "sql") {
1022	push @errors, "You must specify the SQL admin username." if $rename_sql_username eq "";
1023	#push @errors, "You must specify the SQL admin password." if $rename_sql_password eq "";
1024	#push @errors, "You must specify the current SQL database name." if $rename_sql_oldDatabase eq "";
1025	#push @errors, "You must specify the new SQL database name." if $rename_sql_newDatabase eq "";
1026	}
1027
1028	return @errors;	888	return @errors;
1029	}	889	}
1030		890
1031	sub do_rename_course {	891	sub do_rename_course {
1032	my ($self) = @_;	892	my ($self) = @_;
…		…
1037	my $urlpath = $r->urlpath;	897	my $urlpath = $r->urlpath;
1038		898
1039	my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";	899	my $rename_oldCourseID = $r->param("rename_oldCourseID") \|\| "";
1040	my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";	900	my $rename_newCourseID = $r->param("rename_newCourseID") \|\| "";
1041		901
1042	my $rename_sql_host = $r->param("rename_sql_host") \|\| "";
1043	my $rename_sql_port = $r->param("rename_sql_port") \|\| "";
1044	my $rename_sql_username = $r->param("rename_sql_username") \|\| "";
1045	my $rename_sql_password = $r->param("rename_sql_password") \|\| "";
1046	my $rename_sql_oldDatabase = $r->param("rename_sql_oldDatabase") \|\| "";
1047	my $rename_sql_newDatabase = $r->param("rename_sql_newDatabase") \|\| "";
1048	my $rename_sql_wwhost = $r->param("rename_sql_wwhost") \|\| "";
1049
1050	my $ce2 = WeBWorK::CourseEnvironment->new(	902	my $ce2 = WeBWorK::CourseEnvironment->new(
1051	$ce->{webworkDirs}->{root},	903	$ce->{webworkDirs}->{root},
1052	$ce->{webworkURLs}->{root},	904	$ce->{webworkURLs}->{root},
1053	$ce->{pg}->{directories}->{root},	905	$ce->{pg}->{directories}->{root},
1054	$rename_oldCourseID,	906	$rename_oldCourseID,
1055	);	907	);
1056		908
1057	my $dbLayoutName = $ce->{dbLayoutName};	909	my $dbLayoutName = $ce->{dbLayoutName};
1058		910
		911	# 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
1059	my %dbOptions;	914	my %dbOptions;
1060	if ($dbLayoutName eq "sql") {
1061	$dbOptions{host} = $rename_sql_host if $rename_sql_host ne "";
1062	$dbOptions{port} = $rename_sql_port if $rename_sql_port ne "";
1063	$dbOptions{username} = $rename_sql_username;
1064	$dbOptions{password} = $rename_sql_password;
1065	$dbOptions{old_database} = $rename_sql_oldDatabase \|\| "webwork_$rename_oldCourseID";
1066	$dbOptions{new_database} = $rename_sql_newDatabase \|\| "webwork_$rename_newCourseID";
1067	$dbOptions{wwhost} = $rename_sql_wwhost;
1068	}
1069		915
1070	eval {	916	eval {
1071	renameCourse(	917	renameCourse(
1072	courseID => $rename_oldCourseID,	918	courseID => $rename_oldCourseID,
1073	ce => $ce2,	919	ce => $ce2,
…		…
1103	#my $db = $r->db;	949	#my $db = $r->db;
1104	#my $authz = $r->authz;	950	#my $authz = $r->authz;
1105	#my $urlpath = $r->urlpath;	951	#my $urlpath = $r->urlpath;
1106		952
1107	my $delete_courseID = $r->param("delete_courseID") \|\| "";	953	my $delete_courseID = $r->param("delete_courseID") \|\| "";
1108	my $delete_sql_host = $r->param("delete_sql_host") \|\| "";
1109	my $delete_sql_port = $r->param("delete_sql_port") \|\| "";
1110	my $delete_sql_username = $r->param("delete_sql_username") \|\| "";
1111	my $delete_sql_password = $r->param("delete_sql_password") \|\| "";
1112	my $delete_sql_database = $r->param("delete_sql_database") \|\| "";
1113		954
1114	my @courseIDs = listCourses($ce);	955	my @courseIDs = listCourses($ce);
1115	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive	956	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
1116		957
1117	my %courseLabels; # records... heh.	958	my %courseLabels; # records... heh.
…		…
1125	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";	966	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1126	}	967	}
1127		968
1128	print CGI::h2("Delete Course");	969	print CGI::h2("Delete Course");
1129		970
1130	print CGI::start_form("POST", $r->uri);	971	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1131	print $self->hidden_authen_fields;	972	print $self->hidden_authen_fields;
1132	print $self->hidden_fields("subDisplay");	973	print $self->hidden_fields("subDisplay");
1133		974
1134	print CGI::p("Select a course to delete.");	975	print CGI::p("Select a course to delete.");
1135		976
1136	print CGI::table({class=>"FormLayout"},	977	print CGI::table({class=>"FormLayout"},
1137	CGI::Tr(	978	CGI::Tr({},
1138	CGI::th({class=>"LeftHeader"}, "Course Name:"),	979	CGI::th({class=>"LeftHeader"}, "Course Name:"),
1139	CGI::td(	980	CGI::td(
1140	CGI::scrolling_list(	981	CGI::scrolling_list(
1141	-name => "delete_courseID",	982	-name => "delete_courseID",
1142	-values => \@courseIDs,	983	-values => \@courseIDs,
…		…
1147	),	988	),
1148	),	989	),
1149	),	990	),
1150	);	991	);
1151		992
1152	print CGI::p(
1153	"If the course's database layout (indicated in parentheses above) is "
1154	. CGI::b("sql") . ", supply the SQL connections information requested below."
1155	);
1156
1157	print CGI::start_table({class=>"FormLayout"});
1158	print CGI::Tr(CGI::td({colspan=>2},
1159	"Enter the user ID and password for an SQL account with sufficient permissions to delete an existing database."
1160	)
1161	);
1162	print CGI::Tr(
1163	CGI::th({class=>"LeftHeader"}, "SQL Admin Username:"),
1164	CGI::td(CGI::textfield("delete_sql_username", $delete_sql_username, 25)),
1165	);
1166	print CGI::Tr(
1167	CGI::th({class=>"LeftHeader"}, "SQL Admin Password:"),
1168	CGI::td(CGI::password_field("delete_sql_password", $delete_sql_password, 25)),
1169	);
1170
1171	#print CGI::Tr(CGI::td({colspan=>2},
1172	# "The optionial SQL settings you enter below must match the settings in the DBI source"
1173	# . " specification " . CGI::tt($dbi_source) . ". Replace " . CGI::tt("COURSENAME")
1174	# . " with the course name you entered above."
1175	# )
1176	#);
1177	print CGI::Tr(
1178	CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
1179	CGI::td(
1180	CGI::textfield("delete_sql_host", $delete_sql_host, 25),
1181	CGI::br(),
1182	CGI::small("Leave blank to use the default host."),
1183	),
1184	);
1185	print CGI::Tr(
1186	CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
1187	CGI::td(
1188	CGI::textfield("delete_sql_port", $delete_sql_port, 25),
1189	CGI::br(),
1190	CGI::small("Leave blank to use the default port."),
1191	),
1192	);
1193
1194	print CGI::Tr(
1195	CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
1196	CGI::td(
1197	CGI::textfield("delete_sql_database", $delete_sql_database, 25),
1198	CGI::br(),
1199	CGI::small("Leave blank to use the name ", CGI::tt("webwork_COURSENAME"), "."),
1200	),
1201	);
1202	print CGI::end_table();
1203
1204	print CGI::p({style=>"text-align: center"}, CGI::submit("delete_course", "Delete Course"));	993	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"delete_course", -value=>"Delete Course"));
1205		994
1206	print CGI::end_form();	995	print CGI::end_form();
1207	}	996	}
1208		997
1209	sub delete_course_validate {	998	sub delete_course_validate {
…		…
1213	#my $db = $r->db;	1002	#my $db = $r->db;
1214	#my $authz = $r->authz;	1003	#my $authz = $r->authz;
1215	my $urlpath = $r->urlpath;	1004	my $urlpath = $r->urlpath;
1216		1005
1217	my $delete_courseID = $r->param("delete_courseID") \|\| "";	1006	my $delete_courseID = $r->param("delete_courseID") \|\| "";
1218	my $delete_sql_host = $r->param("delete_sql_host") \|\| "";
1219	my $delete_sql_port = $r->param("delete_sql_port") \|\| "";
1220	my $delete_sql_username = $r->param("delete_sql_username") \|\| "";
1221	my $delete_sql_password = $r->param("delete_sql_password") \|\| "";
1222	my $delete_sql_database = $r->param("delete_sql_database") \|\| "";
1223		1007
1224	my @errors;	1008	my @errors;
1225		1009
1226	if ($delete_courseID eq "") {	1010	if ($delete_courseID eq "") {
1227	push @errors, "You must specify a course name.";	1011	push @errors, "You must specify a course name.";
…		…
1234	$ce->{webworkURLs}->{root},	1018	$ce->{webworkURLs}->{root},
1235	$ce->{pg}->{directories}->{root},	1019	$ce->{pg}->{directories}->{root},
1236	$delete_courseID,	1020	$delete_courseID,
1237	);	1021	);
1238		1022
1239	if ($ce2->{dbLayoutName} eq "sql") {
1240	push @errors, "You must specify the SQL admin username." if $delete_sql_username eq "";
1241	#push @errors, "You must specify the SQL admin password." if $delete_sql_password eq "";
1242	#push @errors, "You must specify the SQL database name." if $delete_sql_database eq "";
1243	}
1244
1245	return @errors;	1023	return @errors;
1246	}	1024	}
1247		1025
1248	sub delete_course_confirm {	1026	sub delete_course_confirm {
1249	my ($self) = @_;	1027	my ($self) = @_;
…		…
1254	#my $urlpath = $r->urlpath;	1032	#my $urlpath = $r->urlpath;
1255		1033
1256	print CGI::h2("Delete Course");	1034	print CGI::h2("Delete Course");
1257		1035
1258	my $delete_courseID = $r->param("delete_courseID") \|\| "";	1036	my $delete_courseID = $r->param("delete_courseID") \|\| "";
1259	my $delete_sql_host = $r->param("delete_sql_host") \|\| "";
1260	my $delete_sql_port = $r->param("delete_sql_port") \|\| "";
1261	my $delete_sql_database = $r->param("delete_sql_database") \|\| "";
1262		1037
1263	my $ce2 = WeBWorK::CourseEnvironment->new(	1038	my $ce2 = WeBWorK::CourseEnvironment->new(
1264	$ce->{webworkDirs}->{root},	1039	$ce->{webworkDirs}->{root},
1265	$ce->{webworkURLs}->{root},	1040	$ce->{webworkURLs}->{root},
1266	$ce->{pg}->{directories}->{root},	1041	$ce->{pg}->{directories}->{root},
1267	$delete_courseID,	1042	$delete_courseID,
1268	);	1043	);
1269		1044
1270	if ($ce2->{dbLayoutName} eq "sql") {
1271	print CGI::p("Are you sure you want to delete the course " . CGI::b($delete_courseID)	1045	print CGI::p("Are you sure you want to delete the course " . CGI::b($delete_courseID)
1272	. "? All course files and data and the following database will be destroyed."
1273	. " There is no undo available.");
1274
1275	print CGI::table({class=>"FormLayout"},
1276	CGI::Tr(
1277	CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
1278	CGI::td($delete_sql_host \|\| "system default"),
1279	),
1280	CGI::Tr(
1281	CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
1282	CGI::td($delete_sql_port \|\| "system default"),
1283	),
1284	CGI::Tr(
1285	CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
1286	CGI::td($delete_sql_database \|\| "webwork_$delete_courseID"),
1287	),
1288	);
1289	} else {
1290	print CGI::p("Are you sure you want to delete the course " . CGI::b($delete_courseID)
1291	. "? All course files and data will be destroyed. There is no undo available.");	1046	. "? All course files and data will be destroyed. There is no undo available.");
1292	}
1293		1047
1294	print CGI::start_form("POST", $r->uri);	1048	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1295	print $self->hidden_authen_fields;	1049	print $self->hidden_authen_fields;
1296	print $self->hidden_fields("subDisplay");	1050	print $self->hidden_fields("subDisplay");
1297	print $self->hidden_fields(qw/delete_courseID delete_sql_host delete_sql_port delete_sql_username delete_sql_password delete_sql_database/);	1051	print $self->hidden_fields(qw/delete_courseID/);
1298		1052
1299	print CGI::p({style=>"text-align: center"},	1053	print CGI::p({style=>"text-align: center"},
1300	CGI::submit("decline_delete_course", "Don't delete"),	1054	CGI::submit(-name=>"decline_delete_course", -label=>"Don't delete"),
1301	" ",	1055	" ",
1302	CGI::submit("confirm_delete_course", "Delete"),	1056	CGI::submit(-name=>"confirm_delete_course", -label=>"Delete"),
1303	);	1057	);
1304		1058
1305	print CGI::end_form();	1059	print CGI::end_form();
1306	}	1060	}
1307		1061
1308	sub do_delete_course {	1062	sub do_delete_course {
1309	my ($self) = @_;	1063	my ($self) = @_;
1310	my $r = $self->r;	1064	my $r = $self->r;
1311	my $ce = $r->ce;	1065	my $ce = $r->ce;
1312	#my $db = $r->db;	1066	my $db = $r->db;
1313	#my $authz = $r->authz;	1067	#my $authz = $r->authz;
1314	#my $urlpath = $r->urlpath;	1068	#my $urlpath = $r->urlpath;
1315		1069
1316	my $delete_courseID = $r->param("delete_courseID") \|\| "";	1070	my $delete_courseID = $r->param("delete_courseID") \|\| "";
1317	my $delete_sql_host = $r->param("delete_sql_host") \|\| "";
1318	my $delete_sql_port = $r->param("delete_sql_port") \|\| "";
1319	my $delete_sql_username = $r->param("delete_sql_username") \|\| "";
1320	my $delete_sql_password = $r->param("delete_sql_password") \|\| "";
1321	my $delete_sql_database = $r->param("delete_sql_database") \|\| "";
1322		1071
1323	my $ce2 = WeBWorK::CourseEnvironment->new(	1072	my $ce2 = WeBWorK::CourseEnvironment->new(
1324	$ce->{webworkDirs}->{root},	1073	$ce->{webworkDirs}->{root},
1325	$ce->{webworkURLs}->{root},	1074	$ce->{webworkURLs}->{root},
1326	$ce->{pg}->{directories}->{root},	1075	$ce->{pg}->{directories}->{root},
1327	$delete_courseID,	1076	$delete_courseID,
1328	);	1077	);
1329		1078
		1079	# 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
1330	my %dbOptions;	1082	my %dbOptions;
1331	if ($ce2->{dbLayoutName} eq "sql") {
1332	$dbOptions{host} = $delete_sql_host if $delete_sql_host ne "";
1333	$dbOptions{port} = $delete_sql_port if $delete_sql_port ne "";
1334	$dbOptions{username} = $delete_sql_username;
1335	$dbOptions{password} = $delete_sql_password;
1336	$dbOptions{database} = $delete_sql_database \|\| "webwork_$delete_courseID";
1337	}
1338		1083
1339	eval {	1084	eval {
1340	deleteCourse(	1085	deleteCourse(
1341	courseID => $delete_courseID,	1086	courseID => $delete_courseID,
1342	ce => $ce2,	1087	ce => $ce2,
…		…
1349	print CGI::div({class=>"ResultsWithError"},	1094	print CGI::div({class=>"ResultsWithError"},
1350	CGI::p("An error occured while deleting the course $delete_courseID:"),	1095	CGI::p("An error occured while deleting the course $delete_courseID:"),
1351	CGI::tt(CGI::escapeHTML($error)),	1096	CGI::tt(CGI::escapeHTML($error)),
1352	);	1097	);
1353	} else {	1098	} else {
		1099	# 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	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
1354	print CGI::div({class=>"ResultsWithoutError"},	1116	print CGI::div({class=>"ResultsWithoutError"},
1355	CGI::p("Successfully deleted the course $delete_courseID."),	1117	CGI::p("Successfully deleted the course $delete_courseID."),
1356	);	1118	);
1357	writeLog($ce, "hosted_courses", join("\t",	1119	writeLog($ce, "hosted_courses", join("\t",
1358	"\tDeleted",	1120	"\tDeleted",
1359	"",	1121	"",
1360	"",	1122	"",
1361	$delete_courseID,	1123	$delete_courseID,
1362	));	1124	));
1363	print CGI::start_form("POST", $r->uri);	1125	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1364	print $self->hidden_authen_fields;	1126	print $self->hidden_authen_fields;
1365	print $self->hidden_fields("subDisplay");	1127	print $self->hidden_fields("subDisplay");
1366		1128
1367	print CGI::p({style=>"text-align: center"}, CGI::submit("decline_delete_course", "OK"),);	1129	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"decline_delete_course", -value=>"OK"),);
1368		1130
1369	print CGI::end_form();	1131	print CGI::end_form();
1370	}	1132	}
1371	}	1133	}
1372		1134
…		…
1401	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";	1163	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1402	}	1164	}
1403		1165
1404	print CGI::h2("Export Database");	1166	print CGI::h2("Export Database");
1405		1167
		1168	print CGI::p(IMPORT_EXPORT_WARNING);
		1169
1406	print CGI::start_form("GET", $r->uri);	1170	print CGI::start_form(-method=>"GET", -action=>$r->uri);
1407	print $self->hidden_authen_fields;	1171	print $self->hidden_authen_fields;
1408	print $self->hidden_fields("subDisplay");	1172	print $self->hidden_fields("subDisplay");
1409		1173
1410	print CGI::p("Select a course to export the course's database. Please note	1174	print CGI::p({},"Select a course to export the course's database. Please note
1411	that exporting can take a very long time for a large course. If you have	1175	that exporting can take a very long time for a large course. If you have
1412	shell access to the WeBWorK server, you may use the ", CGI::code("wwdb"), "	1176	shell access to the WeBWorK server, you may use the ", CGI::code("wwdb"), "
1413	utility instead.");	1177	utility instead.");
1414		1178
1415	print CGI::table({class=>"FormLayout"},	1179	print CGI::table({class=>"FormLayout"},
1416	CGI::Tr(	1180	CGI::Tr({},
1417	CGI::th({class=>"LeftHeader"}, "Course Name:"),	1181	CGI::th({class=>"LeftHeader"}, "Course Name:"),
1418	CGI::td(	1182	CGI::td(
1419	CGI::scrolling_list(	1183	CGI::scrolling_list(
1420	-name => "export_courseID",	1184	-name => "export_courseID",
1421	-values => \@courseIDs,	1185	-values => \@courseIDs,
…		…
1424	-multiple => 1,	1188	-multiple => 1,
1425	-labels => \%courseLabels,	1189	-labels => \%courseLabels,
1426	),	1190	),
1427	),	1191	),
1428	),	1192	),
1429	CGI::Tr(	1193	CGI::Tr({},
1430	CGI::th({class=>"LeftHeader"}, "Tables to Export:"),	1194	CGI::th({class=>"LeftHeader"}, "Tables to Export:"),
1431	CGI::td(	1195	CGI::td({},
1432	CGI::checkbox_group(	1196	CGI::checkbox_group(
1433	-name => "export_tables",	1197	-name => "export_tables",
1434	-values => \@tables,	1198	-values => \@tables,
1435	-default => \@export_tables,	1199	-default => \@export_tables,
1436	-linebreak => 1,	1200	-linebreak => 1,
1437	),	1201	),
1438	),	1202	),
1439	),	1203	),
1440	);	1204	);
1441		1205
1442	print CGI::p({style=>"text-align: center"}, CGI::submit("export_database", "Export Database"));	1206	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"export_database", -value=>"Export Database"));
1443		1207
1444	print CGI::end_form();	1208	print CGI::end_form();
1445	}	1209	}
1446		1210
1447	sub export_database_validate {	1211	sub export_database_validate {
…		…
1586	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";	1350	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1587	}	1351	}
1588		1352
1589	# find databases:	1353	# find databases:
1590	my $templatesDir = $ce->{courseDirs}->{templates};	1354	my $templatesDir = $ce->{courseDirs}->{templates};
1591	my %probLibs = %{ $r->ce->{courseFiles}->{problibs} };	1355	my $exempt_dirs = join("\|", keys %{ $r->ce->{courseFiles}->{problibs} });
1592	my $exempt_dirs = join("\|", keys %probLibs);
1593		1356
1594	my @databaseFiles = listFilesRecursive(	1357	my @databaseFiles = listFilesRecursive(
1595	$templatesDir,	1358	$templatesDir,
1596	qr/.\.exported\.xml\.\d*\.gz$/, # match these files #FIXME this is too restricive!!	1359	qr/.\.exported\.xml\.\d*\.gz$/, # match these files #FIXME this is too restricive!!
1597	qr/^(?:$exempt_dirs\|CVS)$/, # prune these directories	1360	qr/^(?:$exempt_dirs\|CVS)$/, # prune these directories
…		…
1603		1366
1604	#######	1367	#######
1605		1368
1606	print CGI::h2("Import Database");	1369	print CGI::h2("Import Database");
1607		1370
		1371	print CGI::p(IMPORT_EXPORT_WARNING);
		1372
1608	print CGI::start_form("POST", $r->uri, &CGI::MULTIPART);	1373	print CGI::start_form(-method=>"POST", -action=>$r->uri, -enctype=>&CGI::MULTIPART);
1609	print $self->hidden_authen_fields;	1374	print $self->hidden_authen_fields;
1610	print $self->hidden_fields("subDisplay");	1375	print $self->hidden_fields("subDisplay");
1611		1376
1612	print CGI::table({class=>"FormLayout"},	1377	print CGI::table({class=>"FormLayout"},
1613	CGI::Tr(	1378	CGI::Tr({},
1614	CGI::th({class=>"LeftHeader"}, "Database XML File:"),	1379	CGI::th({class=>"LeftHeader"}, "Database XML File:"),
1615	# CGI::td(
1616	# CGI::filefield(
1617	# -name => "import_file",
1618	# -size => 50,
1619	# ),
1620	# ),
1621	CGI::td(	1380	CGI::td(
1622	CGI::scrolling_list(	1381	CGI::scrolling_list(
1623	-name => "import_file",	1382	-name => "import_file",
1624	-values => \@databaseFiles,	1383	-values => \@databaseFiles,
1625	-default => undef,	1384	-default => undef,
…		…
1628	-labels => \%databaseLabels,	1387	-labels => \%databaseLabels,
1629	),	1388	),
1630		1389
1631	)	1390	)
1632	),	1391	),
1633	CGI::Tr(	1392	CGI::Tr({},
1634	CGI::th({class=>"LeftHeader"}, "Tables to Import:"),	1393	CGI::th({class=>"LeftHeader"}, "Tables to Import:"),
1635	CGI::td(	1394	CGI::td(
1636	CGI::checkbox_group(	1395	CGI::checkbox_group(
1637	-name => "import_tables",	1396	-name => "import_tables",
1638	-values => \@tables,	1397	-values => \@tables,
1639	-default => \@import_tables,	1398	-default => \@import_tables,
1640	-linebreak => 1,	1399	-linebreak => 1,
1641	),	1400	),
1642	),	1401	),
1643	),	1402	),
1644	CGI::Tr(	1403	CGI::Tr({},
1645	CGI::th({class=>"LeftHeader"}, "Import into Course:"),	1404	CGI::th({class=>"LeftHeader"}, "Import into Course:"),
1646	CGI::td(	1405	CGI::td(
1647	CGI::scrolling_list(	1406	CGI::scrolling_list(
1648	-name => "import_courseID",	1407	-name => "import_courseID",
1649	-values => \@courseIDs,	1408	-values => \@courseIDs,
…		…
1652	-multiple => 0,	1411	-multiple => 0,
1653	-labels => \%courseLabels,	1412	-labels => \%courseLabels,
1654	),	1413	),
1655	),	1414	),
1656	),	1415	),
1657	CGI::Tr(	1416	CGI::Tr({},
1658	CGI::th({class=>"LeftHeader"}, "Conflicts:"),	1417	CGI::th({class=>"LeftHeader"}, "Conflicts:"),
1659	CGI::td(	1418	CGI::td(
1660	CGI::radio_group(	1419	CGI::radio_group(
1661	-name => "import_conflict",	1420	-name => "import_conflict",
1662	-values => [qw/skip replace/],	1421	-values => [qw/skip replace/],
…		…
1669	),	1428	),
1670	),	1429	),
1671	),	1430	),
1672	);	1431	);
1673		1432
1674	print CGI::p({style=>"text-align: center"}, CGI::submit("import_database", "Import Database"));	1433	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"import_database", -value=>"Import Database"));
1675		1434
1676	print CGI::end_form();	1435	print CGI::end_form();
1677	}	1436	}
1678		1437
1679	sub import_database_validate {	1438	sub import_database_validate {
…		…
1778	#my $db = $r->db;	1537	#my $db = $r->db;
1779	#my $authz = $r->authz;	1538	#my $authz = $r->authz;
1780	#my $urlpath = $r->urlpath;	1539	#my $urlpath = $r->urlpath;
1781		1540
1782	my $archive_courseID = $r->param("archive_courseID") \|\| "";	1541	my $archive_courseID = $r->param("archive_courseID") \|\| "";
1783	my $archive_sql_host = $r->param("archive_sql_host") \|\| "";
1784	my $archive_sql_port = $r->param("archive_sql_port") \|\| "";
1785	my $archive_sql_username = $r->param("archive_sql_username") \|\| "";
1786	my $archive_sql_password = $r->param("archive_sql_password") \|\| "";
1787	my $archive_sql_database = $r->param("archive_sql_database") \|\| "";
1788		1542
1789	my @courseIDs = listCourses($ce);	1543	my @courseIDs = listCourses($ce);
1790	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive	1544	@courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive
1791		1545
1792	my %courseLabels; # records... heh.	1546	my %courseLabels; # records... heh.
…		…
1800	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";	1554	$courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")";
1801	}	1555	}
1802		1556
1803	print CGI::h2("archive Course");	1557	print CGI::h2("archive Course");
1804		1558
1805	print CGI::start_form("POST", $r->uri);	1559	print CGI::start_form(-method=>"POST", -action=>$r->uri);
1806	print $self->hidden_authen_fields;	1560	print $self->hidden_authen_fields;
1807	print $self->hidden_fields("subDisplay");	1561	print $self->hidden_fields("subDisplay");
1808		1562
1809	print CGI::p("Select a course to archive.");	1563	print CGI::p("Select a course to archive.");
1810		1564
1811	print CGI::table({class=>"FormLayout"},	1565	print CGI::table({class=>"FormLayout"},
1812	CGI::Tr(	1566	CGI::Tr({},
1813	CGI::th({class=>"LeftHeader"}, "Course Name:"),	1567	CGI::th({class=>"LeftHeader"}, "Course Name:"),
1814	CGI::td(	1568	CGI::td(
1815	CGI::scrolling_list(	1569	CGI::scrolling_list(
1816	-name => "archive_courseID",	1570	-name => "archive_courseID",
1817	-values => \@courseIDs,	1571	-values => \@courseIDs,
…		…
1819	-size => 10,	1573	-size => 10,
1820	-multiple => 0,	1574	-multiple => 0,
1821	-labels => \%courseLabels,	1575	-labels => \%courseLabels,
1822	),	1576	),
1823	),	1577	),
		1578
1824	),	1579	),
		1580	CGI::Tr({},
		1581	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	)
1825	);	1591	);
1826		1592
1827	print CGI::p(	1593	print CGI::p(
1828	"Currently the archive facility is only available for mysql databases.	1594	"Currently the archive facility is only available for mysql databases.
1829	It depends on the mysqldump application."	1595	It depends on the mysqldump application."
1830	);	1596	);
1831	# print CGI::p(	1597
1832	# "If the course's database layout (indicated in parentheses above) is "
1833	# . CGI::b("sql") . ", supply the SQL connections information requested below."
1834	# );
1835		1598
1836	# print CGI::start_table({class=>"FormLayout"});
1837	# print CGI::Tr(CGI::td({colspan=>2},
1838	# "Enter the user ID and password for an SQL account with sufficient permissions to archive an existing database."
1839	# )
1840	# );
1841	# print CGI::Tr(
1842	# CGI::th({class=>"LeftHeader"}, "SQL Admin Username:"),
1843	# CGI::td(CGI::textfield("archive_sql_username", $archive_sql_username, 25)),
1844	# );
1845	# print CGI::Tr(
1846	# CGI::th({class=>"LeftHeader"}, "SQL Admin Password:"),
1847	# CGI::td(CGI::password_field("archive_sql_password", $archive_sql_password, 25)),
1848	# );
1849	#
1850	# #print CGI::Tr(CGI::td({colspan=>2},
1851	# # "The optionial SQL settings you enter below must match the settings in the DBI source"
1852	# # . " specification " . CGI::tt($dbi_source) . ". Replace " . CGI::tt("COURSENAME")
1853	# # . " with the course name you entered above."
1854	# # )
1855	# #);
1856	# print CGI::Tr(
1857	# CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
1858	# CGI::td(
1859	# CGI::textfield("archive_sql_host", $archive_sql_host, 25),
1860	# CGI::br(),
1861	# CGI::small("Leave blank to use the default host."),
1862	# ),
1863	# );
1864	# print CGI::Tr(
1865	# CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
1866	# CGI::td(
1867	# CGI::textfield("archive_sql_port", $archive_sql_port, 25),
1868	# CGI::br(),
1869	# CGI::small("Leave blank to use the default port."),
1870	# ),
1871	# );
1872	#
1873	# print CGI::Tr(
1874	# CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
1875	# CGI::td(
1876	# CGI::textfield("archive_sql_database", $archive_sql_database, 25),
1877	# CGI::br(),
1878	# CGI::small("Leave blank to use the name ", CGI::tt("webwork_COURSENAME"), "."),
1879	# ),
1880	# );
1881	# print CGI::end_table();
1882
1883	print CGI::p({style=>"text-align: center"}, CGI::submit("archive_course", "archive Course"));	1599	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"archive_course", -value=>"archive Course"));
1884		1600
1885	print CGI::end_form();	1601	print CGI::end_form();
1886	}	1602	}
1887		1603
1888	sub archive_course_validate {	1604	sub archive_course_validate {
…		…
1892	#my $db = $r->db;	1608	#my $db = $r->db;
1893	#my $authz = $r->authz;	1609	#my $authz = $r->authz;
1894	my $urlpath = $r->urlpath;	1610	my $urlpath = $r->urlpath;
1895		1611
1896	my $archive_courseID = $r->param("archive_courseID") \|\| "";	1612	my $archive_courseID = $r->param("archive_courseID") \|\| "";
1897	my $archive_sql_host = $r->param("archive_sql_host") \|\| "";
1898	my $archive_sql_port = $r->param("archive_sql_port") \|\| "";
1899	my $archive_sql_username = $r->param("archive_sql_username") \|\| "";
1900	my $archive_sql_password = $r->param("archive_sql_password") \|\| "";
1901	my $archive_sql_database = $r->param("archive_sql_database") \|\| "";
1902		1613
1903	my @errors;	1614	my @errors;
1904		1615
1905	if ($archive_courseID eq "") {	1616	if ($archive_courseID eq "") {
1906	push @errors, "You must specify a course name.";	1617	push @errors, "You must specify a course name.";
1907	} elsif ($archive_courseID eq $urlpath->arg("courseID")) {	1618	} elsif ($archive_courseID eq $urlpath->arg("courseID")) {
1908	push @errors, "You cannot archive the course you are currently using.";	1619	push @errors, "You cannot archive the course you are currently using.";
1909	}	1620	}
		1621
		1622	#my $ce2 = WeBWorK::CourseEnvironment->new(
		1623	# $ce->{webworkDirs}->{root},
		1624	# $ce->{webworkURLs}->{root},
		1625	# $ce->{pg}->{directories}->{root},
		1626	# $archive_courseID,
		1627	#);
		1628
		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	my $delete_course_flag = $r->param("delete_course") \|\| "";
1910		1644
1911	my $ce2 = WeBWorK::CourseEnvironment->new(	1645	my $ce2 = WeBWorK::CourseEnvironment->new(
1912	$ce->{webworkDirs}->{root},	1646	$ce->{webworkDirs}->{root},
1913	$ce->{webworkURLs}->{root},	1647	$ce->{webworkURLs}->{root},
1914	$ce->{pg}->{directories}->{root},	1648	$ce->{pg}->{directories}->{root},
1915	$archive_courseID,	1649	$archive_courseID,
1916	);	1650	);
1917		1651
1918	if ($ce2->{dbLayoutName} eq "sql") {	1652	if ($ce2->{dbLayoutName} ) {
1919	push @errors, "You must specify the SQL admin username." if $archive_sql_username eq "";	1653	print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID)
1920	#push @errors, "You must specify the SQL admin password." if $archive_sql_password eq "";	1654	. "? ");
1921	#push @errors, "You must specify the SQL database name." if $archive_sql_database eq "";	1655	print(CGI::p({-style=>'color:red; font-weight:bold'}, "Are you sure that you want to delete the course ".
1922	}	1656	CGI::b($archive_courseID). " after archiving? This cannot be undone!")) if $delete_course_flag;
		1657
1923		1658
1924	return @errors;	1659	}
		1660
		1661	print CGI::start_form(-method=>"POST", -action=>$r->uri);
		1662	print $self->hidden_authen_fields;
		1663	print $self->hidden_fields("subDisplay");
		1664	print $self->hidden_fields(qw/archive_courseID delete_course/);
		1665
		1666	print CGI::p({style=>"text-align: center"},
		1667	CGI::submit(-name=>"decline_archive_course", -value=>"Don't archive"),
		1668	" ",
		1669	CGI::submit(-name=>"confirm_archive_course", -value=>"archive"),
		1670	);
		1671
		1672	print CGI::end_form();
1925	}	1673	}
1926		1674
1927	sub archive_course_confirm {	1675	sub do_archive_course {
1928	my ($self) = @_;	1676	my ($self) = @_;
1929	my $r = $self->r;	1677	my $r = $self->r;
1930	my $ce = $r->ce;	1678	my $ce = $r->ce;
1931	#my $db = $r->db;	1679	my $db = $r->db;
1932	#my $authz = $r->authz;	1680	#my $authz = $r->authz;
1933	#my $urlpath = $r->urlpath;	1681	#my $urlpath = $r->urlpath;
1934		1682
1935	print CGI::h2("archive Course");
1936
1937	my $archive_courseID = $r->param("archive_courseID") \|\| "";	1683	my $archive_courseID = $r->param("archive_courseID") \|\| "";
1938	my $archive_sql_host = $r->param("archive_sql_host") \|\| "";	1684	my $delete_course_flag = $r->param("delete_course") \|\| "";
1939	my $archive_sql_port = $r->param("archive_sql_port") \|\| "";
1940	my $archive_sql_database = $r->param("archive_sql_database") \|\| "";
1941		1685
1942	my $ce2 = WeBWorK::CourseEnvironment->new(	1686	my $ce2 = WeBWorK::CourseEnvironment->new(
1943	$ce->{webworkDirs}->{root},	1687	$ce->{webworkDirs}->{root},
1944	$ce->{webworkURLs}->{root},	1688	$ce->{webworkURLs}->{root},
1945	$ce->{pg}->{directories}->{root},	1689	$ce->{pg}->{directories}->{root},
1946	$archive_courseID,	1690	$archive_courseID,
1947	);	1691	);
1948		1692
1949	if ($ce2->{dbLayoutName} eq "sql") {	1693	# this is kinda left over from when we had 'gdbm' and 'sql' database layouts
1950	print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID)	1694	# below this line, we would grab values from getopt and put them in this hash
1951	. "? ");	1695	# but for now the hash can remain empty
1952
1953	print CGI::table({class=>"FormLayout"},
1954	CGI::Tr(
1955	CGI::th({class=>"LeftHeader"}, "SQL Server Host:"),
1956	CGI::td($archive_sql_host \|\| "system default"),
1957	),
1958	CGI::Tr(
1959	CGI::th({class=>"LeftHeader"}, "SQL Server Port:"),
1960	CGI::td($archive_sql_port \|\| "system default"),
1961	),
1962	CGI::Tr(
1963	CGI::th({class=>"LeftHeader"}, "SQL Database Name:"),
1964	CGI::td($archive_sql_database \|\| "webwork_$archive_courseID"),
1965	),
1966	);
1967	} else {
1968	print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID)
1969	. "? All course files and data will be destroyed. There is no undo available.");
1970	}
1971
1972	print CGI::start_form("POST", $r->uri);
1973	print $self->hidden_authen_fields;
1974	print $self->hidden_fields("subDisplay");
1975	print $self->hidden_fields(qw/archive_courseID archive_sql_host archive_sql_port archive_sql_username archive_sql_password archive_sql_database/);
1976
1977	print CGI::p({style=>"text-align: center"},
1978	CGI::submit("decline_archive_course", "Don't archive"),
1979	" ",
1980	CGI::submit("confirm_archive_course", "archive"),
1981	);
1982
1983	print CGI::end_form();
1984	}
1985
1986	sub do_archive_course {
1987	my ($self) = @_;
1988	my $r = $self->r;
1989	my $ce = $r->ce;
1990	#my $db = $r->db;
1991	#my $authz = $r->authz;
1992	#my $urlpath = $r->urlpath;
1993
1994	my $archive_courseID = $r->param("archive_courseID") \|\| "";
1995	my $archive_sql_host = $r->param("archive_sql_host") \|\| "";
1996	my $archive_sql_port = $r->param("archive_sql_port") \|\| "";
1997	my $archive_sql_username = $r->param("archive_sql_username") \|\| "";
1998	my $archive_sql_password = $r->param("archive_sql_password") \|\| "";
1999	my $archive_sql_database = $r->param("archive_sql_database") \|\| "";
2000
2001	my $ce2 = WeBWorK::CourseEnvironment->new(
2002	$ce->{webworkDirs}->{root},
2003	$ce->{webworkURLs}->{root},
2004	$ce->{pg}->{directories}->{root},
2005	$archive_courseID,
2006	);
2007
2008	my %dbOptions;	1696	my %dbOptions;
2009	if ($ce2->{dbLayoutName} eq "sql") {
2010	$dbOptions{host} = $archive_sql_host if $archive_sql_host ne "";
2011	$dbOptions{port} = $archive_sql_port if $archive_sql_port ne "";
2012	$dbOptions{username} = $archive_sql_username;
2013	$dbOptions{password} = $archive_sql_password;
2014	$dbOptions{database} = $archive_sql_database \|\| "webwork_$archive_courseID";
2015	}
2016		1697
2017	eval {	1698	eval {
2018	archiveCourse(	1699	archiveCourse(
2019	courseID => $archive_courseID,	1700	courseID => $archive_courseID,
2020	ce => $ce2,	1701	ce => $ce2,
…		…
2036	"\tarchived",	1717	"\tarchived",
2037	"",	1718	"",
2038	"",	1719	"",
2039	$archive_courseID,	1720	$archive_courseID,
2040	));	1721	));
		1722
		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	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
		1756	print CGI::div({class=>"ResultsWithoutError"},
		1757	CGI::p("Successfully deleted the course $archive_courseID."),
		1758	);
		1759	}
		1760
		1761
		1762	}
		1763
		1764	# print CGI::start_form(-method=>"POST", -action=>$r->uri);
		1765	# 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	}
		1772	}
		1773	##########################################################################
		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
2041	print CGI::start_form("POST", $r->uri);	1795	print CGI::start_form(-method=>"POST", -action=>$r->uri);
		1796	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	CGI::Tr({},
		1803	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
		1822
		1823	print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"unarchive_course", -value=>"Unarchive Course"));
		1824
		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	print CGI::start_form(-method=>"POST", -action=>$r->uri);
		1872	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	print $self->hidden_fields(qw/unarchive_courseID/);
		1879
		1880	print CGI::p({style=>"text-align: center"},
		1881	CGI::submit(-name=>"decline_unarchive_course", -value=>"Don't unarchive"),
		1882	" ",
		1883	CGI::submit(-name=>"confirm_unarchive_course", -value=>"unarchive"),
		1884	);
		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	################################################################################
		1937	## 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	-values=>["",
		2028	"selected_locations",
		2029	@locationIDs],
		2030	-labels=>{selected_locations => "locations selected below",
		2031	"" => "no location"}) .
		2032	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	CGI::th({}, ["Select", "Location", "Description",
		2047	"Addresses"]));
		2048	foreach my $loc ( @locations ) {
		2049	my $editAddr = $self->systemLink($urlpath, params=>{subDisplay=>"manage_locations", manage_location_action=>"edit_location_form", edit_location=>$loc->location_id});
		2050	print CGI::Tr({valign=>'top',style=>"background-color:#eeeeee;"},
		2051	CGI::td({style=>'font-size:85%;'},
		2052	[ CGI::checkbox(-name=>"delete_selected",
		2053	-value=>$loc->location_id,
		2054	-label=>''),
		2055	CGI::a({href=>$editAddr}, $loc->location_id),
		2056	$loc->description,
		2057	join(', ', @{$locAddr{$loc->location_id}}) ]));
		2058	}
		2059	print CGI::end_table(), CGI::end_div();
		2060	print CGI::end_form();
		2061
		2062
		2063	}
		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	# 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	# are we sure?
		2171	my $confirm = $r->param("delete_confirm");
		2172
		2173	my $badID;
		2174	if ( ! $locationID ) {
		2175	print CGI::div({-class=>"ResultsWithError"},
		2176	"Please provide a location name " .
		2177	"to delete.");
		2178
		2179	} elsif ( $badID = $self->existsLocations_helper( @delLocations ) ) {
		2180	print CGI::div({-class=>"ResultsWithError"},
		2181	"No location with name $badID " .
		2182	"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	foreach ( @delLocations ) {
		2189	$db->deleteLocation( $_ );
		2190	}
		2191	print CGI::div({-class=>"ResultsWithoutError"},
		2192	"Location" . (@delLocations > 1 ? 's ' : ' ') .
		2193	join(', ', @delLocations) .
		2194	(@delLocations > 1 ? ' have ' : ' has ' ) .
		2195	'been deleted.');
		2196	$r->param('manage_location_action','none');
		2197	$r->param('delete_location','');
		2198	}
		2199	$self->manage_location_form;
		2200	}
		2201	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
		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);
2042	print $self->hidden_authen_fields;	2239	print $self->hidden_authen_fields;
2043	print $self->hidden_fields("subDisplay");	2240	print $self->hidden_fields("subDisplay");
2044		2241	print CGI::hidden(-name=>'edit_location',
2045	print CGI::p({style=>"text-align: center"}, CGI::submit("decline_archive_course", "OK"),);	2242	-default=>$locationID);
2046		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
2047	print CGI::end_form();	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;
2048	}	2417	}
2049	}	2418	}
2050		2419
2051	################################################################################	2420	################################################################################
2052	1;	2421	1;

 Legend:



Removed from v.3621
 


changed lines


 
Added in v.4918
 Legend:



Removed from v.3621
 


changed lines


 
Added in v.4918
-Removed from v.3621
+Added in v.4918

aubreyja at gmail dot com	ViewVC Help
Powered by ViewVC 1.0.9