Parent Directory
| 
Revision Log
changed all references to Safe to WWSafe just to be "safe" fixed security hole in file paths for Problem Set Detail uploaded changes to setmaker 2 from dg_dev. includes holding shift key down (before) you move a file in order to move it rather than to add it.
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/WeBWorK/CourseEnvironment.pm,v 1.37 2007/08/10 16:37:10 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::CourseEnvironment; 18 19 =head1 NAME 20 21 WeBWorK::CourseEnvironment - Read configuration information from global.conf 22 and course.conf files. 23 24 =head1 SYNOPSIS 25 26 use WeBWorK::CourseEnvironment; 27 $ce = WeBWorK::CourseEnvironment->new({ 28 webwork_url => "/webwork2", 29 webwork_dir => "/opt/webwork2", 30 pg_dir => "/opt/pg", 31 webwork_htdocs_url => "/webwork2_files", 32 webwork_htdocs_dir => "/opt/webwork2/htdocs", 33 webwork_courses_url => "/webwork2_course_files", 34 webwork_courses_dir => "/opt/webwork2/courses", 35 courseName => "name_of_course", 36 }); 37 38 my $timeout = $courseEnv->{sessionKeyTimeout}; 39 my $mode = $courseEnv->{pg}->{options}->{displayMode}; 40 # etc... 41 42 =head1 DESCRIPTION 43 44 The WeBWorK::CourseEnvironment module reads the system-wide F<global.conf> and 45 course-specific F<course.conf> files used by WeBWorK to calculate and store 46 settings needed throughout the system. The F<.conf> files are perl source files 47 that can contain any code allowed under the default safe compartment opset. 48 After evaluation of both files, any package variables are copied out of the 49 safe compartment into a hash. This hash becomes the course environment. 50 51 =cut 52 53 use strict; 54 use warnings; 55 use Carp; 56 use WWSafe; 57 use WeBWorK::Utils qw(readFile); 58 use WeBWorK::Debug; 59 use Opcode qw(empty_opset); 60 61 =head1 CONSTRUCTION 62 63 =over 64 65 =item new(HASHREF) 66 67 HASHREF is a reference to a hash containing scalar variables with which to seed 68 the course environment. It must contain at least a value for the key 69 C<webworkRoot>. 70 71 The C<new> method finds the file F<conf/global.conf> relative to the given 72 C<webwork_dir> directory. After reading this file, it uses the 73 C<$courseFiles{environment}> variable, if present, to locate the course 74 environment file. If found, the file is read and added to the environment. 75 76 =item new(ROOT URLROOT PGROOT COURSENAME) 77 78 A deprecated form of the constructor in which four seed variables are given 79 explicitly: C<webwork_dir>, C<webwork_url>, C<pg_dir>, and C<courseName>. 80 81 =cut 82 83 # NEW SYNTAX 84 # 85 # new($invocant, $seedVarsRef) 86 # $invocant implicitly set by caller 87 # $seedVarsRef reference to hash containing scalar variables with which to 88 # seed the course environment 89 # 90 # OLD SYNTAX 91 # 92 # new($invocant, $webworkRoot, $webworkURLRoot, $pgRoot, $courseName) 93 # $invocant implicitly set by caller 94 # $webworkRoot directory that contains the WeBWorK distribution 95 # $webworkURLRoot URL that points to the WeBWorK system 96 # $pgRoot directory that contains the PG distribution 97 # $courseName name of the course being used 98 sub new { 99 my ($invocant, @rest) = @_; 100 my $class = ref($invocant) || $invocant; 101 102 # contains scalar symbols/values with which to seed course environment 103 my %seedVars; 104 105 # where do we get the seed variables? 106 if (ref $rest[0] eq "HASH") { 107 %seedVars = %{$rest[0]}; 108 } else { 109 debug __PACKAGE__, ": deprecated four-argument form of new() used.\n"; 110 $seedVars{webwork_dir} = $rest[0]; 111 $seedVars{webwork_url} = $rest[1]; 112 $seedVars{pg_dir} = $rest[2]; 113 $seedVars{courseName} = $rest[3]; 114 } 115 116 my $safe = WWSafe->new; 117 118 # seed course environment with initial values 119 while (my ($var, $val) = each %seedVars) { 120 $val = "" if not defined $val; 121 $safe->reval("\$$var = '$val';"); 122 } 123 124 # Compile the "include" function with all opcodes available. 125 my $include = q[ sub include { 126 my ($file) = @_; 127 my $fullPath = "].$seedVars{webwork_dir}.q[/$file"; 128 # This regex matches any string that begins with "../", 129 # ends with "/..", contains "/../", or is "..". 130 if ($fullPath =~ m!(?:^|/)\.\.(?:/|$)!) { 131 die "Included file $file has potentially insecure path: contains \"..\""; 132 } else { 133 local @INC = (); 134 my $result = do $fullPath; 135 if ($!) { 136 warn "Failed to read include file $fullPath (has it been created from the corresponding .dist file?): $!"; 137 } elsif ($@) { 138 warn "Failed to compile include file $fullPath: $@"; 139 } elsif (not $result) { 140 warn "Include file $fullPath did not return a true value."; 141 } 142 } 143 } ]; 144 145 my $maskBackup = $safe->mask; 146 $safe->mask(empty_opset); 147 $safe->reval($include); 148 $@ and die "Failed to reval include subroutine: $@"; 149 $safe->mask($maskBackup); 150 151 # determine location of globalEnvironmentFile 152 my $globalEnvironmentFile = "$seedVars{webwork_dir}/conf/global.conf"; 153 154 # read and evaluate the global environment file 155 my $globalFileContents = readFile($globalEnvironmentFile); 156 $safe->reval($globalFileContents); 157 158 # if that evaluation failed, we can't really go on... 159 # we need a global environment! 160 $@ and die "Could not evaluate global environment file $globalEnvironmentFile: $@"; 161 162 # determine location of courseEnvironmentFile and simple configuration file 163 # pull it out of $safe's symbol table ad hoc 164 # (we don't want to do the hash conversion yet) 165 no strict 'refs'; 166 my $courseEnvironmentFile = ${*{${$safe->root."::"}{courseFiles}}}{environment}; 167 my $courseWebConfigFile = $seedVars{web_config_filename} || 168 ${*{${$safe->root."::"}{courseFiles}}}{simpleConfig}; 169 use strict 'refs'; 170 171 # read and evaluate the course environment file 172 # if readFile failed, we don't bother trying to reval 173 my $courseFileContents = eval { readFile($courseEnvironmentFile) }; # catch exceptions 174 $@ or $safe->reval($courseFileContents); 175 my $courseWebConfigContents = eval { readFile($courseWebConfigFile) }; # catch exceptions 176 $@ or $safe->reval($courseWebConfigContents); 177 178 # get the safe compartment's namespace as a hash 179 no strict 'refs'; 180 my %symbolHash = %{$safe->root."::"}; 181 use strict 'refs'; 182 183 # convert the symbol hash into a hash of regular variables. 184 my $self = {}; 185 foreach my $name (keys %symbolHash) { 186 # weed out internal symbols 187 next if $name =~ /^(INC|_.*|__ANON__|main::)$/; 188 # pull scalar, array, and hash values for this symbol 189 my $scalar = ${*{$symbolHash{$name}}}; 190 my @array = @{*{$symbolHash{$name}}}; 191 my %hash = %{*{$symbolHash{$name}}}; 192 # for multiple variables sharing a symbol, scalar takes precedence 193 # over array, which takes precedence over hash. 194 if (defined $scalar) { 195 $self->{$name} = $scalar; 196 } elsif (@array) { 197 $self->{$name} = \@array; 198 } elsif (%hash) { 199 $self->{$name} = \%hash; 200 } 201 } 202 203 bless $self, $class; 204 205 # here is where we can do evil things to the course environment *sigh* 206 # anything changed has to be done here. after this, CE is considered read-only 207 # anything added must be prefixed with an underscore. 208 209 # create reverse-lookup hash mapping status abbreviations to real names 210 $self->{_status_abbrev_to_name} = { 211 map { my $name = $_; map { $_ => $name } @{$self->{statuses}{$name}{abbrevs}} } 212 keys %{$self->{statuses}} 213 }; 214 215 # now that we're done, we can go ahead and return... 216 return $self; 217 } 218 219 =back 220 221 =head1 ACCESS 222 223 There are no formal accessor methods. However, since the course environemnt is 224 a hash of hashes and arrays, is exists as the self hash of an instance 225 variable: 226 227 $ce->{someKey}{someOtherKey}; 228 229 =head1 EXPERIMENTAL ACCESS METHODS 230 231 This is an experiment in extending CourseEnvironment to know a little more about 232 its contents, and perform useful operations for me. 233 234 There is a set of operations that require certain data from the course 235 environment. Most of these are un Utils.pm. I've been forced to pass $ce into 236 them, so that they can get their data out. But some things are so intrinsically 237 linked to the course environment that they might as well be methods in this 238 class. 239 240 =head2 STATUS METHODS 241 242 =over 243 244 =item status_abbrev_to_name($status_abbrev) 245 246 Given the abbreviation for a status, return the name. Returns undef if the 247 abbreviation is not found. 248 249 =cut 250 251 sub status_abbrev_to_name { 252 my ($ce, $status_abbrev) = @_; 253 if (not defined $status_abbrev or $status_abbrev eq "") { 254 carp "status_abbrev_to_name: status_abbrev (first argument) must be defined and non-empty"; 255 return; 256 } 257 258 return $ce->{_status_abbrev_to_name}{$status_abbrev}; 259 } 260 261 =item status_name_to_abbrevs($status_name) 262 263 Returns the list of abbreviations for a given status. Returns an empty list if 264 the status is not found. 265 266 =cut 267 268 sub status_name_to_abbrevs { 269 my ($ce, $status_name) = @_; 270 if (not defined $status_name or $status_name eq "") { 271 carp "status_name_to_abbrevs: status_name (first argument) must be defined and non-empty"; 272 return; 273 } 274 275 return unless exists $ce->{statuses}{$status_name}; 276 return @{$ce->{statuses}{$status_name}{abbrevs}}; 277 } 278 279 =item status_has_behavior($status_name, $behavior) 280 281 Return true if $status_name lists $behavior. 282 283 =cut 284 285 sub status_has_behavior { 286 my ($ce, $status_name, $behavior) = @_; 287 if (not defined $status_name or $status_name eq "") { 288 carp "status_has_behavior: status_name (first argument) must be defined and non-empty"; 289 return; 290 } 291 if (not defined $behavior or $behavior eq "") { 292 carp "status_has_behavior: behavior (second argument) must be defined and non-empty"; 293 return; 294 } 295 296 if (exists $ce->{statuses}{$status_name}) { 297 if (exists $ce->{statuses}{$status_name}{behaviors}) { 298 my $num_matches = grep { $_ eq $behavior } @{$ce->{statuses}{$status_name}{behaviors}}; 299 return $num_matches > 0; 300 } else { 301 return 0; # no behaviors 302 } 303 } else { 304 warn "status '$status_name' not found in \%statuses -- assuming no behaviors.\n"; 305 return 0; 306 } 307 } 308 309 =item status_abbrev_has_behavior($status_abbrev, $behavior) 310 311 Return true if the status abbreviated by $status_abbrev lists $behavior. 312 313 =cut 314 315 sub status_abbrev_has_behavior { 316 my ($ce, $status_abbrev, $behavior) = @_; 317 if (not defined $status_abbrev or $status_abbrev eq "") { 318 carp "status_abbrev_has_behavior: status_abbrev (first argument) must be defined and non-empty"; 319 return; 320 } 321 if (not defined $behavior or $behavior eq "") { 322 carp "status_abbrev_has_behavior: behavior (second argument) must be defined and non-empty"; 323 return; 324 } 325 326 my $status_name = $ce->status_abbrev_to_name($status_abbrev); 327 if (defined $status_name) { 328 return $ce->status_has_behavior($status_name, $behavior); 329 } else { 330 warn "status abbreviation '$status_abbrev' not found in \%statuses -- assuming no behaviors.\n"; 331 } 332 } 333 334 =back 335 336 =cut 337 338 1; 339 340 # perl doesn't look like line noise. line noise has way more alphanumerics.
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |