Parent Directory
| 
Revision Log
This commit was manufactured by cvs2svn to create branch 'rel-2-2-dev'.
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2003 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/WeBWorK/CourseEnvironment.pm,v 1.29 2005/10/05 18:16:51 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 Safe; 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{webworkRoot} = $rest[0]; 111 #$seedVars{webworkURLRoot} = $rest[1]; 112 #$seedVars{pgRoot} = $rest[2]; 113 $seedVars{webwork_dir} = $rest[0]; 114 $seedVars{webwork_url} = $rest[1]; 115 $seedVars{pg_dir} = $rest[2]; 116 $seedVars{courseName} = $rest[3]; 117 } 118 119 my $safe = Safe->new; 120 121 # seed course environment with initial values 122 while (my ($var, $val) = each %seedVars) { 123 $val = "" if not defined $val; 124 $safe->reval("\$$var = '$val';"); 125 } 126 127 # Compile the "include" function with all opcodes available. 128 my $include = q[ sub include { 129 my ($file) = @_; 130 my $fullPath = "].$seedVars{webwork_dir}.q[/$file"; 131 # This regex matches any string that begins with "../", 132 # ends with "/..", contains "/../", or is "..". 133 if ($fullPath =~ m!(?:^|/)\.\.(?:/|$)!) { 134 die "Included file $file has potentially insecure path: contains \"..\""; 135 } else { 136 local @INC = (); 137 my $result = do $fullPath; 138 if ($!) { 139 warn "Failed to read include file $fullPath (has it been created from the corresponding .dist file?): $!"; 140 } elsif ($@) { 141 warn "Failed to compile include file $fullPath: $@"; 142 } elsif (not $result) { 143 warn "Include file $fullPath did not return a true value."; 144 } 145 } 146 } ]; 147 148 my $maskBackup = $safe->mask; 149 $safe->mask(empty_opset); 150 $safe->reval($include); 151 $@ and die "Failed to reval include subroutine: $@"; 152 $safe->mask($maskBackup); 153 154 # determine location of globalEnvironmentFile 155 my $globalEnvironmentFile = "$seedVars{webwork_dir}/conf/global.conf"; 156 157 # read and evaluate the global environment file 158 my $globalFileContents = readFile($globalEnvironmentFile); 159 $safe->reval($globalFileContents); 160 161 # if that evaluation failed, we can't really go on... 162 # we need a global environment! 163 $@ and die "Could not evaluate global environment file $globalEnvironmentFile: $@"; 164 165 # determine location of courseEnvironmentFile and simple configuration file 166 # pull it out of $safe's symbol table ad hoc 167 # (we don't want to do the hash conversion yet) 168 no strict 'refs'; 169 my $courseEnvironmentFile = ${*{${$safe->root."::"}{courseFiles}}}{environment}; 170 my $courseWebConfigFile = $seedVars{web_config_filename} || 171 ${*{${$safe->root."::"}{courseFiles}}}{simpleConfig}; 172 use strict 'refs'; 173 174 # read and evaluate the course environment file 175 # if readFile failed, we don't bother trying to reval 176 my $courseFileContents = eval { readFile($courseEnvironmentFile) }; # catch exceptions 177 $@ or $safe->reval($courseFileContents); 178 my $courseWebConfigContents = eval { readFile($courseWebConfigFile) }; # catch exceptions 179 $@ or $safe->reval($courseWebConfigContents); 180 181 # get the safe compartment's namespace as a hash 182 no strict 'refs'; 183 my %symbolHash = %{$safe->root."::"}; 184 use strict 'refs'; 185 186 # convert the symbol hash into a hash of regular variables. 187 my $self = {}; 188 foreach my $name (keys %symbolHash) { 189 # weed out internal symbols 190 next if $name =~ /^(INC|_|__ANON__|main::)$/; 191 # pull scalar, array, and hash values for this symbol 192 my $scalar = ${*{$symbolHash{$name}}}; 193 my @array = @{*{$symbolHash{$name}}}; 194 my %hash = %{*{$symbolHash{$name}}}; 195 # for multiple variables sharing a symbol, scalar takes precedence 196 # over array, which takes precedence over hash. 197 if (defined $scalar) { 198 $self->{$name} = $scalar; 199 } elsif (@array) { 200 $self->{$name} = \@array; 201 } elsif (%hash) { 202 $self->{$name} = \%hash; 203 } 204 } 205 206 bless $self, $class; 207 208 # here is where we can do evil things to the course environment *sigh* 209 # anything changed has to be done here. after this, CE is considered read-only 210 # anything added must be prefixed with an underscore. 211 212 # create reverse-lookup hash mapping status abbreviations to real names 213 $self->{_status_abbrev_to_name} = { 214 map { my $name = $_; map { $_ => $name } @{$self->{statuses}{$name}{abbrevs}} } 215 keys %{$self->{statuses}} 216 }; 217 218 # now that we're done, we can go ahead and return... 219 return $self; 220 } 221 222 =back 223 224 =head1 ACCESS 225 226 There are no formal accessor methods. However, since the course environemnt is 227 a hash of hashes and arrays, is exists as the self hash of an instance 228 variable: 229 230 $ce->{someKey}{someOtherKey}; 231 232 =head1 EXPERIMENTAL ACCESS METHODS 233 234 This is an experiment in extending CourseEnvironment to know a little more about 235 its contents, and perform useful operations for me. 236 237 There is a set of operations that require certain data from the course 238 environment. Most of these are un Utils.pm. I've been forced to pass $ce into 239 them, so that they can get their data out. But some things are so intrinsically 240 linked to the course environment that they might as well be methods in this 241 class. 242 243 =head2 STATUS METHODS 244 245 =over 246 247 =item status_abbrev_to_name($status_abbrev) 248 249 Given the abbreviation for a status, return the name. Returns undef if the 250 abbreviation is not found. 251 252 =cut 253 254 sub status_abbrev_to_name { 255 my ($ce, $status_abbrev) = @_; 256 if (not defined $status_abbrev or $status_abbrev eq "") { 257 carp "status_abbrev_to_name: status_abbrev (first argument) must be defined and non-empty"; 258 return; 259 } 260 261 return $ce->{_status_abbrev_to_name}{$status_abbrev}; 262 } 263 264 =item status_name_to_abbrevs($status_name) 265 266 Returns the list of abbreviations for a given status. Returns an empty list if 267 the status is not found. 268 269 =cut 270 271 sub status_name_to_abbrevs { 272 my ($ce, $status_name) = @_; 273 if (not defined $status_name or $status_name eq "") { 274 carp "status_name_to_abbrevs: status_name (first argument) must be defined and non-empty"; 275 return; 276 } 277 278 return unless exists $ce->{statuses}{$status_name}; 279 return @{$ce->{statuses}{$status_name}{abbrevs}}; 280 } 281 282 =item status_has_behavior($status_name, $behavior) 283 284 Return true if $status_name lists $behavior. 285 286 =cut 287 288 sub status_has_behavior { 289 my ($ce, $status_name, $behavior) = @_; 290 if (not defined $status_name or $status_name eq "") { 291 carp "status_has_behavior: status_name (first argument) must be defined and non-empty"; 292 return; 293 } 294 if (not defined $behavior or $behavior eq "") { 295 carp "status_has_behavior: behavior (second argument) must be defined and non-empty"; 296 return; 297 } 298 299 if (exists $ce->{statuses}{$status_name}) { 300 if (exists $ce->{statuses}{$status_name}{behaviors}) { 301 my $num_matches = grep { $_ eq $behavior } @{$ce->{statuses}{$status_name}{behaviors}}; 302 return $num_matches > 0; 303 } else { 304 return 0; # no behaviors 305 } 306 } else { 307 warn "status '$status_name' not found in \%statuses -- assuming no behaviors.\n"; 308 return 0; 309 } 310 } 311 312 =item status_abbrev_has_behavior($status_abbrev, $behavior) 313 314 Return true if the status abbreviated by $status_abbrev lists $behavior. 315 316 =cut 317 318 sub status_abbrev_has_behavior { 319 my ($ce, $status_abbrev, $behavior) = @_; 320 if (not defined $status_abbrev or $status_abbrev eq "") { 321 carp "status_abbrev_has_behavior: status_abbrev (first argument) must be defined and non-empty"; 322 return; 323 } 324 if (not defined $behavior or $behavior eq "") { 325 carp "status_abbrev_has_behavior: behavior (second argument) must be defined and non-empty"; 326 return; 327 } 328 329 my $status_name = $ce->status_abbrev_to_name($status_abbrev); 330 if (defined $status_name) { 331 return $ce->status_has_behavior($status_name, $behavior); 332 } else { 333 warn "status abbreviation '$status_abbrev' not found in \%statuses -- assuming no behaviors.\n"; 334 } 335 } 336 337 =back 338 339 =cut 340 341 1; 342 343 # 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 |