[system] / trunk / webwork2 / lib / WeBWorK / CourseEnvironment.pm Repository:
ViewVC logotype

Annotation of /trunk/webwork2/lib/WeBWorK/CourseEnvironment.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6635 - (view) (download) (as text)

1 : sh002i 440 ################################################################################
2 : sh002i 1663 # WeBWorK Online Homework Delivery System
3 : sh002i 5319 # 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 : sh002i 1663 #
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 : sh002i 440 ################################################################################
16 :    
17 : malsyned 283 package WeBWorK::CourseEnvironment;
18 :    
19 : sh002i 455 =head1 NAME
20 :    
21 :     WeBWorK::CourseEnvironment - Read configuration information from global.conf
22 :     and course.conf files.
23 :    
24 : sh002i 3688 =head1 SYNOPSIS
25 :    
26 :     use WeBWorK::CourseEnvironment;
27 :     $ce = WeBWorK::CourseEnvironment->new({
28 :     webwork_url => "/webwork2",
29 :     webwork_dir => "/opt/webwork2",
30 : sh002i 5301 pg_dir => "/opt/pg",
31 : sh002i 3688 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 : sh002i 455 =cut
52 :    
53 : sh002i 319 use strict;
54 :     use warnings;
55 : sh002i 3729 use Carp;
56 : gage 6585 use WWSafe;
57 : sh002i 412 use WeBWorK::Utils qw(readFile);
58 : sh002i 2491 use WeBWorK::Debug;
59 : malsyned 1092 use Opcode qw(empty_opset);
60 : malsyned 283
61 : sh002i 3688 =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 : sh002i 5301 explicitly: C<webwork_dir>, C<webwork_url>, C<pg_dir>, and C<courseName>.
80 : sh002i 3688
81 :     =cut
82 :    
83 : sh002i 2491 # 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 : sh002i 1051 # new($invocant, $webworkRoot, $webworkURLRoot, $pgRoot, $courseName)
93 : sh002i 2491 # $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 : malsyned 283 sub new {
99 : sh002i 2491 my ($invocant, @rest) = @_;
100 : sh002i 319 my $class = ref($invocant) || $invocant;
101 : sh002i 2491
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 : sh002i 5301 $seedVars{pg_dir} = $rest[2];
113 : sh002i 2491 $seedVars{courseName} = $rest[3];
114 :     }
115 :    
116 : gage 6635 my $safe = WWSafe->new;
117 : malsyned 283
118 : sh002i 2491 # 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 : sh002i 319
124 : malsyned 1092 # Compile the "include" function with all opcodes available.
125 : gage 1119 my $include = q[ sub include {
126 : malsyned 1093 my ($file) = @_;
127 : sh002i 2491 my $fullPath = "].$seedVars{webwork_dir}.q[/$file";
128 : sh002i 1695 # This regex matches any string that begins with "../",
129 :     # ends with "/..", contains "/../", or is "..".
130 : gage 1119 if ($fullPath =~ m!(?:^|/)\.\.(?:/|$)!) {
131 : malsyned 1093 die "Included file $file has potentially insecure path: contains \"..\"";
132 : malsyned 1085 } else {
133 : malsyned 1093 local @INC = ();
134 : sh002i 3674 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 : sh002i 1695 }
142 : malsyned 1085 }
143 : gage 1119 } ];
144 : malsyned 1092
145 :     my $maskBackup = $safe->mask;
146 :     $safe->mask(empty_opset);
147 :     $safe->reval($include);
148 : sh002i 1695 $@ and die "Failed to reval include subroutine: $@";
149 : malsyned 1092 $safe->mask($maskBackup);
150 : sh002i 3674
151 : malsyned 283 # determine location of globalEnvironmentFile
152 : sh002i 2491 my $globalEnvironmentFile = "$seedVars{webwork_dir}/conf/global.conf";
153 : sh002i 319
154 : malsyned 283 # read and evaluate the global environment file
155 :     my $globalFileContents = readFile($globalEnvironmentFile);
156 : sh002i 319 $safe->reval($globalFileContents);
157 :    
158 :     # if that evaluation failed, we can't really go on...
159 :     # we need a global environment!
160 : malsyned 283 $@ and die "Could not evaluate global environment file $globalEnvironmentFile: $@";
161 :    
162 : jj 3682 # determine location of courseEnvironmentFile and simple configuration file
163 : sh002i 319 # 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 : jj 3682 my $courseWebConfigFile = $seedVars{web_config_filename} ||
168 :     ${*{${$safe->root."::"}{courseFiles}}}{simpleConfig};
169 : sh002i 319 use strict 'refs';
170 :    
171 : malsyned 283 # read and evaluate the course environment file
172 : sh002i 319 # if readFile failed, we don't bother trying to reval
173 :     my $courseFileContents = eval { readFile($courseEnvironmentFile) }; # catch exceptions
174 :     $@ or $safe->reval($courseFileContents);
175 : jj 3682 my $courseWebConfigContents = eval { readFile($courseWebConfigFile) }; # catch exceptions
176 :     $@ or $safe->reval($courseWebConfigContents);
177 : malsyned 304
178 : sh002i 319 # 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 : sh002i 4305 next if $name =~ /^(INC|_.*|__ANON__|main::)$/;
188 : sh002i 319 # 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 : malsyned 283 bless $self, $class;
204 : sh002i 3688
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 : malsyned 283 return $self;
217 :     }
218 :    
219 : sh002i 3688 =back
220 : sh002i 440
221 : sh002i 3688 =head1 ACCESS
222 : sh002i 440
223 : sh002i 3688 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 : sh002i 440
227 : sh002i 3688 $ce->{someKey}{someOtherKey};
228 : sh002i 440
229 : sh002i 3688 =head1 EXPERIMENTAL ACCESS METHODS
230 : sh002i 440
231 : sh002i 3688 This is an experiment in extending CourseEnvironment to know a little more about
232 :     its contents, and perform useful operations for me.
233 : sh002i 440
234 : sh002i 3688 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 : sh002i 440
240 : sh002i 3688 =head2 STATUS METHODS
241 :    
242 : sh002i 440 =over
243 :    
244 : sh002i 3688 =item status_abbrev_to_name($status_abbrev)
245 : sh002i 440
246 : sh002i 3688 Given the abbreviation for a status, return the name. Returns undef if the
247 :     abbreviation is not found.
248 : sh002i 440
249 : sh002i 3688 =cut
250 : sh002i 2491
251 : sh002i 3688 sub status_abbrev_to_name {
252 :     my ($ce, $status_abbrev) = @_;
253 : sh002i 3734 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 : sh002i 3727
258 : sh002i 3688 return $ce->{_status_abbrev_to_name}{$status_abbrev};
259 :     }
260 : sh002i 2491
261 : sh002i 3688 =item status_name_to_abbrevs($status_name)
262 : sh002i 2491
263 : sh002i 3688 Returns the list of abbreviations for a given status. Returns an empty list if
264 :     the status is not found.
265 : sh002i 440
266 : sh002i 3688 =cut
267 : sh002i 440
268 : sh002i 3688 sub status_name_to_abbrevs {
269 :     my ($ce, $status_name) = @_;
270 : sh002i 3734 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 : sh002i 3727
275 : sh002i 3688 return unless exists $ce->{statuses}{$status_name};
276 :     return @{$ce->{statuses}{$status_name}{abbrevs}};
277 :     }
278 : sh002i 440
279 : sh002i 3688 =item status_has_behavior($status_name, $behavior)
280 : sh002i 440
281 : sh002i 3688 Return true if $status_name lists $behavior.
282 : sh002i 440
283 : sh002i 3688 =cut
284 : sh002i 440
285 : sh002i 3688 sub status_has_behavior {
286 :     my ($ce, $status_name, $behavior) = @_;
287 : sh002i 3734 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 : sh002i 3727
296 : sh002i 3688 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 : sh002i 440 =cut
314 : sh002i 3688
315 :     sub status_abbrev_has_behavior {
316 :     my ($ce, $status_abbrev, $behavior) = @_;
317 : sh002i 3734 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 : sh002i 3727
326 : sh002i 3733 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 : sh002i 3734 warn "status abbreviation '$status_abbrev' not found in \%statuses -- assuming no behaviors.\n";
331 : sh002i 3733 }
332 : sh002i 3688 }
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