View of /trunk/webwork2/lib/WeBWorK/ContentGenerator/CourseAdmin.pm

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