[system] / branches / rel-2-4-patches / webwork2 / lib / WeBWorK / ContentGenerator / CourseAdmin.pm Repository:
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 4841 Revision 4910
1################################################################################ 1################################################################################
2# WeBWorK Online Homework Delivery System 2# WeBWorK Online Homework Delivery System
3# Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/ 3# Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/
4# $CVSHeader: webwork2/lib/WeBWorK/ContentGenerator/CourseAdmin.pm,v 1.60 2006/11/10 17:55:55 sh002i Exp $ 4# $CVSHeader: webwork2/lib/WeBWorK/ContentGenerator/CourseAdmin.pm,v 1.57.2.1 2006/11/10 17:59:09 sh002i Exp $
5# 5#
6# This program is free software; you can redistribute it and/or modify it under 6# This program is free software; you can redistribute it and/or modify it under
7# the terms of either: (a) the GNU General Public License as published by the 7# the terms of either: (a) the GNU General Public License as published by the
8# Free Software Foundation; either version 2, or (at your option) any later 8# Free Software Foundation; either version 2, or (at your option) any later
9# version, or (b) the "Artistic License" which comes with this package. 9# version, or (b) the "Artistic License" which comes with this package.
… …
25 25
26use strict; 26use strict;
27use warnings; 27use warnings;
28#use CGI qw(-nosticky ); 28#use CGI qw(-nosticky );
29use WeBWorK::CGI; 29use WeBWorK::CGI;
30use Data::Dumper;
30use File::Temp qw/tempfile/; 31use File::Temp qw/tempfile/;
31use WeBWorK::CourseEnvironment; 32use WeBWorK::CourseEnvironment;
32use IO::File; 33use IO::File;
33use String::ShellQuote;
34use WeBWorK::Debug; 34use WeBWorK::Debug;
35use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive); 35use WeBWorK::Utils qw(cryptPassword writeLog listFilesRecursive);
36use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse 36use WeBWorK::Utils::CourseManagement qw(addCourse renameCourse deleteCourse listCourses archiveCourse
37 listArchivedCourses unarchiveCourse); 37 listArchivedCourses unarchiveCourse);
38use WeBWorK::Utils::DBImportExport qw(dbExport dbImport); 38use WeBWorK::Utils::DBImportExport qw(dbExport dbImport);
39# needed for location management
40use Net::IP;
39 41
40use constant IMPORT_EXPORT_WARNING => "The ability to import and export 42use constant IMPORT_EXPORT_WARNING => "The ability to import and export
41databases is still under development. It seems to work but it is <b>VERY</b> 43databases is still under development. It seems to work but it is <b>VERY</b>
42slow on large courses. You may prefer to use webwork2/bin/wwdb or the mysql 44slow on large courses. You may prefer to use webwork2/bin/wwdb or the mysql
43dump facility for archiving large courses. Please send bug reports if you find 45dump facility for archiving large courses. Please send bug reports if you find
… …
207 } else { 209 } else {
208 # form only 210 # form only
209 $method_to_call = "unarchive_course_form"; 211 $method_to_call = "unarchive_course_form";
210 } 212 }
211 } 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 }
212 else { 223 else {
213 @errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}."; 224 @errors = "Unrecognized sub-display @{[ CGI::b($subDisplay) ]}.";
214 } 225 }
215
216 } 226 }
217 227
218 $self->{errors} = \@errors; 228 $self->{errors} = \@errors;
219 $self->{method_to_call} = $method_to_call; 229 $self->{method_to_call} = $method_to_call;
220} 230}
… …
298 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"), 308 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"import_database"})}, "Import Database"),
299 " | ", 309 " | ",
300 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"archive_course"})}, "Archive Course"), 310 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"archive_course"})}, "Archive Course"),
301 "|", 311 "|",
302 CGI::a({href=>$self->systemLink($urlpath, params=>{subDisplay=>"unarchive_course"})}, "Unarchive Course"), 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"),
303 CGI::hr(), 315 CGI::hr(),
304 $methodMessage, 316 $methodMessage,
305 317
306 ); 318 );
307 319
… …
648 660
649 my @users; 661 my @users;
650 662
651 # copy users from current (admin) course if desired 663 # copy users from current (admin) course if desired
652 if ($add_admin_users ne "") { 664 if ($add_admin_users ne "") {
653 # DBFIXME do the searching in the database, and grab user/passwd/perm. all at once with a join
654 foreach my $userID ($db->listUsers) { 665 foreach my $userID ($db->listUsers) {
655 if ($userID eq $add_initial_userID) { 666 if ($userID eq $add_initial_userID) {
656 $self->addbadmessage( "User '$userID' will not be copied from admin course as it is the initial instructor."); 667 $self->addbadmessage( "User '$userID' will not be copied from admin course as it is the initial instructor.");
657 next; 668 next;
658 } 669 }
… …
752 permission => "0", 763 permission => "0",
753 ); 764 );
754 # add contact to admin course as student 765 # add contact to admin course as student
755 # or if this contact and course already exist in a dropped status 766 # or if this contact and course already exist in a dropped status
756 # change the student's status to enrolled 767 # change the student's status to enrolled
757 # DBFIXME can use a REPLACE here?
758 if (my $oldUser = $db->getUser($composite_id) ) { 768 if (my $oldUser = $db->getUser($composite_id) ) {
759 warn "Replacing old data for $composite_id status: ". $oldUser->status; 769 warn "Replacing old data for $composite_id status: ". $oldUser->status;
760 $db->deleteUser($composite_id); 770 $db->deleteUser($composite_id);
761 } 771 }
762 eval { $db->addUser($User) }; warn $@ if $@; 772 eval { $db->addUser($User) }; warn $@ if $@;
… …
1086 CGI::tt(CGI::escapeHTML($error)), 1096 CGI::tt(CGI::escapeHTML($error)),
1087 ); 1097 );
1088 } else { 1098 } else {
1089 # mark the contact person in the admin course as dropped. 1099 # mark the contact person in the admin course as dropped.
1090 # find the contact person for the course by searching the admin classlist. 1100 # find the contact person for the course by searching the admin classlist.
1091 # DBFIXME use a where clause, iterator
1092 my @contacts = grep /_$delete_courseID$/, $db->listUsers; 1101 my @contacts = grep /_$delete_courseID$/, $db->listUsers;
1093 if (@contacts) { 1102 if (@contacts) {
1094 die "Incorrect number of contacts for the course $delete_courseID". join(" ", @contacts) if @contacts !=1; 1103 die "Incorrect number of contacts for the course $delete_courseID". join(" ", @contacts) if @contacts !=1;
1095 #warn "contacts", join(" ", @contacts); 1104 #warn "contacts", join(" ", @contacts);
1096 #my $composite_id = "${add_initial_userID}_${add_courseID}"; 1105 #my $composite_id = "${add_initial_userID}_${add_courseID}";
… …
1278 ); 1287 );
1279 }; 1288 };
1280 1289
1281 $outputFileHandle->close(); 1290 $outputFileHandle->close();
1282 1291
1283 my $gzip_cmd = "2>&1 ".$ce->{externalPrograms}{gzip}." ".shell_quote($exportFilePath); 1292 my $gzipMessage = system( 'gzip', $exportFilePath);
1284 my $gzip_out = readpipe $gzip_cmd; 1293 if ( !$gzipMessage ) {
1285 if ($?) { 1294 $self->addgoodmessage(CGI::p( "Database saved to templates/$exportFileName.gzip.
1286 my $exit = $? >> 8; 1295 You may download it with the file manager."));
1287 my $signal = $? & 127;
1288 my $core = $? & 128;
1289 $self->addbadmessage(CGI::p("Failed to gzip file $exportFilePath with command '$gzip_cmd' (exit=$exit signal=$signal core=$core): $gzip_out"));
1290 } else { 1296 } else {
1291 $self->addgoodmessage(CGI::p("Database saved to templates/$exportFileName.gzip. You may download it with the file manager.")); 1297 $self->addbadmessage(CGI::p( "Failed to gzip file $exportFilePath"));
1292 } 1298 }
1293 unlink $exportFilePath; 1299 unlink $exportFilePath;
1294 } # end export of one course 1300 } # end export of one course
1295 #push @errors, "Fatal exception: $@" if $@; 1301 #push @errors, "Fatal exception: $@" if $@;
1296 # 1302 #
… …
1483 1489
1484 # locate file 1490 # locate file
1485 my $templateDir = $ce->{courseDirs}->{templates}; 1491 my $templateDir = $ce->{courseDirs}->{templates};
1486 my $filePath = "$templateDir/$import_file"; 1492 my $filePath = "$templateDir/$import_file";
1487 1493
1494 my $gunzipMessage = system( 'gunzip', $filePath);
1495 #FIXME
1496 #warn "gunzip ", $gunzipMessage;
1497 $filePath =~ s/\.gz$//;
1498 #warn "new file path is $filePath";
1499 my $fileHandle = new IO::File("<$filePath");
1500 # retrieve upload from upload cache
1488# my ($id, $hash) = split /\s+/, $import_file; 1501# my ($id, $hash) = split /\s+/, $import_file;
1489# my $upload = WeBWorK::Upload->retrieve($id, $hash, 1502# my $upload = WeBWorK::Upload->retrieve($id, $hash,
1490# dir => $ce->{webworkDirs}->{uploadCache} 1503# dir => $ce->{webworkDirs}->{uploadCache}
1491# ); 1504# );
1492 1505
1493 my @errors; 1506 my @errors;
1494 1507
1495 my $gzip_cmd = "2>&1 ".$ce->{externalPrograms}{gzip}." -d ".shell_quote($filePath);
1496 my $gzip_out = readpipe $gzip_cmd;
1497 if ($?) {
1498 my $exit = $? >> 8;
1499 my $signal = $? & 127;
1500 my $core = $? & 128;
1501 push @errors, "Failed to ungzip file $filePath with command '$gzip_cmd' (exit=$exit signal=$signal core=$core): $gzip_out";
1502 } else {
1503 $filePath =~ s/\.gz$//;
1504 my $fileHandle = new IO::File("<$filePath");
1505 eval { 1508 eval {
1506 @errors = dbImport( 1509 @errors = dbImport(
1507 db => $db2, 1510 db => $db2,
1508 # xml => $upload->fileHandle, 1511 # xml => $upload->fileHandle,
1509 xml => $fileHandle, 1512 xml => $fileHandle,
1510 tables => \@import_tables, 1513 tables => \@import_tables,
1511 conflict => $import_conflict, 1514 conflict => $import_conflict,
1512 ); 1515 );
1513 }; 1516 };
1517
1514 push @errors, "Fatal exception: $@" if $@; 1518 push @errors, "Fatal exception: $@" if $@;
1515 } 1519 push @errors, $gunzipMessage if $gunzipMessage;
1516 1520
1517 if (@errors) { 1521 if (@errors) {
1518 print CGI::div({class=>"ResultsWithError"}, 1522 print CGI::div({class=>"ResultsWithError"},
1519 CGI::p("An error occured while importing the database of course $import_courseID:"), 1523 CGI::p("An error occured while importing the database of course $import_courseID:"),
1520 CGI::ul(CGI::li(\@errors)), 1524 CGI::ul(CGI::li(\@errors)),
… …
1523 print CGI::div({class=>"ResultsWithoutError"}, 1527 print CGI::div({class=>"ResultsWithoutError"},
1524 CGI::p("Import succeeded."), 1528 CGI::p("Import succeeded."),
1525 ); 1529 );
1526 } 1530 }
1527} 1531}
1528
1529########################################################################## 1532##########################################################################
1530
1531sub archive_course_form { 1533sub archive_course_form {
1532 my ($self) = @_; 1534 my ($self) = @_;
1533 my $r = $self->r; 1535 my $r = $self->r;
1534 my $ce = $r->ce; 1536 my $ce = $r->ce;
1535 #my $db = $r->db; 1537 #my $db = $r->db;
… …
1734 CGI::tt(CGI::escapeHTML($error)), 1736 CGI::tt(CGI::escapeHTML($error)),
1735 ); 1737 );
1736 } else { 1738 } else {
1737 # mark the contact person in the admin course as dropped. 1739 # mark the contact person in the admin course as dropped.
1738 # find the contact person for the course by searching the admin classlist. 1740 # find the contact person for the course by searching the admin classlist.
1739 # DBFIXME where clause, iterator
1740 my @contacts = grep /_$archive_courseID$/, $db->listUsers; 1741 my @contacts = grep /_$archive_courseID$/, $db->listUsers;
1741 if (@contacts) { 1742 if (@contacts) {
1742 die "Incorrect number of contacts for the course $archive_courseID". join(" ", @contacts) if @contacts !=1; 1743 die "Incorrect number of contacts for the course $archive_courseID". join(" ", @contacts) if @contacts !=1;
1743 #warn "contacts", join(" ", @contacts); 1744 #warn "contacts", join(" ", @contacts);
1744 #my $composite_id = "${add_initial_userID}_${add_courseID}"; 1745 #my $composite_id = "${add_initial_userID}_${add_courseID}";
… …
1931 ); 1932 );
1932 } 1933 }
1933} 1934}
1934 1935
1935################################################################################ 1936################################################################################
1937## location management routines; added by DG [Danny Ginn] 20070215
1938## revised by glarose
1939
1940sub manage_location_form {
1941 my ($self) = @_;
1942 my $r = $self->r;
1943 my $ce = $r->ce;
1944 my $db = $r->db;
1945 #my $authz = $r->authz;
1946 my $urlpath = $r->urlpath;
1947
1948 # get a list of all existing locations
1949 my @locations = sort {lc($a->location_id) cmp lc($b->location_id)}
1950 $db->getAllLocations();
1951 my %locAddr = map {$_->location_id => [ $db->listLocationAddresses($_->location_id) ]} @locations;
1952
1953 my @locationIDs = map { $_->location_id } @locations;
1954
1955 print CGI::h2("Manage Locations");
1956
1957 print CGI::p({},CGI::strong("Currently defined locations are listed below."));
1958
1959 print CGI::start_form(-method=>"POST", -action=>$r->uri);
1960 print $self->hidden_authen_fields;
1961 print $self->hidden_fields("subDisplay");
1962
1963 # get a list of radio buttons to select an action
1964 my @actionRadios =
1965 CGI::radio_group(-name => "manage_location_action",
1966 -values => ["edit_location_form",
1967 "add_location_handler",
1968 "delete_location_handler"],
1969 -labels => { edit_location_form => "",
1970 add_location_handler => "",
1971 delete_location_handler => "", },
1972 -default => $r->param("manage_location_action") ? $r->param("manage_location_action") : 'none');
1973
1974 print CGI::start_table({});
1975 print CGI::Tr({}, CGI::th({-colspan=>4,-align=>"left"},
1976 "Select an action to perform:"));
1977
1978 # edit action
1979 print CGI::Tr({},
1980 CGI::td({},[ $actionRadios[0], "Edit Location:" ]),
1981 CGI::td({-colspan=>2, -align=>"left"},
1982 CGI::div({-style=>"width:25%;"},
1983 CGI::popup_menu(-name=>"edit_location",
1984 -values=>[@locationIDs]))) );
1985 # create action
1986 print CGI::Tr({},
1987 CGI::td({-align=>"left"},[ $actionRadios[1],
1988 "Create Location:" ]),
1989 CGI::td({-colspan=>2},
1990 "Location name: " .
1991 CGI::textfield(-name=>"new_location_name",
1992 -size=>"10",
1993 -default=>$r->param("new_location_name")?$r->param("new_location_name"):'')));
1994 print CGI::Tr({valign=>'top'},
1995 CGI::td({}, ["&nbsp;", "Location description:"]),
1996 CGI::td({-colspan=>2},
1997 CGI::textfield(-name=>"new_location_description",
1998 -size=>"50",
1999 -default=>$r->param("new_location_description")?$r->param("new_location_description"):'')) );
2000 print CGI::Tr({}, CGI::td({},"&nbsp;"),
2001 CGI::td({-colspan=>3}, "Addresses for new location " .
2002 "(enter one per line, as single IP addresses " .
2003 "(e.g., 192.168.1.101), address masks (e.g., " .
2004 "192.168.1.0/24), or IP ranges (e.g., " .
2005 "192.168.1.101-192.168.1.150)):"));
2006 print CGI::Tr({}, CGI::td({}, "&nbsp;"),
2007 CGI::td({-colspan=>3},
2008 CGI::textarea({-name=>"new_location_addresses",
2009 -rows=>5, -columns=>28,
2010 -default=>$r->param("new_location_addresses")?$r->param("new_location_addresses"):''})));
2011
2012 # delete action
2013 print CGI::Tr({},
2014 CGI::td({-colspan=>4},
2015 CGI::div({-class=>"ResultsWithError"},
2016 CGI::em({}, "Deletion deletes all location " .
2017 "data and related addresses, and is" .
2018
2019 " not undoable!"))));
2020 print CGI::Tr({},
2021 CGI::td({},
2022 [ $actionRadios[2],
2023 CGI::div({-class=>"ResultsWithError"},
2024 "Delete location:") ]),
2025 CGI::td({-colspan=>2},
2026 CGI::popup_menu(-name=>"delete_location",
2027 -values=>["no location",
2028 @locationIDs]) .
2029 CGI::span({-style=>"color:#C33;"}, " Confirm: ") .
2030 CGI::checkbox({-name=>"delete_confirm",
2031 -value=>"true",
2032 -label=>""}) ) );
2033 print CGI::end_table();
2034
2035 print CGI::p({}, CGI::submit(-name=>"manage_locations", -value=>"Take Action!"));
2036
2037 print CGI::end_form();
2038
2039 # existing location table
2040 # FIXME: the styles for this table should be off in a stylesheet
2041 # somewhere
2042 print CGI::start_div({align=>"center"}),
2043 CGI::start_table({border=>1, cellpadding=>2});
2044 print CGI::Tr({style=>"background-color:#e0e0e0;font-size:92%", align=>"left"},
2045 CGI::th({}, ["Location","Description","Addresses"]));
2046 foreach my $loc ( @locations ) {
2047 print CGI::Tr({valign=>'top',style=>"background-color:#eeeeee;"},
2048 CGI::td({style=>'font-size:85%;'},
2049 [ $loc->location_id,
2050 $loc->description,
2051 join(', ', @{$locAddr{$loc->location_id}}) ]));
2052 }
2053 print CGI::end_table(), CGI::end_div();
2054
2055}
2056
2057sub add_location_handler {
2058 my $self = shift();
2059 my $r = $self->r;
2060 my $db = $r->db;
2061
2062 # the location data we're to add
2063 my $locationID = $r->param("new_location_name");
2064 my $locationDescr = $r->param("new_location_description");
2065 my $locationAddr = $r->param("new_location_addresses");
2066 # break the addresses up
2067 $locationAddr =~ s/\s*-\s*/-/g;
2068 $locationAddr =~ s/\s*\/\s*/\//g;
2069 my @addresses = split(/\s+/, $locationAddr);
2070
2071 # sanity checks
2072 my $badAddr = '';
2073 foreach my $addr ( @addresses ) {
2074 unless ( new Net::IP($addr) ) {
2075 $badAddr .= "$addr, ";
2076 $locationAddr =~ s/$addr\n//s;
2077 }
2078 }
2079 $badAddr =~ s/, $//;
2080
2081 # a check to be sure that the location addresses don't already
2082 # exist
2083 my $badLocAddr;
2084 if ( ! $badAddr && $locationID ) {
2085 if ( $db->countLocationAddresses( $locationID ) ) {
2086 my @allLocAddr = $db->listLocationAddresses($locationID);
2087 foreach my $addr ( @addresses ) {
2088 $badLocAddr .= "$addr, "
2089 if ( grep {/^$addr$/} @allLocAddr );
2090 }
2091 $badLocAddr =~ s/, $//;
2092 }
2093 }
2094
2095 if ( ! @addresses || ! $locationID || ! $locationDescr ) {
2096 print CGI::div({-class=>"ResultsWithError"},
2097 "Missing required input data. Please check " .
2098 "that you have filled in all of the create " .
2099 "location fields and resubmit.");
2100 } elsif ( $badAddr ) {
2101 $r->param("new_location_addresses", $locationAddr);
2102 print CGI::div({-class=>"ResultsWithError"},
2103 "Address(es) $badAddr is(are) not in a " .
2104 "recognized form. Please check your " .
2105 "data entry and resubmit.");
2106 } elsif ( $db->existsLocation( $locationID ) ) {
2107 print CGI::div({-class=>"ResultsWithError"},
2108 "A location with the name $locationID " .
2109 "already exists in the database. Did " .
2110 "you mean to edit that location instead?");
2111 } elsif ( $badLocAddr ) {
2112 print CGI::div({-class=>"ResultsWithError"},
2113 "Address(es) $badLocAddr already exist " .
2114 "in the database. THIS SHOULD NOT HAPPEN! " .
2115 "Please double check the integrity of " .
2116 "the WeBWorK database before continuing.");
2117 } else {
2118 # add the location
2119 my $locationObj = $db->newLocation;
2120 $locationObj->location_id( $locationID );
2121 $locationObj->description( $locationDescr );
2122 $db->addLocation( $locationObj );
2123
2124 # and add the addresses
2125 foreach my $addr ( @addresses ) {
2126 my $locationAddress = $db->newLocationAddress;
2127 $locationAddress->location_id($locationID);
2128 $locationAddress->ip_mask($addr);
2129
2130 $db->addLocationAddress( $locationAddress );
2131 }
2132
2133 # we've added the location, so clear those param
2134 # entries
2135 $r->param('manage_location_action','none');
2136 $r->param('new_location_name','');
2137 $r->param('new_location_description','');
2138 $r->param('new_location_addresses','');
2139
2140 print CGI::div({-class=>"ResultsWithoutError"},
2141 "Location $locationID has been created, " .
2142 "with addresses " . join(', ', @addresses) .
2143 ".");
2144 }
2145
2146 $self->manage_location_form;
2147}
2148
2149sub delete_location_handler {
2150 my $self = shift;
2151 my $r = $self->r;
2152 my $db = $r->db;
2153
2154 # what location are we deleting?
2155 my $locationID = $r->param("delete_location");
2156 # are we sure?
2157 my $confirm = $r->param("delete_confirm");
2158
2159 if ( ! $locationID ) {
2160 print CGI::div({-class=>"ResultsWithError"},
2161 "Please provide a location name " .
2162 "to delete.");
2163
2164 } elsif ( ! $db->existsLocation($locationID) ) {
2165 print CGI::div({-class=>"ResultsWithError"},
2166 "No location with name $locationID " .
2167 "exists in the database.");
2168
2169 } elsif ( ! $confirm || $confirm ne 'true' ) {
2170 print CGI::div({-class=>"ResultsWithError"},
2171 "Location deletion requires confirmation.");
2172 } else {
2173 $db->deleteLocation( $locationID );
2174 print CGI::div({-class=>"ResultsWithoutError"},
2175 "Location $locationID has been deleted.");
2176 $r->param('manage_location_action','none');
2177 $r->param('delete_location','');
2178 }
2179 $self->manage_location_form;
2180}
2181
2182sub edit_location_form {
2183 my $self = shift;
2184 my $r = $self->r;
2185 my $db = $r->db;
2186
2187 my $locationID = $r->param("edit_location");
2188 if ( $db->existsLocation( $locationID ) ) {
2189 my $location = $db->getLocation($locationID);
2190 # this doesn't give that nice a sort for IP addresses,
2191 # b/c there's the problem with 192.168.1.168 sorting
2192 # ahead of 192.168.1.2. we could do better if we
2193 # either invoked Net::IP in the sort routine, or if
2194 # we insisted on dealing only with IPv4. rather than
2195 # deal with either of those, we'll leave this for now
2196 my @locAddresses = sort { $a cmp $b }
2197 $db->listLocationAddresses($locationID);
2198
2199 print CGI::h2("Editing location ", $locationID);
2200
2201 print CGI::p({},"Edit the current value of the location ",
2202 "description, if desired, then add and select ",
2203 "addresses to delete, and then click the ",
2204 "\"Take Action\" button to make all of your ",
2205 "changes. Or, click \"Manage Locations\" ",
2206 "above to make no changes and return to the ",
2207 "Manage Locations page.");
2208
2209 print CGI::start_form(-method=>"POST",
2210 -action=>$r->uri);
2211 print $self->hidden_authen_fields;
2212 print $self->hidden_fields("subDisplay");
2213 print CGI::hidden(-name=>'edit_location',
2214 -default=>$locationID);
2215 print CGI::hidden(-name=>'manage_location_action',
2216 -default=>'edit_location_handler');
2217
2218 print CGI::start_table();
2219 print CGI::Tr({-valign=>'top'},
2220 CGI::td({-colspan=>3},
2221 "Location description: ", CGI::br(),
2222 CGI::textfield(-name=>"location_description",
2223 -size=>"50",
2224 -default=>$location->description)));
2225 print CGI::Tr({-valign=>'top'},
2226 CGI::td({-width=>"50%"},
2227 "Addresses to add to the location " .
2228 "(enter one per line, as single IP addresses " .
2229 "(e.g., 192.168.1.101), address masks " .
2230 "(e.g., 192.168.1.0/24), or IP ranges " .
2231 "(e.g., 192.168.1.101-192.168.1.150)):" .
2232 CGI::br() .
2233 CGI::textarea({-name=>"new_location_addresses",
2234 -rows=>5, -columns=>28})),
2235 CGI::td({}, "&nbsp;"),
2236 CGI::td({-width=>"50%"},
2237 "Existing addresses for the location are " .
2238 "given in the scrolling list below. Select " .
2239 "addresses from the list to delete them:" .
2240 CGI::br() .
2241 CGI::scrolling_list(-name=>'delete_location_addresses',
2242 -values=>[@locAddresses],
2243 -size=>8,
2244 -multiple=>'multiple') .
2245 CGI::br() . "or: " .
2246 CGI::checkbox(-name=>'delete_all_addresses',
2247 -value=>'true',
2248 -label=>'Delete all existing addresses')
2249 ));
2250
2251 print CGI::end_table();
2252
2253 print CGI::p({},CGI::submit(-value=>'Take Action!'));
2254
2255 } else {
2256 print CGI::div({-class=>"ResultsWithError"},
2257 "Location $locationID does not exist " .
2258 "in the WeBWorK database. Please check " .
2259 "your input (perhaps you need to reload " .
2260 "the location management page?).");
2261
2262 $self->manage_location_form;
2263 }
2264}
2265
2266sub edit_location_handler {
2267 my $self = shift;
2268 my $r = $self->r;
2269 my $db = $r->db;
2270
2271 my $locationID = $r->param("edit_location");
2272 my $locationDesc = $r->param("location_description");
2273 my $addAddresses = $r->param("new_location_addresses");
2274 my @delAddresses = $r->param("delete_location_addresses");
2275 my $deleteAll = $r->param("delete_all_addresses");
2276
2277 # gut check
2278 if ( ! $locationID ) {
2279 print CGI::div({-class=>"ResultsWithError"},
2280 "No location specified to edit?! " .
2281 "Please check your input data.");
2282 $self->manage_location_form;
2283
2284 } elsif ( ! $db->existsLocation( $locationID ) ) {
2285 print CGI::div({-class=>"ResultsWithError"},
2286 "Location $locationID does not exist " .
2287 "in the WeBWorK database. Please check " .
2288 "your input (perhaps you need to reload " .
2289 "the location management page?).");
2290 $self->manage_location_form;
2291 } else {
2292 my $location = $db->getLocation($locationID);
2293
2294 # get the current location addresses. if we're deleting
2295 # all of the existing addresses, we don't use this list
2296 # to determine which addresses to add, however.
2297 my @currentAddr = $db->listLocationAddresses($locationID);
2298 my @compareAddr = ( ! $deleteAll || $deleteAll ne 'true' )
2299 ? @currentAddr : ();
2300
2301 my $doneMsg = '';
2302
2303 if ($locationDesc && $location->description ne $locationDesc) {
2304 $location->description($locationDesc);
2305 $db->putLocation($location);
2306 $doneMsg .= CGI::p({},"Updated location description.");
2307 }
2308 # get the actual addresses to add out of the text field
2309 $addAddresses =~ s/\s*-\s*/-/g;
2310 $addAddresses =~ s/\s*\/\s*/\//g;
2311 my @addAddresses = split(/\s+/, $addAddresses);
2312
2313 # make sure that we're adding and deleting only those
2314 # addresses that are not yet/currently in the location
2315 # addresses
2316 my @toAdd = (); my @noAdd = ();
2317 my @toDel = (); my @noDel = ();
2318 foreach my $addr ( @addAddresses ) {
2319 if (grep {/^$addr$/} @compareAddr) {push(@noAdd,$addr);}
2320 else { push(@toAdd, $addr); }
2321 }
2322 if ( $deleteAll && $deleteAll eq 'true' ) {
2323 @toDel = @currentAddr;
2324 } else {
2325 foreach my $addr ( @delAddresses ) {
2326 if (grep {/^$addr$/} @currentAddr) {
2327 push(@toDel,$addr);
2328 } else { push(@noDel, $addr); }
2329 }
2330 }
2331
2332 # and make sure that all of the addresses we're adding are
2333 # a sensible form
2334 my $badAddr = '';
2335 foreach my $addr ( @toAdd ) {
2336 unless ( new Net::IP($addr) ) {
2337 $badAddr .= "$addr, ";
2338 }
2339 }
2340 $badAddr =~ s/, $//;
2341
2342 # delete addresses first, because we allow deletion of
2343 # all existing addresses, then addition of addresses.
2344 # note that we don't allow deletion and then addition
2345 # of the same address normally, however; in that case
2346 # we'll end up just deleting the address.
2347 foreach ( @toDel ) {
2348 $db->deleteLocationAddress($locationID, $_);
2349 }
2350 foreach ( @toAdd ) {
2351 my $locAddr = $db->newLocationAddress;
2352 $locAddr->location_id($locationID);
2353 $locAddr->ip_mask($_);
2354
2355 $db->addLocationAddress($locAddr);
2356 }
2357
2358 my $addrMsg = '';
2359 $addrMsg .= "Deleted addresses " . join(', ', @toDel) .
2360 " from location." . CGI::br() if ( @toDel );
2361 $addrMsg .= "Added addresses " . join(', ', @toAdd) .
2362 " to location $locationID. " if ( @toAdd );
2363
2364 my $badMsg = '';
2365 $badMsg .= 'Address(es) ' . join(', ', @noAdd) .
2366 " in the add list is(are) already in the " .
2367 "location $locationID, and so were " .
2368 "skipped." . CGI::br() if ( @noAdd );
2369 $badMsg .= "Address(es) $badAddr is(are) not in a " .
2370 "recognized form. Please check your data " .
2371 "entry and try again." . CGI::br() if ( $badAddr );
2372 $badMsg .= 'Address(es) ' . join(', ', @noDel) .
2373 " in the delete list is(are) not in the " .
2374 "location $locationID, and so were " .
2375 "skipped." if ( @noDel );
2376
2377 print CGI::div({-class=>"ResultsWithError"}, $badMsg)
2378 if ( $badMsg );
2379 if ( $doneMsg || $addrMsg ) {
2380 print CGI::div({-class=>"ResultsWithoutError"},
2381 CGI::p({}, $doneMsg, $addrMsg));
2382 } else {
2383 print CGI::div({-class=>"ResultsWithError"},
2384 "No valid changes submitted for ",
2385 "location $locationID.");
2386 }
2387
2388 $self->edit_location_form;
2389 }
2390}
2391
2392################################################################################
19361; 23931;
Legend:
Removed from v.4841  
changed lines
  Added in v.4910
aubreyja at gmail dot com
 ViewVC Help
Powered by ViewVC 1.0.9