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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6635 - (download) (as text) (annotate)
Sun Dec 12 19:04:10 2010 UTC (9 years, 1 month ago) by gage
File size: 11202 byte(s)
change calls to use Safe.pm  to use WWSafe.pm

closed security hole in ProblemSetDetail.pm

other small improvements brought in from gage_dev



    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