Parent Directory
| 
Revision Log
backport (sh002i): use $ce->{externalPrograms}{gzip} rather than 'gzip'.
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader$ 5 # 6 # This program is free software; you can redistribute it and/or modify it under 7 # the terms of either: (a) the GNU General Public License as published by the 8 # Free Software Foundation; either version 2, or (at your option) any later 9 # version, or (b) the "Artistic License" which comes with this package. 10 # 11 # This program is distributed in the hope that it will be useful, but WITHOUT 12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 13 # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 14 # Artistic License for more details. 15 ################################################################################ 16 17 package WeBWorK::ContentGenerator::CourseAdmin; 18 use base qw(WeBWorK::ContentGenerator); 19 20 =head1 NAME 21 22 WeBWorK::ContentGenerator::CourseAdmin - Add, rename, and delete courses. 23 24 =cut 25 26 use strict; 27 use warnings; 28 #use CGI qw(-nosticky ); 29 use WeBWorK::CGI; 30 use Data::Dumper; 31 use File::Temp qw/tempfile/; 32 use WeBWorK::CourseEnvironment; 33 use IO::File; 34 use WeBWorK::Debug; 35 use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive); 36 use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse 37 listArchivedCourses unarchiveCourse); 38 use WeBWorK::Utils::DBImportExport qw(dbExport dbImport); 39 # needed for location management 40 use Net::IP; 41 42 use constant IMPORT_EXPORT_WARNING => "The ability to import and export 43 databases is still under development. It seems to work but it is <b>VERY</b> 44 slow on large courses. You may prefer to use webwork2/bin/wwdb or the mysql 45 dump facility for archiving large courses. Please send bug reports if you find 46 errors."; 47 48 sub pre_header_initialize { 49 my ($self) = @_; 50 my $r = $self->r; 51 my $ce = $r->ce; 52 my $db = $r->db; 53 my $authz = $r->authz; 54 my $urlpath = $r->urlpath; 55 my $user = $r->param('user'); 56 57 # check permissions 58 unless ($authz->hasPermissions($user, "create_and_delete_courses")) { 59 $self->addmessage( CGI::div({class=>'ResultsWithError'},"$user is not authorized to create or delete courses") ); 60 return; 61 } 62 63 # get result and send to message 64 my $status_message = $r->param("status_message"); 65 $self->addmessage(CGI::p("$status_message")) if $status_message; 66 67 ## if the user is asking for the downloaded database... 68 #if (defined $r->param("download_exported_database")) { 69 # my $courseID = $r->param("export_courseID"); 70 # my $random_chars = $r->param("download_exported_database"); 71 # 72 # die "courseID not specified" unless defined $courseID; 73 # die "invalid file specification" unless $random_chars =~ m/^\w+$/; 74 # 75 # my $tempdir = $ce->{webworkDirs}->{tmp}; 76 # my $export_file = "$tempdir/db_export_$random_chars"; 77 # 78 # $self->reply_with_file("application/xml", $export_file, "${courseID}_database.xml", 0); 79 # 80 # return ""; 81 #} 82 # 83 ## otherwise... 84 85 my @errors; 86 my $method_to_call; 87 88 my $subDisplay = $r->param("subDisplay"); 89 if (defined $subDisplay) { 90 91 if ($subDisplay eq "add_course") { 92 if (defined $r->param("add_course")) { 93 @errors = $self->add_course_validate; 94 if (@errors) { 95 $method_to_call = "add_course_form"; 96 } else { 97 $method_to_call = "do_add_course"; 98 } 99 } else { 100 $method_to_call = "add_course_form"; 101 } 102 } 103 104 elsif ($subDisplay eq "rename_course") { 105 if (defined $r->param("rename_course")) { 106 @errors = $self->rename_course_validate; 107 if (@errors) { 108 $method_to_call = "rename_course_form"; 109 } else { 110 $method_to_call = "do_rename_course"; 111 } 112 } else { 113 $method_to_call = "rename_course_form"; 114 } 115 } 116 117 elsif ($subDisplay eq "delete_course") { 118 if (defined $r->param("delete_course")) { 119 # validate or confirm 120 @errors = $self->delete_course_validate; 121 if (@errors) { 122 $method_to_call = "delete_course_form"; 123 } else { 124 $method_to_call = "delete_course_confirm"; 125 } 126 } elsif (defined $r->param("confirm_delete_course")) { 127 # validate and delete 128 @errors = $self->delete_course_validate; 129 if (@errors) { 130 $method_to_call = "delete_course_form"; 131 } else { 132 $method_to_call = "do_delete_course"; 133 } 134 } else { 135 # form only 136 $method_to_call = "delete_course_form"; 137 } 138 } 139 140 elsif ($subDisplay eq "export_database") { 141 if (defined $r->param("export_database")) { 142 @errors = $self->export_database_validate; 143 if (@errors) { 144 $method_to_call = "export_database_form"; 145 } else { 146 # we have to do something special here, since we're sending 147 # the database as we export it. $method_to_call still gets 148 # set here, but it gets caught by header() and content() 149 # below instead of by body(). 150 $method_to_call = "do_export_database"; 151 } 152 } else { 153 $method_to_call = "export_database_form"; 154 } 155 } 156 157 elsif ($subDisplay eq "import_database") { 158 if (defined $r->param("import_database")) { 159 @errors = $self->import_database_validate; 160 if (@errors) { 161 $method_to_call = "import_database_form"; 162 } else { 163 $method_to_call = "do_import_database"; 164 } 165 } else { 166 $method_to_call = "import_database_form"; 167 } 168 } 169 170 elsif ($subDisplay eq "archive_course") { 171 if (defined $r->param("archive_course")) { 172 # validate or confirm 173 @errors = $self->archive_course_validate; 174 if (@errors) { 175 $method_to_call = "archive_course_form"; 176 } else { 177 $method_to_call = "archive_course_confirm"; 178 } 179 } elsif (defined $r->param("confirm_archive_course")) { 180 # validate and archive 181 @errors = $self->archive_course_validate; 182 if (@errors) { 183 $method_to_call = "archive_course_form"; 184 } else { 185 $method_to_call = "do_archive_course"; 186 } 187 } else { 188 # form only 189 $method_to_call = "archive_course_form"; 190 } 191 } 192 elsif ($subDisplay eq "unarchive_course") { 193 if (defined $r->param("unarchive_course")) { 194 # validate or confirm 195 @errors = $self->unarchive_course_validate; 196 if (@errors) { 197 $method_to_call = "unarchive_course_form"; 198 } else { 199 $method_to_call = "unarchive_course_confirm"; 200 } 201 } elsif (defined $r->param("confirm_unarchive_course")) { 202 # validate and archive 203 @errors = $self->unarchive_course_validate; 204 if (@errors) { 205 $method_to_call = "unarchive_course_form"; 206 } else { 207 $method_to_call = "do_unarchive_course"; 208 } 209 } else { 210 # form only 211 $method_to_call = "unarchive_course_form"; 212 } 213 } 214 elsif ($subDisplay eq "manage_locations") { 215 if (defined ($r->param("manage_location_action"))) { 216 $method_to_call = 217 $r->param("manage_location_action"); 218 } 219 else{ 220 $method_to_call = "manage_location_form"; 221 } 222 } 223 else { 224 @errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}."; 225 } 226 } 227 228 $self->{errors} = \@errors; 229 $self->{method_to_call} = $method_to_call; 230 } 231 232 sub header { 233 my ($self) = @_; 234 my $method_to_call = $self->{method_to_call}; 235 # if (defined $method_to_call and $method_to_call eq "do_export_database") { 236 # my $r = $self->r; 237 # my $courseID = $r->param("export_courseID"); 238 # $r->content_type("application/octet-stream"); 239 # $r->header_out("Content-Disposition" => "attachment; filename=\"${courseID}_database.xml\""); 240 # $r->send_http_header; 241 # } else { 242 $self->SUPER::header; 243 # } 244 } 245 246 # sends: 247 # 248 # HTTP/1.1 200 OK 249 # Date: Fri, 09 Jul 2004 19:05:55 GMT 250 # Server: Apache/1.3.27 (Unix) mod_perl/1.27 251 # Content-Disposition: attachment; filename="mth143_database.xml" 252 # Connection: close 253 # Content-Type: application/octet-stream 254 255 sub content { 256 my ($self) = @_; 257 my $method_to_call = $self->{method_to_call}; 258 if (defined $method_to_call and $method_to_call eq "do_export_database") { 259 #$self->do_export_database; 260 $self->SUPER::content; 261 } else { 262 $self->SUPER::content; 263 } 264 } 265 266 sub body { 267 my ($self) = @_; 268 my $r = $self->r; 269 my $ce = $r->ce; 270 my $db = $r->db; 271 my $authz = $r->authz; 272 my $urlpath = $r->urlpath; 273 274 my $user = $r->param('user'); 275 276 # check permissions 277 unless ($authz->hasPermissions($user, "create_and_delete_courses")) { 278 return ""; 279 } 280 my $method_to_call = $self->{method_to_call}; 281 my $methodMessage =""; 282 283 (defined($method_to_call) and $method_to_call eq "do_export_database") && do { 284 my @export_courseID = $r->param("export_courseID"); 285 my $course_ids = join(", ", @export_courseID); 286 $methodMessage = CGI::p("Exporting database for course(s) $course_ids"). 287 CGI::p(".... please wait.... 288 If your browser times out you will 289 still be able to download the exported database using the 290 file manager.").CGI::hr(); 291 }; 292 293 294 print CGI::p({style=>"text-align: center"}, 295 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"add_course",add_admin_users=>1, 296 add_dbLayout=>'sql_single', 297 add_templates_course => $ce->{siteDefaults}->{default_templates_course} ||""} 298 )}, 299 "Add Course" 300 ), 301 " | ", 302 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"rename_course"})}, "Rename Course"), 303 " | ", 304 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"delete_course"})}, "Delete Course"), 305 " | ", 306 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"export_database"})}, "Export Database"), 307 " | ", 308 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"), 309 " | ", 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"), 315 CGI::hr(), 316 $methodMessage, 317 318 ); 319 320 my @errors = @{$self->{errors}}; 321 322 323 if (@errors) { 324 print CGI::div({class=>"ResultsWithError"}, 325 CGI::p("Please correct the following errors and try again:"), 326 CGI::ul(CGI::li(\@errors)), 327 ); 328 } 329 330 if (defined $method_to_call and $method_to_call ne "") { 331 $self->$method_to_call; 332 } else { 333 334 print CGI::h2("Courses"); 335 336 print CGI::start_ol(); 337 338 my @courseIDs = listCourses($ce); 339 foreach my $courseID (sort {lc($a) cmp lc($b) } @courseIDs) { 340 next if $courseID eq "admin"; # done already above 341 my $urlpath = $r->urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets", courseID => $courseID); 342 my $tempCE = WeBWorK::CourseEnvironment->new( 343 $ce->{webworkDirs}->{root}, 344 $ce->{webworkURLs}->{root}, 345 $ce->{pg}->{directories}->{root}, 346 $courseID, 347 ); 348 print CGI::li(CGI::a({href=>$self->systemLink($urlpath, authen => 0)}, $courseID), 349 CGI::code( 350 $tempCE->{dbLayoutName}, 351 ), 352 (-r $tempCE->{courseFiles}->{environment}) ? "" : CGI::i(", missing course.conf"), 353 354 ); 355 356 } 357 358 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(); 369 } 370 return ""; 371 } 372 373 ################################################################################ 374 375 sub add_course_form { 376 my ($self) = @_; 377 my $r = $self->r; 378 my $ce = $r->ce; 379 #my $db = $r->db; 380 #my $authz = $r->authz; 381 #my $urlpath = $r->urlpath; 382 383 my $add_courseID = $r->param("add_courseID") || ""; 384 my $add_courseTitle = $r->param("add_courseTitle") || ""; 385 my $add_courseInstitution = $r->param("add_courseInstitution") || ""; 386 387 my $add_admin_users = $r->param("add_admin_users") || ""; 388 389 my $add_initial_userID = $r->param("add_initial_userID") || ""; 390 my $add_initial_password = $r->param("add_initial_password") || ""; 391 my $add_initial_confirmPassword = $r->param("add_initial_confirmPassword") || ""; 392 my $add_initial_firstName = $r->param("add_initial_firstName") || ""; 393 my $add_initial_lastName = $r->param("add_initial_lastName") || ""; 394 my $add_initial_email = $r->param("add_initial_email") || ""; 395 396 my $add_templates_course = $r->param("add_templates_course") || ""; 397 398 my $add_dbLayout = $r->param("add_dbLayout") || ""; 399 400 my @dbLayouts = do { 401 my @ordered_layouts; 402 foreach my $layout (@{$ce->{dbLayout_order}}) { 403 if (exists $ce->{dbLayouts}->{$layout}) { 404 push @ordered_layouts, $layout; 405 } 406 } 407 408 my %ordered_layouts; @ordered_layouts{@ordered_layouts} = (); 409 my @other_layouts; 410 foreach my $layout (keys %{ $ce->{dbLayouts} }) { 411 unless (exists $ordered_layouts{$layout}) { 412 push @other_layouts, $layout; 413 } 414 } 415 416 (@ordered_layouts, @other_layouts); 417 }; 418 419 my $ce2 = WeBWorK::CourseEnvironment->new( 420 $ce->{webworkDirs}->{root}, 421 $ce->{webworkURLs}->{root}, 422 $ce->{pg}->{directories}->{root}, 423 "COURSENAME", 424 ); 425 426 my @existingCourses = listCourses($ce); 427 @existingCourses = sort { lc($a) cmp lc ($b) } @existingCourses; #make sort case insensitive 428 429 print CGI::h2("Add Course"); 430 431 print CGI::start_form(-method=>"POST", -action=>$r->uri); 432 print $self->hidden_authen_fields; 433 print $self->hidden_fields("subDisplay"); 434 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."); 436 437 print CGI::table({class=>"FormLayout"}, 438 CGI::Tr({}, 439 CGI::th({class=>"LeftHeader"}, "Course ID:"), 440 CGI::td(CGI::textfield(-name=>"add_courseID", -value=>$add_courseID, -size=>25)), 441 ), 442 CGI::Tr({}, 443 CGI::th({class=>"LeftHeader"}, "Course Title:"), 444 CGI::td(CGI::textfield(-name=>"add_courseTitle", -value=>$add_courseTitle, -size=>25)), 445 ), 446 CGI::Tr({}, 447 CGI::th({class=>"LeftHeader"}, "Institution:"), 448 CGI::td(CGI::textfield(-name=>"add_courseInstitution", -value=>$add_courseInstitution, -size=>25)), 449 ), 450 ); 451 452 print CGI::p("To add the WeBWorK administrators to the new course (as instructors) check the box below."); 453 my @checked = ($add_admin_users) ?(checked=>1): (); # workaround because CGI::checkbox seems to have a bug -- it won't default to checked. 454 print CGI::p({},CGI::input({-type=>'checkbox', -name=>"add_admin_users", @checked }, "Add WeBWorK administrators to new course")); 455 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"); 458 459 print CGI::table({class=>"FormLayout"}, CGI::Tr({}, 460 CGI::td({}, 461 CGI::table({class=>"FormLayout"}, 462 CGI::Tr({}, 463 CGI::th({class=>"LeftHeader"}, "User ID:"), 464 CGI::td(CGI::textfield(-name=>"add_initial_userID", -value=>$add_initial_userID, -size=>25)), 465 ), 466 CGI::Tr({}, 467 CGI::th({class=>"LeftHeader"}, "Password:"), 468 CGI::td(CGI::password_field(-name=>"add_initial_password", -value=>$add_initial_password, -size=>25)), 469 ), 470 CGI::Tr({}, 471 CGI::th({class=>"LeftHeader"}, "Confirm Password:"), 472 CGI::td(CGI::password_field(-name=>"add_initial_confirmPassword", -value=>$add_initial_confirmPassword, -size=>25)), 473 ), 474 ), 475 ), 476 CGI::td({}, 477 CGI::table({class=>"FormLayout"}, 478 CGI::Tr({}, 479 CGI::th({class=>"LeftHeader"}, "First Name:"), 480 CGI::td(CGI::textfield(-name=>"add_initial_firstName", -value=>$add_initial_firstName, -size=>25)), 481 ), 482 CGI::Tr({}, 483 CGI::th({class=>"LeftHeader"}, "Last Name:"), 484 CGI::td(CGI::textfield(-name=>"add_initial_lastName", -value=>$add_initial_lastName, -size=>25)), 485 ), 486 CGI::Tr({}, 487 CGI::th({class=>"LeftHeader"}, "Email Address:"), 488 CGI::td(CGI::textfield(-name=>"add_initial_email", -value=>$add_initial_email, -size=>25)), 489 ), 490 ), 491 492 ), 493 )); 494 495 print CGI::p("To copy problem templates from an existing course, select the course below."); 496 497 print CGI::table({class=>"FormLayout"}, 498 CGI::Tr({}, 499 CGI::th({class=>"LeftHeader"}, "Copy templates from:"), 500 CGI::td( 501 CGI::popup_menu( 502 -name => "add_templates_course", 503 -values => [ "", @existingCourses ], 504 -default => $add_templates_course, 505 #-size => 10, 506 #-multiple => 0, 507 #-labels => \%courseLabels, 508 ), 509 510 ), 511 ), 512 ); 513 514 515 516 print CGI::p("Select a database layout below."); 517 print CGI::start_table({class=>"FormLayout"}); 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); 522 foreach my $dbLayout (@dbLayouts) { 523 my $dbLayoutLabel = (defined $ce->{dbLayout_descr}{$dbLayout}) 524 ? "$dbLayout - " . $ce->{dbLayout_descr}{$dbLayout} 525 : "$dbLayout - no description provided in global.conf"; 526 print CGI::Tr({}, 527 CGI::td({width=>'20%'}, $dbLayout_buttons{$dbLayout}), 528 CGI::td($dbLayoutLabel), 529 ); 530 } 531 print CGI::end_table(); 532 print CGI::p({style=>"text-align: left"}, CGI::submit(-name=>"add_course", -label=>"Add Course")); 533 534 print CGI::end_form(); 535 } 536 537 sub add_course_validate { 538 my ($self) = @_; 539 my $r = $self->r; 540 my $ce = $r->ce; 541 #my $db = $r->db; 542 #my $authz = $r->authz; 543 #my $urlpath = $r->urlpath; 544 545 my $add_courseID = $r->param("add_courseID") || ""; 546 my $add_courseTitle = $r->param("add_courseTitle") || ""; 547 my $add_courseInstitution = $r->param("add_courseInstitution") || ""; 548 549 my $add_admin_users = $r->param("add_admin_users") || ""; 550 551 my $add_initial_userID = $r->param("add_initial_userID") || ""; 552 my $add_initial_password = $r->param("add_initial_password") || ""; 553 my $add_initial_confirmPassword = $r->param("add_initial_confirmPassword") || ""; 554 my $add_initial_firstName = $r->param("add_initial_firstName") || ""; 555 my $add_initial_lastName = $r->param("add_initial_lastName") || ""; 556 my $add_initial_email = $r->param("add_initial_email") || ""; 557 558 my $add_templates_course = $r->param("add_templates_course") || ""; 559 560 my $add_dbLayout = $r->param("add_dbLayout") || ""; 561 562 my @errors; 563 564 if ($add_courseID eq "") { 565 push @errors, "You must specify a course ID."; 566 } 567 unless ($add_courseID =~ /^[\w-]*$/) { # regex copied from CourseAdministration.pm 568 push @errors, "Course ID may only contain letters, numbers, hyphens, and underscores."; 569 } 570 if (grep { $add_courseID eq $_ } listCourses($ce)) { 571 push @errors, "A course with ID $add_courseID already exists."; 572 } 573 #if ($add_courseTitle eq "") { 574 # push @errors, "You must specify a course title."; 575 #} 576 #if ($add_courseInstitution eq "") { 577 # push @errors, "You must specify an institution for this course."; 578 #} 579 580 if ($add_initial_userID ne "") { 581 if ($add_initial_password eq "") { 582 push @errors, "You must specify a password for the initial instructor."; 583 } 584 if ($add_initial_confirmPassword eq "") { 585 push @errors, "You must confirm the password for the initial instructor."; 586 } 587 if ($add_initial_password ne $add_initial_confirmPassword) { 588 push @errors, "The password and password confirmation for the instructor must match."; 589 } 590 if ($add_initial_firstName eq "") { 591 push @errors, "You must specify a first name for the initial instructor."; 592 } 593 if ($add_initial_lastName eq "") { 594 push @errors, "You must specify a last name for the initial instructor."; 595 } 596 if ($add_initial_email eq "") { 597 push @errors, "You must specify an email address for the initial instructor."; 598 } 599 } 600 601 if ($add_dbLayout eq "") { 602 push @errors, "You must select a database layout."; 603 } else { 604 if (exists $ce->{dbLayouts}->{$add_dbLayout}) { 605 # we used to check for layout-specific fields here, but there aren't any layouts that require them 606 # anymore. (in the future, we'll probably deal with this in layout-specific modules.) 607 } else { 608 push @errors, "The database layout $add_dbLayout doesn't exist."; 609 } 610 } 611 612 return @errors; 613 } 614 615 sub do_add_course { 616 my ($self) = @_; 617 my $r = $self->r; 618 my $ce = $r->ce; 619 my $db = $r->db; 620 my $authz = $r->authz; 621 my $urlpath = $r->urlpath; 622 623 my $add_courseID = $r->param("add_courseID") || ""; 624 my $add_courseTitle = $r->param("add_courseTitle") || ""; 625 my $add_courseInstitution = $r->param("add_courseInstitution") || ""; 626 627 my $add_admin_users = $r->param("add_admin_users") || ""; 628 629 my $add_initial_userID = $r->param("add_initial_userID") || ""; 630 my $add_initial_password = $r->param("add_initial_password") || ""; 631 my $add_initial_confirmPassword = $r->param("add_initial_confirmPassword") || ""; 632 my $add_initial_firstName = $r->param("add_initial_firstName") || ""; 633 my $add_initial_lastName = $r->param("add_initial_lastName") || ""; 634 my $add_initial_email = $r->param("add_initial_email") || ""; 635 636 my $add_templates_course = $r->param("add_templates_course") || ""; 637 638 my $add_dbLayout = $r->param("add_dbLayout") || ""; 639 640 my $ce2 = WeBWorK::CourseEnvironment->new( 641 $ce->{webworkDirs}->{root}, 642 $ce->{webworkURLs}->{root}, 643 $ce->{pg}->{directories}->{root}, 644 $add_courseID, 645 ); 646 647 my %courseOptions = ( dbLayoutName => $add_dbLayout ); 648 649 if ($add_initial_email ne "") { 650 $courseOptions{allowedRecipients} = [ $add_initial_email ]; 651 # don't set feedbackRecipients -- this just gets in the way of the more 652 # intelligent "receive_recipients" method. 653 #$courseOptions{feedbackRecipients} = [ $add_initial_email ]; 654 } 655 656 # this is kinda left over from when we had 'gdbm' and 'sql' database layouts 657 # below this line, we would grab values from getopt and put them in this hash 658 # but for now the hash can remain empty 659 my %dbOptions; 660 661 my @users; 662 663 # copy users from current (admin) course if desired 664 if ($add_admin_users ne "") { 665 foreach my $userID ($db->listUsers) { 666 if ($userID eq $add_initial_userID) { 667 $self->addbadmessage( "User '$userID' will not be copied from admin course as it is the initial instructor."); 668 next; 669 } 670 my $User = $db->getUser($userID); 671 my $Password = $db->getPassword($userID); 672 my $PermissionLevel = $db->getPermissionLevel($userID); 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. 676 } 677 } 678 679 # add initial instructor if desired 680 if ($add_initial_userID ne "") { 681 my $User = $db->newUser( 682 user_id => $add_initial_userID, 683 first_name => $add_initial_firstName, 684 last_name => $add_initial_lastName, 685 student_id => $add_initial_userID, 686 email_address => $add_initial_email, 687 status => "C", 688 ); 689 my $Password = $db->newPassword( 690 user_id => $add_initial_userID, 691 password => cryptPassword($add_initial_password), 692 ); 693 my $PermissionLevel = $db->newPermissionLevel( 694 user_id => $add_initial_userID, 695 permission => "10", 696 ); 697 push @users, [ $User, $Password, $PermissionLevel ]; 698 } 699 700 push @{$courseOptions{PRINT_FILE_NAMES_FOR}}, map { $_->[0]->user_id } @users; 701 702 my %optional_arguments; 703 if ($add_templates_course ne "") { 704 $optional_arguments{templatesFrom} = $add_templates_course; 705 } 706 707 eval { 708 addCourse( 709 courseID => $add_courseID, 710 ce => $ce2, 711 courseOptions => \%courseOptions, 712 dbOptions => \%dbOptions, 713 users => \@users, 714 %optional_arguments, 715 ); 716 }; 717 if ($@) { 718 my $error = $@; 719 print CGI::div({class=>"ResultsWithError"}, 720 CGI::p("An error occured while creating the course $add_courseID:"), 721 CGI::tt(CGI::escapeHTML($error)), 722 ); 723 # get rid of any partially built courses 724 # FIXME -- this is too fragile 725 unless ($error =~ /course exists/) { 726 eval { 727 deleteCourse( 728 courseID => $add_courseID, 729 ce => $ce2, 730 dbOptions => \%dbOptions, 731 ); 732 } 733 } 734 } else { 735 #log the action 736 writeLog($ce, "hosted_courses", join("\t", 737 "\tAdded", 738 ( defined $add_courseInstitution ? $add_courseInstitution : "(no institution specified)" ), 739 ( defined $add_courseTitle ? $add_courseTitle : "(no title specified)" ), 740 $add_courseID, 741 $add_initial_firstName, 742 $add_initial_lastName, 743 $add_initial_email, 744 )); 745 # add contact to admin course as student? 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 } 776 print CGI::div({class=>"ResultsWithoutError"}, 777 CGI::p("Successfully created the course $add_courseID"), 778 ); 779 my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets", 780 courseID => $add_courseID); 781 my $newCourseURL = $self->systemLink($newCoursePath, authen => 0); 782 print CGI::div({style=>"text-align: center"}, 783 CGI::a({href=>$newCourseURL}, "Log into $add_courseID"), 784 ); 785 } 786 787 788 } 789 790 ################################################################################ 791 792 sub rename_course_form { 793 my ($self) = @_; 794 my $r = $self->r; 795 my $ce = $r->ce; 796 #my $db = $r->db; 797 #my $authz = $r->authz; 798 #my $urlpath = $r->urlpath; 799 800 my $rename_oldCourseID = $r->param("rename_oldCourseID") || ""; 801 my $rename_newCourseID = $r->param("rename_newCourseID") || ""; 802 803 my @courseIDs = listCourses($ce); 804 @courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; 805 806 my %courseLabels; # records... heh. 807 foreach my $courseID (@courseIDs) { 808 my $tempCE = WeBWorK::CourseEnvironment->new( 809 $ce->{webworkDirs}->{root}, 810 $ce->{webworkURLs}->{root}, 811 $ce->{pg}->{directories}->{root}, 812 $courseID, 813 ); 814 $courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")"; 815 } 816 817 print CGI::h2("Rename Course"); 818 819 print CGI::start_form(-method=>"POST", -action=>$r->uri); 820 print $self->hidden_authen_fields; 821 print $self->hidden_fields("subDisplay"); 822 823 print CGI::p("Select a course to rename."); 824 825 print CGI::table({class=>"FormLayout"}, 826 CGI::Tr({}, 827 CGI::th({class=>"LeftHeader"}, "Course Name:"), 828 CGI::td( 829 CGI::scrolling_list( 830 -name => "rename_oldCourseID", 831 -values => \@courseIDs, 832 -default => $rename_oldCourseID, 833 -size => 10, 834 -multiple => 0, 835 -labels => \%courseLabels, 836 ), 837 ), 838 ), 839 CGI::Tr({}, 840 CGI::th({class=>"LeftHeader"}, "New Name:"), 841 CGI::td(CGI::textfield(-name=>"rename_newCourseID", -value=>$rename_newCourseID, -size=>25)), 842 ), 843 ); 844 845 print CGI::end_table(); 846 847 print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"rename_course", -label=>"Rename Course")); 848 849 print CGI::end_form(); 850 } 851 852 sub rename_course_validate { 853 my ($self) = @_; 854 my $r = $self->r; 855 my $ce = $r->ce; 856 #my $db = $r->db; 857 #my $authz = $r->authz; 858 #my $urlpath = $r->urlpath; 859 860 my $rename_oldCourseID = $r->param("rename_oldCourseID") || ""; 861 my $rename_newCourseID = $r->param("rename_newCourseID") || ""; 862 863 my @errors; 864 865 if ($rename_oldCourseID eq "") { 866 push @errors, "You must select a course to rename."; 867 } 868 if ($rename_newCourseID eq "") { 869 push @errors, "You must specify a new name for the course."; 870 } 871 if ($rename_oldCourseID eq $rename_newCourseID) { 872 push @errors, "Can't rename to the same name."; 873 } 874 unless ($rename_newCourseID =~ /^[\w-]*$/) { # regex copied from CourseAdministration.pm 875 push @errors, "Course ID may only contain letters, numbers, hyphens, and underscores."; 876 } 877 if (grep { $rename_newCourseID eq $_ } listCourses($ce)) { 878 push @errors, "A course with ID $rename_newCourseID already exists."; 879 } 880 881 my $ce2 = WeBWorK::CourseEnvironment->new( 882 $ce->{webworkDirs}->{root}, 883 $ce->{webworkURLs}->{root}, 884 $ce->{pg}->{directories}->{root}, 885 $rename_oldCourseID, 886 ); 887 888 return @errors; 889 } 890 891 sub do_rename_course { 892 my ($self) = @_; 893 my $r = $self->r; 894 my $ce = $r->ce; 895 my $db = $r->db; 896 #my $authz = $r->authz; 897 my $urlpath = $r->urlpath; 898 899 my $rename_oldCourseID = $r->param("rename_oldCourseID") || ""; 900 my $rename_newCourseID = $r->param("rename_newCourseID") || ""; 901 902 my $ce2 = WeBWorK::CourseEnvironment->new( 903 $ce->{webworkDirs}->{root}, 904 $ce->{webworkURLs}->{root}, 905 $ce->{pg}->{directories}->{root}, 906 $rename_oldCourseID, 907 ); 908 909 my $dbLayoutName = $ce->{dbLayoutName}; 910 911 # this is kinda left over from when we had 'gdbm' and 'sql' database layouts 912 # below this line, we would grab values from getopt and put them in this hash 913 # but for now the hash can remain empty 914 my %dbOptions; 915 916 eval { 917 renameCourse( 918 courseID => $rename_oldCourseID, 919 ce => $ce2, 920 dbOptions => \%dbOptions, 921 newCourseID => $rename_newCourseID, 922 ); 923 }; 924 if ($@) { 925 my $error = $@; 926 print CGI::div({class=>"ResultsWithError"}, 927 CGI::p("An error occured while renaming the course $rename_oldCourseID to $rename_newCourseID:"), 928 CGI::tt(CGI::escapeHTML($error)), 929 ); 930 } else { 931 print CGI::div({class=>"ResultsWithoutError"}, 932 CGI::p("Successfully renamed the course $rename_oldCourseID to $rename_newCourseID"), 933 ); 934 my $newCoursePath = $urlpath->newFromModule("WeBWorK::ContentGenerator::ProblemSets", 935 courseID => $rename_newCourseID); 936 my $newCourseURL = $self->systemLink($newCoursePath, authen => 0); 937 print CGI::div({style=>"text-align: center"}, 938 CGI::a({href=>$newCourseURL}, "Log into $rename_newCourseID"), 939 ); 940 } 941 } 942 943 ################################################################################ 944 945 sub delete_course_form { 946 my ($self) = @_; 947 my $r = $self->r; 948 my $ce = $r->ce; 949 #my $db = $r->db; 950 #my $authz = $r->authz; 951 #my $urlpath = $r->urlpath; 952 953 my $delete_courseID = $r->param("delete_courseID") || ""; 954 955 my @courseIDs = listCourses($ce); 956 @courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive 957 958 my %courseLabels; # records... heh. 959 foreach my $courseID (@courseIDs) { 960 my $tempCE = WeBWorK::CourseEnvironment->new( 961 $ce->{webworkDirs}->{root}, 962 $ce->{webworkURLs}->{root}, 963 $ce->{pg}->{directories}->{root}, 964 $courseID, 965 ); 966 $courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")"; 967 } 968 969 print CGI::h2("Delete Course"); 970 971 print CGI::start_form(-method=>"POST", -action=>$r->uri); 972 print $self->hidden_authen_fields; 973 print $self->hidden_fields("subDisplay"); 974 975 print CGI::p("Select a course to delete."); 976 977 print CGI::table({class=>"FormLayout"}, 978 CGI::Tr({}, 979 CGI::th({class=>"LeftHeader"}, "Course Name:"), 980 CGI::td( 981 CGI::scrolling_list( 982 -name => "delete_courseID", 983 -values => \@courseIDs, 984 -default => $delete_courseID, 985 -size => 10, 986 -multiple => 0, 987 -labels => \%courseLabels, 988 ), 989 ), 990 ), 991 ); 992 993 print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"delete_course", -value=>"Delete Course")); 994 995 print CGI::end_form(); 996 } 997 998 sub delete_course_validate { 999 my ($self) = @_; 1000 my $r = $self->r; 1001 my $ce = $r->ce; 1002 #my $db = $r->db; 1003 #my $authz = $r->authz; 1004 my $urlpath = $r->urlpath; 1005 1006 my $delete_courseID = $r->param("delete_courseID") || ""; 1007 1008 my @errors; 1009 1010 if ($delete_courseID eq "") { 1011 push @errors, "You must specify a course name."; 1012 } elsif ($delete_courseID eq $urlpath->arg("courseID")) { 1013 push @errors, "You cannot delete the course you are currently using."; 1014 } 1015 1016 my $ce2 = WeBWorK::CourseEnvironment->new( 1017 $ce->{webworkDirs}->{root}, 1018 $ce->{webworkURLs}->{root}, 1019 $ce->{pg}->{directories}->{root}, 1020 $delete_courseID, 1021 ); 1022 1023 return @errors; 1024 } 1025 1026 sub delete_course_confirm { 1027 my ($self) = @_; 1028 my $r = $self->r; 1029 my $ce = $r->ce; 1030 #my $db = $r->db; 1031 #my $authz = $r->authz; 1032 #my $urlpath = $r->urlpath; 1033 1034 print CGI::h2("Delete Course"); 1035 1036 my $delete_courseID = $r->param("delete_courseID") || ""; 1037 1038 my $ce2 = WeBWorK::CourseEnvironment->new( 1039 $ce->{webworkDirs}->{root}, 1040 $ce->{webworkURLs}->{root}, 1041 $ce->{pg}->{directories}->{root}, 1042 $delete_courseID, 1043 ); 1044 1045 print CGI::p("Are you sure you want to delete the course " . CGI::b($delete_courseID) 1046 . "? All course files and data will be destroyed. There is no undo available."); 1047 1048 print CGI::start_form(-method=>"POST", -action=>$r->uri); 1049 print $self->hidden_authen_fields; 1050 print $self->hidden_fields("subDisplay"); 1051 print $self->hidden_fields(qw/delete_courseID/); 1052 1053 print CGI::p({style=>"text-align: center"}, 1054 CGI::submit(-name=>"decline_delete_course", -label=>"Don't delete"), 1055 " ", 1056 CGI::submit(-name=>"confirm_delete_course", -label=>"Delete"), 1057 ); 1058 1059 print CGI::end_form(); 1060 } 1061 1062 sub do_delete_course { 1063 my ($self) = @_; 1064 my $r = $self->r; 1065 my $ce = $r->ce; 1066 my $db = $r->db; 1067 #my $authz = $r->authz; 1068 #my $urlpath = $r->urlpath; 1069 1070 my $delete_courseID = $r->param("delete_courseID") || ""; 1071 1072 my $ce2 = WeBWorK::CourseEnvironment->new( 1073 $ce->{webworkDirs}->{root}, 1074 $ce->{webworkURLs}->{root}, 1075 $ce->{pg}->{directories}->{root}, 1076 $delete_courseID, 1077 ); 1078 1079 # this is kinda left over from when we had 'gdbm' and 'sql' database layouts 1080 # below this line, we would grab values from getopt and put them in this hash 1081 # but for now the hash can remain empty 1082 my %dbOptions; 1083 1084 eval { 1085 deleteCourse( 1086 courseID => $delete_courseID, 1087 ce => $ce2, 1088 dbOptions => \%dbOptions, 1089 ); 1090 }; 1091 1092 if ($@) { 1093 my $error = $@; 1094 print CGI::div({class=>"ResultsWithError"}, 1095 CGI::p("An error occured while deleting the course $delete_courseID:"), 1096 CGI::tt(CGI::escapeHTML($error)), 1097 ); 1098 } else { 1099 # 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 1116 print CGI::div({class=>"ResultsWithoutError"}, 1117 CGI::p("Successfully deleted the course $delete_courseID."), 1118 ); 1119 writeLog($ce, "hosted_courses", join("\t", 1120 "\tDeleted", 1121 "", 1122 "", 1123 $delete_courseID, 1124 )); 1125 print CGI::start_form(-method=>"POST", -action=>$r->uri); 1126 print $self->hidden_authen_fields; 1127 print $self->hidden_fields("subDisplay"); 1128 1129 print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"decline_delete_course", -value=>"OK"),); 1130 1131 print CGI::end_form(); 1132 } 1133 } 1134 1135 ################################################################################ 1136 1137 sub export_database_form { 1138 my ($self) = @_; 1139 my $r = $self->r; 1140 my $ce = $r->ce; 1141 #my $db = $r->db; 1142 #my $authz = $r->authz; 1143 #my $urlpath = $r->urlpath; 1144 1145 my @tables = keys %{$ce->{dbLayout}}; 1146 1147 my $export_courseID = $r->param("export_courseID") || ""; 1148 my @export_tables = $r->param("export_tables"); 1149 1150 @export_tables = @tables unless @export_tables; 1151 1152 my @courseIDs = listCourses($ce); 1153 @courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive 1154 1155 my %courseLabels; # records... heh. 1156 foreach my $courseID (@courseIDs) { 1157 my $tempCE = WeBWorK::CourseEnvironment->new( 1158 $ce->{webworkDirs}->{root}, 1159 $ce->{webworkURLs}->{root}, 1160 $ce->{pg}->{directories}->{root}, 1161 $courseID, 1162 ); 1163 $courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")"; 1164 } 1165 1166 print CGI::h2("Export Database"); 1167 1168 print CGI::p(IMPORT_EXPORT_WARNING); 1169 1170 print CGI::start_form(-method=>"GET", -action=>$r->uri); 1171 print $self->hidden_authen_fields; 1172 print $self->hidden_fields("subDisplay"); 1173 1174 print CGI::p({},"Select a course to export the course's database. Please note 1175 that exporting can take a very long time for a large course. If you have 1176 shell access to the WeBWorK server, you may use the ", CGI::code("wwdb"), " 1177 utility instead."); 1178 1179 print CGI::table({class=>"FormLayout"}, 1180 CGI::Tr({}, 1181 CGI::th({class=>"LeftHeader"}, "Course Name:"), 1182 CGI::td( 1183 CGI::scrolling_list( 1184 -name => "export_courseID", 1185 -values => \@courseIDs, 1186 -default => $export_courseID, 1187 -size => 10, 1188 -multiple => 1, 1189 -labels => \%courseLabels, 1190 ), 1191 ), 1192 ), 1193 CGI::Tr({}, 1194 CGI::th({class=>"LeftHeader"}, "Tables to Export:"), 1195 CGI::td({}, 1196 CGI::checkbox_group( 1197 -name => "export_tables", 1198 -values => \@tables, 1199 -default => \@export_tables, 1200 -linebreak => 1, 1201 ), 1202 ), 1203 ), 1204 ); 1205 1206 print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"export_database", -value=>"Export Database")); 1207 1208 print CGI::end_form(); 1209 } 1210 1211 sub export_database_validate { 1212 my ($self) = @_; 1213 my $r = $self->r; 1214 #my $ce = $r->ce; 1215 #my $db = $r->db; 1216 #my $authz = $r->authz; 1217 #my $urlpath = $r->urlpath; 1218 1219 my @export_courseID = $r->param("export_courseID") || (); 1220 my @export_tables = $r->param("export_tables"); 1221 1222 my @errors; 1223 1224 unless ( @export_courseID) { 1225 push @errors, "You must specify at least one course name."; 1226 } 1227 1228 unless (@export_tables) { 1229 push @errors, "You must specify at least one table to export."; 1230 } 1231 1232 return @errors; 1233 } 1234 1235 sub do_export_database { 1236 my ($self) = @_; 1237 my $r = $self->r; 1238 my $ce = $r->ce; 1239 #my $db = $r->db; 1240 #my $authz = $r->authz; 1241 my $urlpath = $r->urlpath; 1242 1243 my @export_courseID = $r->param("export_courseID"); 1244 my @export_tables = $r->param("export_tables"); 1245 1246 foreach my $export_courseID (@export_courseID) { 1247 1248 my $ce2 = WeBWorK::CourseEnvironment->new( 1249 $ce->{webworkDirs}->{root}, 1250 $ce->{webworkURLs}->{root}, 1251 $ce->{pg}->{directories}->{root}, 1252 $export_courseID, 1253 ); 1254 1255 my $db2 = new WeBWorK::DB($ce2->{dbLayout}); 1256 1257 #my ($fh, $export_file) = tempfile("db_export_XXXXXX", DIR => $ce->{webworkDirs}->{tmp}); 1258 #my ($random_chars) = $export_file =~ m/db_export_(\w+)$/; 1259 # export to the admin/templates directory 1260 my $exportFileName = "$export_courseID.exported.xml"; 1261 my $exportFilePath = $ce->{courseDirs}->{templates}."/$exportFileName"; 1262 # get a unique name 1263 my $number =1; 1264 while (-e "$exportFilePath.$number.gz") { 1265 $number++; 1266 last if $number>9; 1267 } 1268 if ($number<=9 ) { 1269 $exportFilePath = "$exportFilePath.$number"; 1270 $exportFileName = "$exportFileName.$number"; 1271 } else { 1272 $self->addbadmessage(CGI::p("There are more than 9 exported files for this course! Please 1273 remove some of these files.")); 1274 $exportFilePath = "$exportFilePath.999"; 1275 $exportFileName = "$exportFileName.999"; 1276 } 1277 1278 my $outputFileHandle = new IO::File(">$exportFilePath") or warn "Unable to create $exportFilePath"; 1279 1280 my @errors; 1281 eval { 1282 @errors = dbExport( 1283 db => $db2, 1284 #xml => $fh, 1285 xml => $outputFileHandle, 1286 tables => \@export_tables, 1287 ); 1288 }; 1289 1290 $outputFileHandle->close(); 1291 1292 my $gzipMessage = system($ce->{externalPrograms}{gzip}, $exportFilePath); 1293 if ( !$gzipMessage ) { 1294 $self->addgoodmessage(CGI::p( "Database saved to templates/$exportFileName.gz. 1295 You may download it with the file manager.")); 1296 } else { 1297 $self->addbadmessage(CGI::p( "Failed to gzip file $exportFilePath")); 1298 } 1299 unlink $exportFilePath; 1300 } # end export of one course 1301 #push @errors, "Fatal exception: $@" if $@; 1302 # 1303 #if (@errors) { 1304 # print CGI::div({class=>"ResultsWithError"}, 1305 # CGI::p("An error occured while exporting the database of course $export_courseID:"), 1306 # CGI::ul(CGI::li(\@errors)), 1307 # ); 1308 #} else { 1309 # print CGI::div({class=>"ResultsWithoutError"}, 1310 # CGI::p("Export succeeded."), 1311 # ); 1312 # 1313 # print CGI::div({style=>"text-align: center"}, 1314 # CGI::a({href=>$self->systemLink($urlpath, params=>{download_exported_database=>$random_chars, export_courseID=>undef})}, "Download Exported Database"), 1315 # ); 1316 #} 1317 } 1318 1319 ################################################################################ 1320 1321 sub import_database_form { 1322 my ($self) = @_; 1323 my $r = $self->r; 1324 my $ce = $r->ce; 1325 #my $db = $r->db; 1326 #my $authz = $r->authz; 1327 #my $urlpath = $r->urlpath; 1328 1329 my @tables = keys %{$ce->{dbLayout}}; 1330 1331 my $import_file = $r->param("import_file") || ""; 1332 my $import_courseID = $r->param("import_courseID") || ""; 1333 my @import_tables = $r->param("import_tables"); 1334 my $import_conflict = $r->param("import_conflict") || "skip"; 1335 1336 @import_tables = @tables unless @import_tables; 1337 1338 my @courseIDs = listCourses($ce); 1339 @courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive 1340 1341 1342 my %courseLabels; # records... heh. 1343 foreach my $courseID (@courseIDs) { 1344 my $tempCE = WeBWorK::CourseEnvironment->new( 1345 $ce->{webworkDirs}->{root}, 1346 $ce->{webworkURLs}->{root}, 1347 $ce->{pg}->{directories}->{root}, 1348 $courseID, 1349 ); 1350 $courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")"; 1351 } 1352 1353 # find databases: 1354 my $templatesDir = $ce->{courseDirs}->{templates}; 1355 my $exempt_dirs = join("|", keys %{ $r->ce->{courseFiles}->{problibs} }); 1356 1357 my @databaseFiles = listFilesRecursive( 1358 $templatesDir, 1359 qr/.\.exported\.xml\.\d*\.gz$/, # match these files #FIXME this is too restricive!! 1360 qr/^(?:$exempt_dirs|CVS)$/, # prune these directories 1361 0, # match against file name only 1362 1, # prune against path relative to $templatesDir 1363 ); 1364 1365 my %databaseLabels = map { ($_ => $_) } @databaseFiles; 1366 1367 ####### 1368 1369 print CGI::h2("Import Database"); 1370 1371 print CGI::p(IMPORT_EXPORT_WARNING); 1372 1373 print CGI::start_form(-method=>"POST", -action=>$r->uri, -enctype=>&CGI::MULTIPART); 1374 print $self->hidden_authen_fields; 1375 print $self->hidden_fields("subDisplay"); 1376 1377 print CGI::table({class=>"FormLayout"}, 1378 CGI::Tr({}, 1379 CGI::th({class=>"LeftHeader"}, "Database XML File:"), 1380 CGI::td( 1381 CGI::scrolling_list( 1382 -name => "import_file", 1383 -values => \@databaseFiles, 1384 -default => undef, 1385 -size => 10, 1386 -multiple => 0, 1387 -labels => \%databaseLabels, 1388 ), 1389 1390 ) 1391 ), 1392 CGI::Tr({}, 1393 CGI::th({class=>"LeftHeader"}, "Tables to Import:"), 1394 CGI::td( 1395 CGI::checkbox_group( 1396 -name => "import_tables", 1397 -values => \@tables, 1398 -default => \@import_tables, 1399 -linebreak => 1, 1400 ), 1401 ), 1402 ), 1403 CGI::Tr({}, 1404 CGI::th({class=>"LeftHeader"}, "Import into Course:"), 1405 CGI::td( 1406 CGI::scrolling_list( 1407 -name => "import_courseID", 1408 -values => \@courseIDs, 1409 -default => $import_courseID, 1410 -size => 10, 1411 -multiple => 0, 1412 -labels => \%courseLabels, 1413 ), 1414 ), 1415 ), 1416 CGI::Tr({}, 1417 CGI::th({class=>"LeftHeader"}, "Conflicts:"), 1418 CGI::td( 1419 CGI::radio_group( 1420 -name => "import_conflict", 1421 -values => [qw/skip replace/], 1422 -default => $import_conflict, 1423 -linebreak=>'true', 1424 -labels => { 1425 skip => "Skip duplicate records", 1426 replace => "Replace duplicate records", 1427 }, 1428 ), 1429 ), 1430 ), 1431 ); 1432 1433 print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"import_database", -value=>"Import Database")); 1434 1435 print CGI::end_form(); 1436 } 1437 1438 sub import_database_validate { 1439 my ($self) = @_; 1440 my $r = $self->r; 1441 #my $ce = $r->ce; 1442 #my $db = $r->db; 1443 #my $authz = $r->authz; 1444 #my $urlpath = $r->urlpath; 1445 1446 my $import_file = $r->param("import_file") || ""; 1447 my $import_courseID = $r->param("import_courseID") || ""; 1448 my @import_tables = $r->param("import_tables"); 1449 #my $import_conflict = $r->param("import_conflict") || "skip"; # not checked 1450 1451 my @errors; 1452 1453 if ($import_file eq "") { 1454 push @errors, "You must specify a database file to import."; 1455 } 1456 1457 if ($import_courseID eq "") { 1458 push @errors, "You must specify a course name."; 1459 } 1460 1461 unless (@import_tables) { 1462 push @errors, "You must specify at least one table to import."; 1463 } 1464 1465 return @errors; 1466 } 1467 1468 sub do_import_database { 1469 my ($self) = @_; 1470 my $r = $self->r; 1471 my $ce = $r->ce; 1472 #my $db = $r->db; 1473 #my $authz = $r->authz; 1474 my $urlpath = $r->urlpath; 1475 1476 my $import_file = $r->param("import_file"); 1477 my $import_courseID = $r->param("import_courseID"); 1478 my @import_tables = $r->param("import_tables"); 1479 my $import_conflict = $r->param("import_conflict") || "skip"; # need default -- not checked above 1480 1481 my $ce2 = WeBWorK::CourseEnvironment->new( 1482 $ce->{webworkDirs}->{root}, 1483 $ce->{webworkURLs}->{root}, 1484 $ce->{pg}->{directories}->{root}, 1485 $import_courseID, 1486 ); 1487 1488 my $db2 = new WeBWorK::DB($ce2->{dbLayout}); 1489 1490 # locate file 1491 my $templateDir = $ce->{courseDirs}->{templates}; 1492 my $filePath = "$templateDir/$import_file"; 1493 1494 my $gunzipMessage = system( 'gunzip', $filePath); 1495 #FIXME 1496 #warn "gunzip ", $gunzipMessage; 1497 $filePath =~ s/\.gz$//; 1498 #warn "new file path is $filePath"; 1499 my $fileHandle = new IO::File("<$filePath"); 1500 # retrieve upload from upload cache 1501 # my ($id, $hash) = split /\s+/, $import_file; 1502 # my $upload = WeBWorK::Upload->retrieve($id, $hash, 1503 # dir => $ce->{webworkDirs}->{uploadCache} 1504 # ); 1505 1506 my @errors; 1507 1508 eval { 1509 @errors = dbImport( 1510 db => $db2, 1511 # xml => $upload->fileHandle, 1512 xml => $fileHandle, 1513 tables => \@import_tables, 1514 conflict => $import_conflict, 1515 ); 1516 }; 1517 1518 push @errors, "Fatal exception: $@" if $@; 1519 push @errors, $gunzipMessage if $gunzipMessage; 1520 1521 if (@errors) { 1522 print CGI::div({class=>"ResultsWithError"}, 1523 CGI::p("An error occured while importing the database of course $import_courseID:"), 1524 CGI::ul(CGI::li(\@errors)), 1525 ); 1526 } else { 1527 print CGI::div({class=>"ResultsWithoutError"}, 1528 CGI::p("Import succeeded."), 1529 ); 1530 } 1531 } 1532 ########################################################################## 1533 sub archive_course_form { 1534 my ($self) = @_; 1535 my $r = $self->r; 1536 my $ce = $r->ce; 1537 #my $db = $r->db; 1538 #my $authz = $r->authz; 1539 #my $urlpath = $r->urlpath; 1540 1541 my $archive_courseID = $r->param("archive_courseID") || ""; 1542 1543 my @courseIDs = listCourses($ce); 1544 @courseIDs = sort {lc($a) cmp lc ($b) } @courseIDs; #make sort case insensitive 1545 1546 my %courseLabels; # records... heh. 1547 foreach my $courseID (@courseIDs) { 1548 my $tempCE = WeBWorK::CourseEnvironment->new( 1549 $ce->{webworkDirs}->{root}, 1550 $ce->{webworkURLs}->{root}, 1551 $ce->{pg}->{directories}->{root}, 1552 $courseID, 1553 ); 1554 $courseLabels{$courseID} = "$courseID (" . $tempCE->{dbLayoutName} . ")"; 1555 } 1556 1557 print CGI::h2("archive Course"); 1558 1559 print CGI::start_form(-method=>"POST", -action=>$r->uri); 1560 print $self->hidden_authen_fields; 1561 print $self->hidden_fields("subDisplay"); 1562 1563 print CGI::p("Select a course to archive."); 1564 1565 print CGI::table({class=>"FormLayout"}, 1566 CGI::Tr({}, 1567 CGI::th({class=>"LeftHeader"}, "Course Name:"), 1568 CGI::td( 1569 CGI::scrolling_list( 1570 -name => "archive_courseID", 1571 -values => \@courseIDs, 1572 -default => $archive_courseID, 1573 -size => 10, 1574 -multiple => 0, 1575 -labels => \%courseLabels, 1576 ), 1577 ), 1578 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 ) 1591 ); 1592 1593 print CGI::p( 1594 "Currently the archive facility is only available for mysql databases. 1595 It depends on the mysqldump application." 1596 ); 1597 1598 1599 print CGI::p({style=>"text-align: center"}, CGI::submit(-name=>"archive_course", -value=>"archive Course")); 1600 1601 print CGI::end_form(); 1602 } 1603 1604 sub archive_course_validate { 1605 my ($self) = @_; 1606 my $r = $self->r; 1607 my $ce = $r->ce; 1608 #my $db = $r->db; 1609 #my $authz = $r->authz; 1610 my $urlpath = $r->urlpath; 1611 1612 my $archive_courseID = $r->param("archive_courseID") || ""; 1613 1614 my @errors; 1615 1616 if ($archive_courseID eq "") { 1617 push @errors, "You must specify a course name."; 1618 } elsif ($archive_courseID eq $urlpath->arg("courseID")) { 1619 push @errors, "You cannot archive the course you are currently using."; 1620 } 1621 1622 #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") || ""; 1644 1645 my $ce2 = WeBWorK::CourseEnvironment->new( 1646 $ce->{webworkDirs}->{root}, 1647 $ce->{webworkURLs}->{root}, 1648 $ce->{pg}->{directories}->{root}, 1649 $archive_courseID, 1650 ); 1651 1652 if ($ce2->{dbLayoutName} ) { 1653 print CGI::p("Are you sure you want to archive the course " . CGI::b($archive_courseID) 1654 . "? "); 1655 print(CGI::p({-style=>'color:red; font-weight:bold'}, "Are you sure that you want to delete the course ". 1656 CGI::b($archive_courseID). " after archiving? This cannot be undone!")) if $delete_course_flag; 1657 1658 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(); 1673 } 1674 1675 sub do_archive_course { 1676 my ($self) = @_; 1677 my $r = $self->r; 1678 my $ce = $r->ce; 1679 my $db = $r->db; 1680 #my $authz = $r->authz; 1681 #my $urlpath = $r->urlpath; 1682 1683 my $archive_courseID = $r->param("archive_courseID") || ""; 1684 my $delete_course_flag = $r->param("delete_course") || ""; 1685 1686 my $ce2 = WeBWorK::CourseEnvironment->new( 1687 $ce->{webworkDirs}->{root}, 1688 $ce->{webworkURLs}->{root}, 1689 $ce->{pg}->{directories}->{root}, 1690 $archive_courseID, 1691 ); 1692 1693 # this is kinda left over from when we had 'gdbm' and 'sql' database layouts 1694 # below this line, we would grab values from getopt and put them in this hash 1695 # but for now the hash can remain empty 1696 my %dbOptions; 1697 1698 eval { 1699 archiveCourse( 1700 courseID => $archive_courseID, 1701 ce => $ce2, 1702 dbOptions => \%dbOptions, 1703 ); 1704 }; 1705 1706 if ($@) { 1707 my $error = $@; 1708 print CGI::div({class=>"ResultsWithError"}, 1709 CGI::p("An error occured while archiving the course $archive_courseID:"), 1710 CGI::tt(CGI::escapeHTML($error)), 1711 ); 1712 } else { 1713 print CGI::div({class=>"ResultsWithoutError"}, 1714 CGI::p("Successfully archived the course $archive_courseID"), 1715 ); 1716 writeLog($ce, "hosted_courses", join("\t", 1717 "\tarchived", 1718 "", 1719 "", 1720 $archive_courseID, 1721 )); 1722 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 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); 2239 print $self->hidden_authen_fields; 2240 print $self->hidden_fields("subDisplay"); 2241 print CGI::hidden(-name=>'edit_location', 2242 -default=>$locationID); 2243 print CGI::hidden(-name=>'manage_location_action', 2244 -default=>'edit_location_handler'); 2245 2246 print CGI::start_table(); 2247 print CGI::Tr({-valign=>'top'}, 2248 CGI::td({-colspan=>3}, 2249 "Location description: ", CGI::br(), 2250 CGI::textfield(-name=>"location_description", 2251 -size=>"50", 2252 -default=>$location->description))); 2253 print CGI::Tr({-valign=>'top'}, 2254 CGI::td({-width=>"50%"}, 2255 "Addresses to add to the location " . 2256 "(enter one per line, as single IP addresses " . 2257 "(e.g., 192.168.1.101), address masks " . 2258 "(e.g., 192.168.1.0/24), or IP ranges " . 2259 "(e.g., 192.168.1.101-192.168.1.150)):" . 2260 CGI::br() . 2261 CGI::textarea({-name=>"new_location_addresses", 2262 -rows=>5, -columns=>28})), 2263 CGI::td({}, " "), 2264 CGI::td({-width=>"50%"}, 2265 "Existing addresses for the location are " . 2266 "given in the scrolling list below. Select " . 2267 "addresses from the list to delete them:" . 2268 CGI::br() . 2269 CGI::scrolling_list(-name=>'delete_location_addresses', 2270 -values=>[@locAddresses], 2271 -size=>8, 2272 -multiple=>'multiple') . 2273 CGI::br() . "or: " . 2274 CGI::checkbox(-name=>'delete_all_addresses', 2275 -value=>'true', 2276 -label=>'Delete all existing addresses') 2277 )); 2278 2279 print CGI::end_table(); 2280 2281 print CGI::p({},CGI::submit(-value=>'Take Action!')); 2282 2283 } else { 2284 print CGI::div({-class=>"ResultsWithError"}, 2285 "Location $locationID does not exist " . 2286 "in the WeBWorK database. Please check " . 2287 "your input (perhaps you need to reload " . 2288 "the location management page?)."); 2289 2290 $self->manage_location_form; 2291 } 2292 } 2293 2294 sub edit_location_handler { 2295 my $self = shift; 2296 my $r = $self->r; 2297 my $db = $r->db; 2298 2299 my $locationID = $r->param("edit_location"); 2300 my $locationDesc = $r->param("location_description"); 2301 my $addAddresses = $r->param("new_location_addresses"); 2302 my @delAddresses = $r->param("delete_location_addresses"); 2303 my $deleteAll = $r->param("delete_all_addresses"); 2304 2305 # gut check 2306 if ( ! $locationID ) { 2307 print CGI::div({-class=>"ResultsWithError"}, 2308 "No location specified to edit?! " . 2309 "Please check your input data."); 2310 $self->manage_location_form; 2311 2312 } elsif ( ! $db->existsLocation( $locationID ) ) { 2313 print CGI::div({-class=>"ResultsWithError"}, 2314 "Location $locationID does not exist " . 2315 "in the WeBWorK database. Please check " . 2316 "your input (perhaps you need to reload " . 2317 "the location management page?)."); 2318 $self->manage_location_form; 2319 } else { 2320 my $location = $db->getLocation($locationID); 2321 2322 # get the current location addresses. if we're deleting 2323 # all of the existing addresses, we don't use this list 2324 # to determine which addresses to add, however. 2325 my @currentAddr = $db->listLocationAddresses($locationID); 2326 my @compareAddr = ( ! $deleteAll || $deleteAll ne 'true' ) 2327 ? @currentAddr : (); 2328 2329 my $doneMsg = ''; 2330 2331 if ($locationDesc && $location->description ne $locationDesc) { 2332 $location->description($locationDesc); 2333 $db->putLocation($location); 2334 $doneMsg .= CGI::p({},"Updated location description."); 2335 } 2336 # get the actual addresses to add out of the text field 2337 $addAddresses =~ s/\s*-\s*/-/g; 2338 $addAddresses =~ s/\s*\/\s*/\//g; 2339 my @addAddresses = split(/\s+/, $addAddresses); 2340 2341 # make sure that we're adding and deleting only those 2342 # addresses that are not yet/currently in the location 2343 # addresses 2344 my @toAdd = (); my @noAdd = (); 2345 my @toDel = (); my @noDel = (); 2346 foreach my $addr ( @addAddresses ) { 2347 if (grep {/^$addr$/} @compareAddr) {push(@noAdd,$addr);} 2348 else { push(@toAdd, $addr); } 2349 } 2350 if ( $deleteAll && $deleteAll eq 'true' ) { 2351 @toDel = @currentAddr; 2352 } else { 2353 foreach my $addr ( @delAddresses ) { 2354 if (grep {/^$addr$/} @currentAddr) { 2355 push(@toDel,$addr); 2356 } else { push(@noDel, $addr); } 2357 } 2358 } 2359 2360 # and make sure that all of the addresses we're adding are 2361 # a sensible form 2362 my $badAddr = ''; 2363 foreach my $addr ( @toAdd ) { 2364 unless ( new Net::IP($addr) ) { 2365 $badAddr .= "$addr, "; 2366 } 2367 } 2368 $badAddr =~ s/, $//; 2369 2370 # delete addresses first, because we allow deletion of 2371 # all existing addresses, then addition of addresses. 2372 # note that we don't allow deletion and then addition 2373 # of the same address normally, however; in that case 2374 # we'll end up just deleting the address. 2375 foreach ( @toDel ) { 2376 $db->deleteLocationAddress($locationID, $_); 2377 } 2378 foreach ( @toAdd ) { 2379 my $locAddr = $db->newLocationAddress; 2380 $locAddr->location_id($locationID); 2381 $locAddr->ip_mask($_); 2382 2383 $db->addLocationAddress($locAddr); 2384 } 2385 2386 my $addrMsg = ''; 2387 $addrMsg .= "Deleted addresses " . join(', ', @toDel) . 2388 " from location." . CGI::br() if ( @toDel ); 2389 $addrMsg .= "Added addresses " . join(', ', @toAdd) . 2390 " to location $locationID. " if ( @toAdd ); 2391 2392 my $badMsg = ''; 2393 $badMsg .= 'Address(es) ' . join(', ', @noAdd) . 2394 " in the add list is(are) already in the " . 2395 "location $locationID, and so were " . 2396 "skipped." . CGI::br() if ( @noAdd ); 2397 $badMsg .= "Address(es) $badAddr is(are) not in a " . 2398 "recognized form. Please check your data " . 2399 "entry and try again." . CGI::br() if ( $badAddr ); 2400 $badMsg .= 'Address(es) ' . join(', ', @noDel) . 2401 " in the delete list is(are) not in the " . 2402 "location $locationID, and so were " . 2403 "skipped." if ( @noDel ); 2404 2405 print CGI::div({-class=>"ResultsWithError"}, $badMsg) 2406 if ( $badMsg ); 2407 if ( $doneMsg || $addrMsg ) { 2408 print CGI::div({-class=>"ResultsWithoutError"}, 2409 CGI::p({}, $doneMsg, $addrMsg)); 2410 } else { 2411 print CGI::div({-class=>"ResultsWithError"}, 2412 "No valid changes submitted for ", 2413 "location $locationID."); 2414 } 2415 2416 $self->edit_location_form; 2417 } 2418 } 2419 2420 ################################################################################ 2421 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |